既存のワークシートの構成を取得するためのコード集
（Microsoft365 64bit環境推奨）
G-Tool1-A01 からのつづき
６．【Alt】＋【F11】キーを押下し、VBE画面を出す。
７．【挿入】タブから【標準モジュール】を選択し、標準モジュールを作成。
８．下記ボックス内をコピーし、標準モジュールに貼り付ける。
９．モジュール名を【M12_Color】に変更する。
モジュール名：M03_GetSettingSht
Option Explicit '==================================================== ' 行高、列幅取得 '==================================================== Sub getRowHeightAry() Dim i As Long Dim j As Long Dim MaxRow As Long '最終行 Dim MaxCol As Long '最終列 Dim tgtCol As Long Dim buf As String Dim strAry As String Dim nmlTmn As Boolean '正常終了フラグ：normal Termination Bln_Err = False nmlTmn = False ErrProsName = "getRowHeightAry" On Error GoTo getRowHeightAry_Err Call StopUpdating IsCall = False '初期値 With ActiveSheet buf = "" strAry = "" '使用済み範囲の最終行、最終列 With .UsedRange MaxRow = .Rows(.Rows.Count).Row MaxCol = .Columns(.Columns.Count).Column End With For i = 1 To MaxRow buf = .Rows(i).RowHeight & "," strAry = strAry & buf Next i Debug.Print "行高：" & "0," & Left(strAry, InStrRev(strAry, ",") - 1) buf = "" strAry = "" For j = 1 To MaxCol buf = .Columns(j).ColumnWidth & "," strAry = strAry & buf Next j Debug.Print "列幅：" & "0," & Left(strAry, InStrRev(strAry, ",") - 1) End With ' ' Debug.Print Left(strAry, InStrRev(strAry, ",") - 1) '' Debug.Print strAry getRowHeightAry_Exit: 'エラーを無視 On Error Resume Next Call Updating If nmlTmn Then MsgBox " 完了♪" End If 'エラー制御を戻す On Error GoTo 0 Exit Sub getRowHeightAry_Err: Bln_Err = True MsgBox "実行時エラー:" & Err.Nuer & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName Err.Clear 'エラー情報クリア GoTo getRowHeightAry_Exit End Sub '+++*******************************************************+++ ' アクティブシートのボタン等の情報取得 '+++*******************************************************+++ Sub getShpData() Dim shp As Shape Dim shpCnt As Long Dim gBoxCnt As Long Dim btn As Object Dim btnCnt As Long Dim txtbCnt As Long Dim tgtShpCnt As Long Dim myName As String Dim myText As String Dim myFontSize As Double Dim myFontBold As Boolean Dim myMacro As String Dim myLeft As Double Dim myTop As Double Dim myWidth As Double Dim myHeight As Double Dim mybkClr As Long Dim mylineClr As Long Dim mylineW As Double Dim mylineStl As Double Dim myshpType As Double Dim i As Long Dim j As Long Dim i1 As Long Dim i0 As Long Dim i4 As Long Dim i7 As Long Dim i17 As Long Dim optBtn As Object Dim optBtnCnt As Long Dim buf As String Dim shp1Array() As Variant Dim shp2Array() As Variant Dim btn1Array() As Variant Dim btn2Array() As Variant Dim gpb1Array() As Variant Dim gpb2Array() As Variant Dim opt1Array() As Variant Dim opt2Array() As Variant Dim txtb1Array() As Variant Dim txtb2Array() As Variant Dim lmtNo As Long Dim temp As String Dim myStr As String Dim var As Variant Dim myAry() As Variant Dim strResult As String Dim objfso As Object Dim notePath As String Set objfso = CreateObject("Scripting.FileSystemObject") notePath = ThisWorkbook.Path & "\myNote.log" '記録用テキストファイルが存在する場合 If objfso.FileExists(notePath) Then Kill notePath End If With ActiveSheet '--- 全シェイプ数 shpCnt = ActiveSheet.Shapes.Count Debug.Print "シェイプ数：" & shpCnt For Each shp In ActiveSheet.Shapes If shp.Type = msoAutoShape Then '1:オートシェイプ tgtShpCnt = tgtShpCnt + 1 ' ElseIf shp.Type = msoTextBox Then '17:テキスト ボックス ' txtbCnt = txtbCnt + 1 End If Next shp '対象シェイプ（フォームコントロール以外） Debug.Print "対象シェイプ数：" & tgtShpCnt ReDim shp1Array(tgtShpCnt, 7) ReDim shp2Array(tgtShpCnt, 3) '0:ボタン btnCnt = .Buttons.Count Debug.Print "ボタン数：" & btnCnt ReDim btn1Array(btnCnt, 3) ReDim btn2Array(btnCnt, 3) '4:グループ ボックス gBoxCnt = .GroupBoxes.Count Debug.Print "グループボックス数：" & gBoxCnt ReDim gpb1Array(gBoxCnt, 7) ReDim gpb2Array(gBoxCnt, 3) '7:オプションボタン optBtnCnt = .OptionButtons.Count Debug.Print "オプションボタン数：" & optBtnCnt ReDim opt1Array(optBtnCnt, 7) ReDim opt2Array(optBtnCnt, 3) '17:テキストボックス txtbCnt = .TextBoxes.Count Debug.Print "テキストボックス数：" & txtbCnt ReDim txtb1Array(txtbCnt, 7) ReDim txtb2Array(txtbCnt, 3) For Each shp In .Shapes 'エラーを無視 On Error Resume Next With shp ' Debug.Print "名前：" & .Name ' Debug.Print "文字：" & .TextFrame.Characters.Text ' Debug.Print " 左の位置：" & .Left ' Debug.Print " 上の位置：" & .Top ' Debug.Print " 横幅：" & .Width ' Debug.Print " 高さ：" & .Height ' Debug.Print " タイプ：" & .AutoShapeType ' Debug.Print " 背景色：" & .Fill.ForeColor.RGB ' Debug.Print " 透過率：" & .Fill.Transparency ' Debug.Print " 枠線の色：" & .Line.ForeColor.RGB ' Debug.Print " 表示非表示：" & .Visible ' Debug.Print " タイプ：" & .AutoShapeType ' Debug.Print " 線太さ：" & .Line.Weight ' Debug.Print " 線のスタイル：" & .Line.DashStyle '--- 初期化 myName = "" '名前 myText = "" '表示文字 myFontSize = 0 '文字のサイズ myFontBold = False '太文字か否か myMacro = "" '登録マクロ名 myLeft = 0 '左位置 myTop = 0 '上位置 myWidth = 0 '幅 myHeight = 0 '高さ mybkClr = 0 '背景色 mylineClr = 0 '線の色 mylineW = 0 '線の太さ mylineStl = 0 '線の種類 myshpType = 0 '形のタイプ '--- 登録 myName = .Name '名前 With .TextFrame.Characters 'テキスト myText = .Text '表示文字 myFontSize = .Font.Size '文字のサイズ myFontBold = .Font.Bold '太文字か否か End With myMacro = .OnAction '登録マクロ名 myLeft = .Left '左位置 myTop = .Top '上位置 myWidth = .Width '幅 myHeight = .Height '高さ mybkClr = .Fill.ForeColor.RGB '背景色 mylineClr = .Line.ForeColor.RGB '線の色 mylineW = .Line.Weight '線の太さ mylineStl = .Line.DashStyle '線の種類 myshpType = .AutoShapeType '形のタイプ End With If shp.Type = msoAutoShape Then '1:オートシェイプ i1 = i1 + 1 shp1Array(i1, 0) = myName '0:名前 shp1Array(i1, 1) = myText '1:表示文字 shp1Array(i1, 2) = myFontSize '2:文字のサイズ shp2Array(i1, 0) = Round(myLeft, 3) '0:左位置 shp2Array(i1, 1) = Round(myTop, 3) '1:上位置 shp2Array(i1, 2) = Round(myWidth, 3) '2:幅 shp2Array(i1, 3) = Round(myHeight, 3) '3:高さ shp1Array(i1, 3) = mybkClr '3:背景色 shp1Array(i1, 4) = mylineClr '4:線の色 shp1Array(i1, 5) = mylineW '5:線の太さ shp1Array(i1, 6) = mylineStl '6:線の種類 shp1Array(i1, 7) = myshpType '7:形のタイプ ElseIf shp.Type = msoFormControl Then '8:フォーム コントロール Select Case shp.FormControlType Case xlButtonControl '0:ボタン i0 = i0 + 1 btn1Array(i0, 0) = myName '0:名前 btn1Array(i0, 1) = myText '1:表示文字 btn1Array(i0, 2) = myFontSize '2:文字のサイズ btn2Array(i0, 0) = Round(myLeft, 3) '0:左位置 btn2Array(i0, 1) = Round(myTop, 3) '1:上位置 btn2Array(i0, 2) = Round(myWidth, 3) '2:幅 btn2Array(i0, 3) = Round(myHeight, 3) '3:高さ btn1Array(i0, 3) = myMacro '登録マクロ名 Case xlGroupBox '4:グループ ボックス i4 = i4 + 1 gpb1Array(i4, 0) = myName '0:名前 gpb1Array(i4, 1) = myText '1:表示文字 gpb1Array(i4, 2) = myFontSize '2:文字のサイズ gpb2Array(i4, 0) = Round(myLeft, 3) '0:左位置 gpb2Array(i4, 1) = Round(myTop, 3) '1:上位置 gpb2Array(i4, 2) = Round(myWidth, 3) '2:幅 gpb2Array(i4, 3) = Round(myHeight, 3) '3:高さ gpb1Array(i4, 3) = mybkClr '3:背景色 gpb1Array(i4, 4) = mylineClr '4:線の色 gpb1Array(i4, 5) = mylineW '5:線の太さ gpb1Array(i4, 6) = mylineStl '6:線の種類 gpb1Array(i4, 7) = myshpType '7:形のタイプ Case xlOptionButton '7:オプション ボタン i7 = i7 + 1 opt1Array(i7, 0) = myName '0:名前 opt1Array(i7, 1) = myText opt1Array(i7, 2) = myFontSize '2:文字のサイズ opt2Array(i7, 0) = Round(myLeft, 3) '0:左位置 opt2Array(i7, 1) = Round(myTop, 3) '1:上位置 opt2Array(i7, 2) = Round(myWidth, 3) '2:幅 opt2Array(i7, 3) = Round(myHeight, 3) '3:高さ opt1Array(i7, 3) = mybkClr '3:背景色 opt1Array(i7, 4) = mylineClr '4:線の色 opt1Array(i7, 5) = mylineW '5:線の太さ opt1Array(i7, 6) = mylineStl '6:線の種類 opt1Array(i7, 7) = myshpType '7:形のタイプ End Select ElseIf shp.Type = msoTextBox Then '17:テキスト ボックス i17 = i17 + 1 txtb1Array(i17, 0) = myName '0:名前 txtb1Array(i17, 1) = myText '1:表示文字 txtb1Array(i17, 2) = myFontSize '2:文字のサイズ txtb2Array(i17, 0) = Round(myLeft, 3) '0:左位置 txtb2Array(i17, 1) = Round(myTop, 3) '1:上位置 txtb2Array(i17, 2) = Round(myWidth, 3) '2:幅 txtb2Array(i17, 3) = Round(myHeight, 3) '3:高さ txtb1Array(i17, 3) = myMacro '登録マクロ名 txtb1Array(i17, 4) = mybkClr '3:背景色 txtb1Array(i17, 5) = mylineClr '4:線の色 txtb1Array(i17, 6) = mylineW '5:線の太さ txtb1Array(i17, 7) = mylineStl '6:線の種類 txtb1Array(i17, 8) = myshpType '7:形のタイプ End If Next End With '****************************************************************************** lmtNo = 60 '=== シェイプの処理 strResult = "'--- 取得したシェイプ情報" 'Debug.Print strResult writeNote (strResult) strResult = "対象シェイプ数：" & UBound(shp1Array, 1) 'Debug.Print strResult writeNote (strResult) temp = "" buf = "" myStr = "" For j = 0 To UBound(shp1Array, 2) temp = "shp1Array(" & j & ")(" For i = 0 To UBound(shp1Array, 1) buf = shp1Array(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(shp1Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) myStr = "" Next j myStr = "" buf = "" temp = "shp2Array(""0,0,0,0""," For i = 1 To UBound(shp2Array, 1) buf = """" For j = 0 To UBound(shp2Array, 2) buf = buf & shp2Array(i, j) & "," Next j buf = buf & shp2Array(i, 3) & """," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(shp2Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = "位置:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) '=== ボタンの処理 strResult = "'--- 取得したボタン情報" 'Debug.Print strResult writeNote (strResult) strResult = "対象ボタン数：" & UBound(btn1Array, 1) 'Debug.Print strResult writeNote (strResult) temp = "" buf = "" myStr = "" For j = 0 To UBound(btn1Array, 2) temp = "btn1Array(" & j & ")(" For i = 0 To UBound(btn1Array, 1) buf = btn1Array(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(btn1Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) myStr = "" Next j myStr = "" buf = "" temp = "btn2Array(""0,0,0,0""," For i = 1 To UBound(btn2Array, 1) buf = """" For j = 0 To UBound(btn2Array, 2) buf = buf & btn2Array(i, j) & "," Next j buf = buf & btn2Array(i, 3) & """," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(btn2Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = "位置:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) '=== グループボックスの処理 strResult = "'--- 取得したグループボックス情報" 'Debug.Print strResult writeNote (strResult) strResult = "対象グループボックス数：" & UBound(gpb1Array, 1) 'Debug.Print strResult writeNote (strResult) temp = "" buf = "" myStr = "" For j = 0 To UBound(gpb1Array, 2) temp = "gpb1Array(" & j & ")(" For i = 0 To UBound(gpb1Array, 1) buf = gpb1Array(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(gpb1Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) myStr = "" Next j myStr = "" buf = "" temp = "gpb2Array(""0,0,0,0""," For i = 1 To UBound(gpb2Array, 1) buf = """" For j = 0 To 2 buf = buf & gpb2Array(i, j) & "," Next j buf = buf & gpb2Array(i, 3) & """," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(gpb2Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = "位置:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) '=== オプションボタンの処理 strResult = "'--- 取得したオプションボタン情報" 'Debug.Print strResult writeNote (strResult) strResult = "オプションボタン数：" & optBtnCnt 'Debug.Print strResult writeNote (strResult) temp = "" buf = "" myStr = "" For j = 0 To UBound(opt1Array, 2) temp = "opt1Array(" & j & ")(" For i = 0 To UBound(opt1Array, 1) buf = opt1Array(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(opt1Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) myStr = "" Next j myStr = "" buf = "" temp = "opt2Array(""0,0,0,0""," For i = 1 To UBound(opt2Array, 1) buf = """" For j = 0 To 2 buf = buf & opt2Array(i, j) & "," Next j buf = buf & opt2Array(i, 3) & """," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(opt2Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = "位置:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) '=== テキストボックスの処理 strResult = "'--- 取得したテキストボックス情報" 'Debug.Print strResult writeNote (strResult) strResult = "対象テキストボックス数：" & UBound(shp1Array, 1) 'Debug.Print strResult writeNote (strResult) temp = "" buf = "" myStr = "" For j = 0 To UBound(txtb1Array, 2) temp = "txtb1Array(" & j & ")(" For i = 0 To UBound(txtb1Array, 1) buf = txtb1Array(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(txtb1Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) myStr = "" Next j myStr = "" buf = "" temp = "txtb2Array(""0,0,0,0""," For i = 1 To UBound(txtb2Array, 1) buf = """" For j = 0 To 2 buf = buf & txtb2Array(i, j) & "," Next j buf = buf & txtb2Array(i, 3) & """," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(txtb2Array, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i strResult = "位置:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" 'Debug.Print strResult writeNote (strResult) End Sub '+++**************************************************************+++ ' csvファイルに結果を記録 '+++**************************************************************+++ Sub writeNote(strResult As String) Dim objfso As Object Dim notePath As String Set objfso = CreateObject("Scripting.FileSystemObject") notePath = ThisWorkbook.Path & "\myNote.log" 'ログがなければ作ります If objfso.FileExists(notePath) = False Then objfso.CreateTextFile notePath End If '追記で開きます With objfso.OpenTextFile(notePath, ForAppending) .WriteLine strResult .Close End With Set objfso = Nothing End Sub ' +++*******************************************************+++ ' フォームコントロール ボタンのみ取得例 ' +++*******************************************************+++ Sub getBottunsData() Dim i As Long Dim j As Long Dim btn As Object Dim btnCnt As Long Dim buf As String Dim myArray() As Variant Dim lmtNo As Long Dim temp As String Dim myStr As String Dim var As Variant Dim myAry() As Variant With ActiveSheet btnCnt = .Buttons.Count ReDim myArray(btnCnt, 6) For Each btn In .Buttons i = i + 1 On Error Resume Next With btn ' Debug.Print i & " 名前：" & .Name ' Debug.Print i & " 文字：" & .Characters.Text ' Debug.Print i & " 左の位置：" & .Left ' Debug.Print i & " 上の位置：" & .Top ' Debug.Print i & " 横幅：" & .Width ' Debug.Print i & " 高さ：" & .Height ' Debug.Print i & " マクロ：" & .OnAction myArray(i, 0) = .Name myArray(i, 1) = .Characters.Text myArray(i, 2) = .OnAction myArray(i, 3) = Round(.Left, 3) myArray(i, 4) = Round(.Top, 3) myArray(i, 5) = Round(.Width, 3) myArray(i, 6) = Round(.Height, 3) End With 'エラー制御を戻す On Error GoTo 0 Next btn End With lmtNo = 60 For j = 0 To 2 temp = "myArray(" & j & ")(" For i = 0 To UBound(myArray, 1) buf = myArray(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(myArray, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i Debug.Print j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" myStr = "" Next j myStr = "" buf = "" temp = "myArray(3)((0,0,0,0)," For i = 1 To UBound(myArray, 1) buf = "(" For j = 3 To 5 buf = buf & myArray(i, j) & "," Next j buf = buf & myArray(i, 6) & ")," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(myArray, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i Debug.Print "3:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" End Sub ' +++*******************************************************+++ ' フォームコントロール オプションボタンのみ取得例 ' +++*******************************************************+++ Sub getOptionBottunsData() Dim i As Long Dim j As Long Dim optBtn As Object Dim optBtnCnt As Long Dim buf As String Dim myArray() As Variant Dim lmtNo As Long Dim temp As String Dim myStr As String Dim var As Variant Dim myAry() As Variant With ActiveSheet optBtnCnt = .OptionButtons.Count Debug.Print optBtnCnt ReDim myArray(optBtnCnt, 5) For Each optBtn In .OptionButtons i = i + 1 On Error Resume Next With optBtn Debug.Print i & " 名前：" & .Name ' Debug.Print i & " 文字：" & .Characters.Text ' Debug.Print i & " 左の位置：" & .Left ' Debug.Print i & " 上の位置：" & .Top ' Debug.Print i & " 横幅：" & .Width ' Debug.Print i & " 高さ：" & .Height myArray(i, 0) = .Name myArray(i, 1) = .Characters.Text myArray(i, 2) = Round(.Left, 3) myArray(i, 3) = Round(.Top, 3) myArray(i, 4) = Round(.Width, 3) myArray(i, 5) = Round(.Height, 3) End With 'エラー制御を戻す On Error GoTo 0 Next optBtn End With lmtNo = 60 For j = 0 To 2 temp = "myArray(" & j & ")(" For i = 0 To UBound(myArray, 1) buf = myArray(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(myArray, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i Debug.Print j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" myStr = "" Next j myStr = "" buf = "" temp = "myArray(3)((0,0,0,0)," For i = 1 To UBound(myArray, 1) buf = "(" For j = 2 To 4 buf = buf & myArray(i, j) & "," Next j buf = buf & myArray(i, 5) & ")," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(myArray, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i Debug.Print "3:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" End Sub ' +++*******************************************************+++ ' フォームコントロール オプションボタンのみ取得例 ' +++*******************************************************+++ Sub getGroupBoxData() Dim i As Long Dim j As Long Dim gBox As Object Dim gBoxCnt As Long Dim buf As String Dim myArray() As Variant Dim lmtNo As Long Dim temp As String Dim myStr As String Dim var As Variant Dim myAry() As Variant With ActiveSheet gBoxCnt = .GroupBoxes.Count Debug.Print gBoxCnt ReDim myArray(gBoxCnt, 5) For Each gBox In .GroupBoxes i = i + 1 On Error Resume Next With gBox ' Debug.Print i & " 名前：" & .Name ' Debug.Print i & " 文字：" & .Characters.Text ' Debug.Print i & " 左の位置：" & .Left ' Debug.Print i & " 上の位置：" & .Top ' Debug.Print i & " 横幅：" & .Width ' Debug.Print i & " 高さ：" & .Height ' Debug.Print i & " マクロ：" & .OnAction Debug.Print i & " 背景色：" & .Fill.ForeColor.RGB myArray(i, 0) = .Name '0:名前 myArray(i, 1) = .Characters.Text '1:表示文字 myArray(i, 2) = Round(.Left, 3) '2:左位置 myArray(i, 3) = Round(.Top, 3) '3:上位置 myArray(i, 4) = Round(.Width, 3) '4:幅 myArray(i, 5) = Round(.Height, 3) '5:高さ End With 'エラー制御を戻す On Error GoTo 0 Next gBox End With lmtNo = 60 For j = 0 To 1 temp = "myArray(" & j & ")(" For i = 0 To UBound(myArray, 1) buf = myArray(i, j) buf = """" & buf & """, " var = StrConv(temp & buf, vbFromUnicode) If i = UBound(myArray, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i Debug.Print j & ":" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" myStr = "" Next j myStr = "" buf = "" temp = "myArray(2)((0,0,0,0)," For i = 1 To UBound(myArray, 1) buf = "(" For j = 2 To 4 buf = buf & myArray(i, j) & "," Next j buf = buf & myArray(i, 5) & ")," var = StrConv(temp & buf, vbFromUnicode) If i = UBound(myArray, 1) Then If LenB(var) <= lmtNo Then myStr = myStr & temp & buf Else myStr = myStr & temp & " _" & vbCrLf & _ buf End If ElseIf LenB(var) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i Debug.Print "2:" & Left(myStr, InStrRev(myStr, ",") - 1) & ")" End Sub '***************************************************** ' アクティブセル 色等取得 '***************************************************** Public Sub GetRngColorA() Dim valH As Long Dim valV As Long Dim strH As String Dim strV As String Debug.Print "背景色：" & ActiveCell.Interior.Color Debug.Print "文字色：" & ActiveCell.Font.Color valH = ActiveCell.HorizontalAlignment valV = ActiveCell.VerticalAlignment Select Case valH Case -4108 strH = "xlHAlignCenter,中央揃え" Case -4117 strH = "xlHAlignDistributed,均等割り付け" Case -4130 strH = "xlHAlignJustify,両端揃え" Case -4131 strH = "xlHAlignLeft ,左詰め" Case -4152 strH = "xlHAlignRight,右詰め" Case 7 strH = "xlHAlignCenterAcrossSelection,選択範囲内で中央" Case 5 strH = "xlHAlignFill,繰り返し" Case 1 strH = "xlHAlignGeneral ,標準" End Select Select Case valV Case -4107 strV = "xlVAlignBottom ,下詰めえ" Case -4108 strV = "xlVAlignCenter,中央揃え" Case -4117 strV = "xlVAlignDistributed,均等割り付け" Case -4130 strV = "xlVAlignJustify ,両端揃え" Case -4160 strV = "xlVAlignTop,上詰め " End Select Debug.Print "文字の横方向の配置：" & strH Debug.Print "文字の縦方向の配置：" & strV End Sub '***************************************************** ' アクティブshape 色等取得 '***************************************************** Public Sub GetActiveShpColor() Dim shp As Shape 'アクティブシート内の図形/画像の中心位置をピクセル単位で取得 With ActiveSheet 'エラーを無視 On Error Resume Next With Selection.ShapeRange Debug.Print "名前：" & .Name Debug.Print "文字：" & .TextFrame.Characters Debug.Print " 左の位置：" & .Left Debug.Print " 上の位置：" & .Top Debug.Print " 横幅：" & .Width Debug.Print " 高さ：" & .Height Debug.Print " タイプ：" & .AutoShapeType Debug.Print " 背景色：" & .Fill.ForeColor.RGB Debug.Print " 透過率：" & .Fill.Transparency Debug.Print " 枠線の色：" & .Line.ForeColor.RGB End With 'エラー制御を戻す On Error GoTo 0 End With End Sub '***************************************************** ' アクティブシートシェイプ 色等取得 ' グループ化されたシェイプは取得されないので注意 '***************************************************** Public Sub GetShpColorA() Dim shp As Shape Dim Cnt As Long Cnt = ActiveSheet.Shapes.Count Debug.Print " シェイプ数：" & Cnt 'アクティブシート内の図形 For Each shp In ActiveSheet.Shapes 'エラーを無視 On Error Resume Next With shp Debug.Print "名前：" & .Name Debug.Print "文字：" & .TextFrame.Characters.Text Debug.Print " 左の位置：" & .Left Debug.Print " 上の位置：" & .Top Debug.Print " 横幅：" & .Width Debug.Print " 高さ：" & .Height Debug.Print " タイプ：" & .AutoShapeType Debug.Print " 背景色：" & .Fill.ForeColor.RGB Debug.Print " 透過率：" & .Fill.Transparency Debug.Print " 枠線の色：" & .Line.ForeColor.RGB Debug.Print " 表示非表示：" & .Visible End With 'エラー制御を戻す On Error GoTo 0 Next shp End Sub '***************************************************** ' アクティブシートシェイプ 色等を配列に取得 ' グループ化されたシェイプは取得されないので注意 '***************************************************** Public Sub GetShpArrayA() Dim shp As Shape Dim Cnt As Long Dim i As Long Dim j As Long Dim myArray() As Variant Cnt = ActiveSheet.Shapes.Count Debug.Print " シェイプ数：" & Cnt 'アクティブシート内の図形 For Each shp In ActiveSheet.Shapes 'エラーを無視 On Error Resume Next With shp Debug.Print "名前：" & .Name Debug.Print "文字：" & .TextFrame.Characters.Text Debug.Print " 左の位置：" & .Left Debug.Print " 上の位置：" & .Top Debug.Print " 横幅：" & .Width Debug.Print " 高さ：" & .Height Debug.Print " タイプ：" & .AutoShapeType Debug.Print " 背景色：" & .Fill.ForeColor.RGB Debug.Print " 透過率：" & .Fill.Transparency Debug.Print " 枠線の色：" & .Line.ForeColor.RGB Debug.Print " 表示非表示：" & .Visible End With 'エラー制御を戻す On Error GoTo 0 Next shp End Sub '==================================================== ' セル文字を配列に格納 '==================================================== Sub SetAry() Dim i As Long Dim sttRow As Long '開始行 Dim midiRow As Long '中間行 Dim MaxRow As Long '最終行 Dim MaxCol As Long '最終列 Dim tgtCol As Long '対象列 Dim lmtNo As Long '文字：折り返しまでの限界値 Dim buf As String Dim temp As String Dim myStr As String Dim buf2 As String Dim temp2 As String Dim myStr2 As String Dim nmlTmn As Boolean '正常終了フラグ：normal Termination Bln_Err = False nmlTmn = False ErrProsName = "SetAry" On Error GoTo SetAry_Err Call StopUpdating IsCall = False '初期値 With ActiveSheet sttRow = 2 tgtCol = 3 '切り替えて使用 lmtNo = 52 ' tgtCol = 15 '切り替えて使用 ' lmtNo = 65 '' 'A列基準最終行取得 '' MaxRow = .Cells(Rows.Count, tgtCol).End(xlUp).Row '' '使用済み範囲の最終行、最終列 With .UsedRange MaxRow = .Rows(.Rows.Count).Row MaxCol = .Columns(.Columns.Count).Column End With temp = "myArray1("""", " For i = sttRow To MaxRow buf = Trim(.Cells(i, tgtCol).Value) buf = """" & buf & """, " If i = MaxRow Then myStr = myStr & temp & buf ElseIf Len(temp) <= lmtNo Then temp = temp & buf Else myStr = myStr & temp & " _" & vbCrLf temp = "" temp = temp & buf End If Next i 'ダブルクォーテーションなし '切り替えて使用 ' myStr = Replace(myStr, """", "") Debug.Print Left(myStr, InStrRev(myStr, ",") - 1) & ")" '============================================================================== '色番号取得 '切り替えて使用 temp2 = "myArray2("""", " For i = sttRow To MaxRow buf2 = .Cells(i, tgtCol).Interior.Color buf2 = buf2 & ", " If i = MaxRow Then myStr2 = myStr2 & temp2 & buf2 ElseIf Len(temp2) <= lmtNo Then temp2 = temp2 & buf2 Else myStr2 = myStr2 & temp2 & " _" & vbCrLf temp2 = "" temp2 = temp2 & buf2 End If Next i 'ダブルクォーテーションなし '切り替えて使用 ' myStr = Replace(myStr, """", "") Debug.Print Left(myStr2, InStrRev(myStr2, ",") - 1) & ")" '============================================================================== End With SetAry_Exit: 'エラーを無視 On Error Resume Next Call ReSetObject Call Updating If nmlTmn Then MsgBox " 完了♪" End If 'エラー制御を戻す On Error GoTo 0 Exit Sub SetAry_Err: Bln_Err = True MsgBox "実行時エラー:" & Err.Nuer & "" & _ Err.Description & vbCr & _ "処理を終了します。", vbExclamation, ErrProsName Err.Clear 'エラー情報クリア GoTo SetAry_Exit End Sub '==================================================== ' シェイプを設定する方法 '==================================================== Sub SetShape() 'Type,Left,Top,Width,Heightを指定 With ActiveSheet.Shapes.AddShape(msoShapeRectangle, 150, 50, 50, 50) '名前を指定 .Name = "図形1" '図形の塗りつぶし色を指定 .Fill.ForeColor.RGB = RGB(100, 200, 255) With .TextFrame.Characters 'テキスト .Text = "四角形" '文字列 .Font.Size = 10 '文字のサイズ .Font.Bold = True End With End With End Sub
コメント