画像付き見出し付きテキストボックス作成のフローチャート書いてみた(2/3) ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
↑の記事の続き
多分最後のページ、3分割とか初めてだわ
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(mASType, R.Left, R.Top, Wid, R.Height)
With Mida.TextFrame
.HorizontalAlignment = xlHAlignCenter
.VerticalAlignment = xlVAlignCenter
.Characters.Text = R.Value
textCount = .Characters.Count
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
Mida.Top = R.Top
Set AddMida見出し作成 = Mida
End Function
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
With TB.TextFrame
.Characters.Text = R.Value
If Me.CheckBoxTextAlignCenter.Value Then
.HorizontalAlignment = xlHAlignCenter
End If
textCount = .Characters.Count
End With
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
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
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
Public Type myRGB
iRed As Integer
iGreen As Integer
iBlue As Integer
End Type
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
Function Color2RGB(ByVal myColor As Long) As myRGB
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時間位かかった
全体の処理の流れを見るのにはいいかもしれないけどどうなのかなあ
半年後とか忘れたころに見ればまた違うのかも