午後わてんのブログ

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

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

エクセルExcel2007 #ソフトウェア エクセルVBA
続き
前の記事は
画像付き見出し付きテキストボックス作成のフローチャート書いてみた(１／２) ( ガーデニング ) - 午後わてんのブログ - Yahoo!ブログ
 

f:id:gogowaten:20191023133306p:plain

フローチャートって初めて書いてみたけど時間かかる、2時間位かかった
参照したところは
この辺り
 
 
sakusei図形作成
Sub sakusei図形作成(sType As eTextBoxType, MidasiType As Long)
    Dim Mida As Shape '見出し図形
    Dim Hon As Shape '本文図形
    Dim fillC As Long '見出し背景色
    Dim fontC As Long '見出し文字の色
    Dim mASType As MsoAutoShapeType '図形の種類
    'テキストボックス(本文)
    Dim tbLineC As Long 'テキストボックス枠の色
    Dim tbFontC As Long 'テキストボックスフォントカラー
'    Dim tbFillC As Long 'テキストボックス背景色
    Dim TB As Shape 'テキストボックス
    Dim TBR As Range 'テキストボックス用セル
    Dim fitHeight As Boolean
    
    '画像図形
    Dim Pic As Shape '画像図形
    Dim PR As Range '画像ファイルのパスがあるセル
    Dim pName As String '画像ファイルのパス
    
    Dim GP As Shape
    Dim RS  As Range, R As Range
    Dim Area As Areas
    Dim ash As Worksheet
    Dim i As Long, j As Long
    Set ash = ActiveSheet
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Set Area = Selection.Areas
    'mASType = Me.CommandButton4.Tag ' msoShapeRectangle'ボタンのtagで作成する図形を指定する
    
    
    For i = 1 To Area.Count
        Set RS = Area(i)
        For j = 1 To RS.Rows.Count
            Set R = RS.Cells(j, 1)
            Set TBR = R.Offset(, 1)
            Set PR = R.Offset(, 2)
            '画像付きの時、画像ファイルの確認
            If sType = PicAndTextBoxWihtMidasi Then
                
                pName = PR.Value
                '画像ファイルパスが空欄ならファイル指定ダイアログ表示
                If pName = "" Then
                    pName = Application.GetOpenFilename(",*.jpg;*.jpeg;*.bmp;*.png;*.gif", , R.Value)
                End If
                If pName = "False" Then Exit Sub '画像指定でキャンセルされたら終了
                
                '画像ファイルの存在確認
                If Dir(pName) = "" Then
                    MsgBox "指定されたファイル 「" & pName & "」 は見つからなかったので処理を終了"
                    Exit Sub '存在しないファイル名なら終了
                ElseIf Judge画像ファイル拡張子で判定(pName) = False Then
                    MsgBox "指定されたファイル" & vbNewLine _
                        & pName & vbNewLine _
                        & "は開くことができなかったので処理を終了"
                    Exit Sub '拡張子が画像以外なら終了
                End If
            End If
            
            '背景色や文字色の取得
            fillC = GetFillColor背景色(R)
            fontC = GetFontColor見出しの文字の色(R, fillC)
            honFontC = GetFontColor本文の文字の色(fillC)
            tbLineC = fillC
            tbFontC = GetFontColor本文の文字の色(fillC)
            
            '見出しの図形作成
            'Set Mida = AddMida見出し作成(R, mASType, 160, fillC, fontC)
            Set Mida = AddMida見出し作成(R, MidasiType, 160, fillC, fontC)
            Mida.Placement = xlMove
                        
            If sType = TextBoxWithMidasi Then
            '見出し付きTB
                '本文用のテキストボックス作成
                Set TB = AddTextBox本文図形作成(TBR, 160, tbFontC, tbLineC)
                '見出しと本文の位置調整
                'Dim fitCell As Boolean: fitCell = Me.CheckBoxFitHeightToCell.Value
                fitHeight = Me.CheckBoxFitHeightToCell.Value
                Call ReadjustSub位置合わせ(Mida, TB, False, fitHeight)
                
                'グループ化
                Set GP = ash.Shapes.Range(Array(Mida.Name, TB.Name)).Group
                GP.Placement = xlMove 'セルに合わせて移動するけどサイズ変更はしない
            ElseIf sType = PicAndTextBoxWihtMidasi Then
            '画像付き見出し付きテキストボックス
                '本文用のテキストボックス作成
                Set TB = AddTextBox本文図形作成(TBR, 160, tbFontC, tbLineC)
                Set Pic = GetPictureFromFile(pName)
                Call Adjust見出しとテキストボックスと画像の位置調整(Mida, TB, Pic)
                'グループ化
                Set GP = ash.Shapes.Range(Array(Mida.Name, TB.Name, Pic.Name)).Group
                GP.Placement = xlMove
                
            End If
                    
        Next j
    Next i
        
