午後わてんのブログ

ベランダ菜園とWindows用アプリ作成(WPFとC#)

画像付き見出し付きテキストボックス作成のフローチャート書いてみた(3/3)

画像付き見出し付きテキストボックス作成のフローチャート書いてみた(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
 

f:id:gogowaten:20191023134425p:plain

 
 
'本文の図形作成
'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
 

f:id:gogowaten:20191023134437p:plain

 
'見出しとテキストボックスの位置調整
'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
 
 
 
 

f:id:gogowaten:20191023134448p:plain

  
'画像付き見出し付きテキストボックスの位置調整
'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

 

 

f:id:gogowaten:20191023134500p:plain

'背景色の輝度の取得
'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時間位かかった
全体の処理の流れを見るのにはいいかもしれないけどどうなのかなあ
半年後とか忘れたころに見ればまた違うのかも