画像付き見出し付きテキストボックス作成のフローチャート書いてみた(2／3) ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
↑の記事の続き
多分最後のページ、3分割とか初めてだわ
見出し部分の図形作成
Rセル(range)
mASType図形の種類 （MsoAutoShapeType）
Wid図形の幅
fillC背景色
fontC文字色
Function AddMida見出し作成(R As Range, mASType As MsoAutoShapeType, Wid As Single, fillC As Long, fontC As Long) As Shape
Dim Mida As Shape
Dim i As Long
Dim ash As Worksheet
Set ash = ActiveSheet
Dim textCount As Long
'Set Mida = ash.Shapes.AddShape(msoShapeRectangle, R.Left, R.Top, Wid, R.Height)
Set Mida = ash.Shapes.AddShape(mASType, R.Left, R.Top, Wid, R.Height)
With Mida.TextFrame
.HorizontalAlignment = xlHAlignCenter '水平位置中央
.VerticalAlignment = xlVAlignCenter '垂直位置中央
.Characters.Text = R.Value '文字入れ
textCount = .Characters.Count '文字数カウント
' .MarginBottom = tCell.Font.Size / 4
' .MarginTop = tCell.Font.Size / 4
End With
With Mida
.Line.Weight = 0.1
.Line.ForeColor.RGB = fillC
.Fill.ForeColor.RGB = fillC '塗りつぶしの色
If Me.CheckBoxFillColorNothing.Value Then
.Fill.Transparency = 1 '背景色なしは完全透明
End If
End With
With Mida.TextFrame2.TextRange.Characters(1, textCount).Font
.Name = R.Font.Name 'フォント指定
.NameFarEast = R.Font.Name '日本語のフォント指定
'フォントサイズ
If Me.CheckBoxCaptionMagnification倍率.Value Then
.Size = R.Font.Size * 1.2
Else
.Size = R.Font.Size
End If
.Bold = msoTrue '太字指定
.Fill.ForeColor.RGB = fontC '文字色
End With
'テキストボックスの縦幅をテキストに合わせる
Mida.TextFrame2.AutoSize = msoAutoSizeShapeToFitText 'TextFrameのAutoSizeとは少し違い
'横幅は変化しないで高さだけが調整される＋少し高さが高くなる
'再度位置調整
Mida.Top = R.Top
Set AddMida見出し作成 = Mida
End Function
本文の図形作成
Rセル Range
Wid図形の幅 As Single
fontC文字色 As Long
lineC枠の色 As Long
Function AddTextBox本文図形作成(R As Range, Wid As Single, _
fontC As Long, lineC As Long) As Shape
Dim TB As Shape 'テキストボックス
Dim ash As Worksheet
Set ash = ActiveSheet
Dim textCount As Long
Set TB = ash.Shapes.AddTextbox(msoTextOrientationHorizontal, R.Left, R.Top, Wid, R.Height)
'枠の色
With TB.Line
.Weight = 0.1
.ForeColor.RGB = lineC
End With
'背景色
With TB.Fill
If Me.CheckBoxFillColorNothing.Value Then
.Transparency = 1 '完全透明
End If
End With
'テキストフレーム1
With TB.TextFrame
.Characters.Text = R.Value 'テキスト指定
If Me.CheckBoxTextAlignCenter.Value Then
.HorizontalAlignment = xlHAlignCenter '中央揃え
End If
textCount = .Characters.Count '文字数カウント
End With
'テキストフレーム2
With TB.TextFrame2.TextRange.Characters(1, textCount).Font
.Name = R.Font.Name 'フォント指定
.NameFarEast = R.Font.Name '日本語のフォント指定
.Size = R.Font.Size 'フォントサイズ
.Fill.ForeColor.RGB = fontC 'フォントカラー
End With
'セルの値をテキストボックスにリンク表示
If Me.CheckBoxTextLinkToCell.Value Then
TB.DrawingObject.Formula = R.Address
End If
'横幅そのままで高さだけをテキストに合わせる
TB.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
Set AddTextBox本文図形作成 = TB
End Function
見出しとテキストボックスの位置調整
myShape As Shape見出し用図形
myTB As Shapeテキストボックス
fitCell As Boolean位置をセルグリッドに合わせる
fitHeight As Booleanテキストボックスの下のラインをセルグリッドに合わせる
Public Sub ReadjustSub位置合わせ(myShape As Shape, myTB As Shape, _
Optional fitCell As Boolean = False, _
Optional fitHeight As Boolean = False)
Dim myTop As Single
'見出し用の図形をセルに合わせてから本文のテキストボックスを見出しにあわせる
If fitCell Then
Call FitShapes2Cell図形位置を最寄りのセルにピッタリ(myShape)
End If
myTop = myShape.Top
myShape.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
myShape.Top = myTop
With myTB
.Width = myShape.Width
.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
.TextFrame2.VerticalAnchor = msoAnchorTop
.Top = myShape.Top + myShape.Height
.Left = myShape.Left
'テキストボックスの高さの再調整してセルに合わせる
If fitHeight Then
Dim cellH As Single, TBH As Single
cellH = .BottomRightCell.Top + .BottomRightCell.Height
TBH = .Top + .Height
.TextFrame2.VerticalAnchor = msoAnchorMiddle '縦位置中央
.Height = .Height + (cellH - TBH)
End If
End With
End Sub
画像付き見出し付きテキストボックスの位置調整
Mida As Shape見出し用図形
TB As Shapeテキストボックス
Pic As Shape画像図形
Sub Adjust見出しとテキストボックスと画像の位置調整(Mida As Shape, TB As Shape, Pic As Shape)
'渡されたテキストボックスと見出しと画像の位置を再調整
With Mida
.Width = Pic.Width
.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
Pic.Left = .Left
If .Fill.Transparency = 0 Then
'見出しの背景色が完全不透明なら
Pic.Top = .Top + .Height
Else
Pic.Top = .Top
End If
End With
With Pic
TB.Width = .Width
TB.Top = .Top + .Height
TB.Left = .Left
TB.TextFrame2.AutoSize = msoAutoSizeShapeToFitText
End With
End Sub
背景色の輝度の取得
RGB各色の値の入れ物myRGB
Public Type myRGB
iRed As Integer
iGreen As Integer
iBlue As Integer
End Type
セルの背景色Range.Interior.Colorとかの値を渡して輝度を取得する
Color2HDTV
Function Color2HDTV(myColor As Long)
Dim rr As Double, gg As Double, bb As Double, X As Double
Dim R As Double, G As Double, B As Double
Dim iRGB As myRGB
iRGB = Color2RGB(myColor)
R = iRGB.iRed
G = iRGB.iGreen
B = iRGB.iBlue
rr = 0.222015
gg = 0.706655
bb = 0.07133
X = 2.2
R = (R ^ X) * rr
G = (G ^ X) * gg
B = (B ^ X) * bb
Dim Y
Y = (R + G + B) ^ (1 / X)
Color2HDTV = Y
End Function
セルの背景色Range.Interior.Colorとかの値を渡してRGB各色を取得する
Color2RGB
Function Color2RGB(ByVal myColor As Long) As myRGB
'Color(Long)をRGBにして返す
Dim iRGB As myRGB
With iRGB
.iRed = myColor Mod 256
.iGreen = Int(myColor / 256) Mod 256
.iBlue = Int(myColor / 256 / 256)
End With
Color2RGB = iRGB
End Function
ただでさえわかりにくい記事が3分割でもっとわかりにくくなってしまった
フローチャートはどこまで細かく書けばいいのかがわかんないなあ
あんまり細かく書くとプロシージャと差がないようなものができあがりそうだし
書いてる時は楽しいけど時間もかかる
今回のはかなり大雑把に書いたけど2時間位かかった
全体の処理の流れを見るのにはいいかもしれないけどどうなのかなあ
半年後とか忘れたころに見ればまた違うのかも