続き
前の記事は
画像付き見出し付きテキストボックス作成のフローチャート書いてみた(１／２) ( ガーデニング ) - 午後わてんのブログ - Yahoo!ブログ
参照したところは
FLOWCHART
フローチャート-繰返し型
基本フローチャートを作成する
この辺り
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
これがさっきのフローチャートの画像作成の部分
その他の細かいメソッドや関数は
背景色や文字色の取得が
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
見出し部分の背景色の取得
フォームの
赤枠部分のどこにチェックが入っているかで色を決めている
見出し部分のフォントの色取得
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
これもフォームの
赤枠部分のどこにチェックが入っているかで決定
本文の文字色取得
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!ブログ
Yahoo!の人へのお願い
メール送っても無視されるからここに記録してみる
確認ボタンではエラーにならないけど投稿ボタンを押すとエラー
しばらく(1時間経過)してから投稿してもエラー
記事の文字数を減らせば投稿できるけど
書きなおすのがめんどくさい
コピペすると画像と水平線が消えるので文字以外は全部やり直し
めんどくさい！
1万文字でえらーになるのがおかしい
直せないとか直す気がないならそう言って欲しい…