End Sub

f:id:gogowaten:20191023133322p:plain

これがさっきのフローチャートの画像作成の部分
 
 
その他の細かいメソッドや関数は
背景色や文字色の取得が
Function GetFillColor背景色(R As Range) As Long
'背景色を返す、使う引数はセル
    Dim myColor As Long
    Select Case True
        Case myFillForeColor = Sample '見本の色
           myColor = Me.LabelSampleColor色見本.BackColor
        Case myFillForeColor = Random 'ランダム
            Randomize
            myColor = Int((16777215 - 0 + 1) * Rnd(16777215) - 0)
        Case myFillForeColor = CellLink 'セルと同じ色
            myColor = R.Interior.Color
        Case myFillForeColor = Unspecified '指定なしは初期テーマカラー
            Dim ash As Workbook
            Set ash = ActiveWorkbook
            myColor = ash.Theme.ThemeColorScheme.Colors(msoThemeAccent1)
            
    End Select
    GetFillColor背景色 = myColor
    
End Function

f:id:gogowaten:20191023133334p:plain

見出し部分の背景色の取得
フォームの

f:id:gogowaten:20191023133344p:plain

赤枠部分のどこにチェックが入っているかで色を決めている
 
 
 
見出し部分のフォントの色取得
Function GetFontColor見出しの文字の色(R As Range, fillC As Long) As Long
    Dim myColor As Long
    Dim Y As Double
    Select Case True
        Case myFontColor = fcAuto 'オート、白or灰色
            Y = Color2HDTV(fillC)
            If Y < 230 Then
                myColor = RGB(255, 255, 255)
            Else
                myColor = RGB(192, 192, 192)
            End If
        Case myFontColor = fcBlack '黒
            myColor = RGB(0, 0, 0)
        Case myFontColor = fcCell 'セルと同じ色
            myColor = R.Font.Color
        Case myFontColor = fcRandom 'ランダム
            Randomize
            myColor = Int((16777215 - 0 + 1) * Rnd(16777215) - 0)
        Case myFontColor = fcWhite '白
            myColor = RGB(255, 255, 255)
        Case myFontColor = fcWorB '白or黒の自動判別
            Y = Color2HDTV(fillC)
            If Y < 230 Then
                myColor = RGB(255, 255, 255)
            Else
                myColor = RGB(0, 0, 0)
            End If
    End Select
    GetFontColor見出しの文字の色 = myColor
End Function

f:id:gogowaten:20191023133354p:plain

これもフォームの

f:id:gogowaten:20191023133404p:plain

赤枠部分のどこにチェックが入っているかで決定
 
本文の文字色取得
Function GetFontColor本文の文字の色(fillC As Long) As Long
    Dim myColor As Long
    Dim Y As Double
    Select Case True
        Case myTextFontColor = tfcAuto
            Y = (Color2HDTV(fillC) / 2)
            myColor = RGB(Y, Y, Y)
        Case myTextFontColor = tfcBlack
            myColor = RGB(0, 0, 0)
    End Select
    
    GetFontColor本文の文字の色 = myColor
End Function
またエラーになったので分割
続きは
画像付き見出し付きテキストボックス作成のフローチャート書いてみた(3／3) ( ソフトウェア ) - 午後わてんのブログ - Yahoo!ブログ
 
 
 
 
 
 
 
2019/10/23追記ここから
以下の状況は後日対応してもらって解決したので取り消し
主な原因はタブ文字が空白4文字になっていて、これで見かけより多くの文字数が消費されていたから
追記ここまで
 
Yahoo!の人へのお願い
メール送っても無視されるからここに記録してみる

f:id:gogowaten:20191023133422p:plain

確認ボタンではエラーにならないけど投稿ボタンを押すとエラー
しばらく(1時間経過)してから投稿してもエラー
記事の文字数を減らせば投稿できるけど
書きなおすのがめんどくさい
コピペすると画像と水平線が消えるので文字以外は全部やり直し
めんどくさい！
 
 

f:id:gogowaten:20191023133456p:plain

だいたい文字数だって2万文字までOKって言っているのに

1万文字でえらーになるのがおかしい

直せないとか直す気がないならそう言って欲しい…