MyRibbonTools T01_GetSettingSht

Option Explicit

'--- AutoShape
Dim shp1Array() As Variant
Dim shp2Array() As Variant

'--- Button
Dim btn1Array() As Variant
Dim btn2Array() As Variant

'--- GroupBox
Dim gpb1Array() As Variant
Dim gpb2Array() As Variant

'--- OptionButton
Dim opt1Array() As Variant
Dim opt2Array() As Variant

'--- TextBox
Dim txtb1Array() As Variant
Dim txtb2Array() As Variant
'+++*********************************************************+++
' getRowHeightAry：行高、列幅取得
' ・ActiveSheetのUsedRangeから最終行・列を取得
' ・行高と列幅をカンマ区切りでDebug出力
' ・WordPress再現用の設定吸い取りツール
'+++*********************************************************+++
Sub getRowHeightAry()

    '--------------------------------------------------
    '【初期宣言】ループ・範囲・バッファ・フラグ類
    '--------------------------------------------------
    Dim i As Long, j As Long
    Dim MaxRow As Long, MaxCol As Long
    Dim buf As String, strAry As String
    Dim nmlTmn As Boolean               '正常終了フラグ：normal Termination

    '--------------------------------------------------
    '【初期設定】プロシージャ名・フラグ類
    '--------------------------------------------------
    Bln_Err = False
    nmlTmn = False
    myProcd = "getRowHeightAry"
    IsCall = False

    On Error GoTo getRowHeightAry_Err
    Call StopUpdating

    '--------------------------------------------------
    '【行高・列幅取得】UsedRangeから最終行列を取得
    '--------------------------------------------------
    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

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.Number & "" & _
           Err.Description & vbCr & _
           "処理を終了します。", vbExclamation, myProcd
    Err.Clear          'エラー情報クリア
    GoTo getRowHeightAry_Exit

End Sub
'====================================================================
' OutputBtnLog：フォームボタンの情報をログファイルに出力
'====================================================================
Sub OutputBtnLog()
    Dim i As Long, j As Long
    Dim buf As String, temp As String, myStr As String, strResult As String
    Dim var As Variant
    Dim lmtNo As Long: lmtNo = 60

    strResult = "'--- 取得したボタン情報"
    writeNote strResult
    strResult = "対象ボタン数：" & UBound(btn1Array, 1)
    writeNote strResult

    '--- btn1Array（属性情報）
    For j = 0 To UBound(btn1Array, 2)
        temp = "btn1Array(" & j & ")("
        myStr = ""
        For i = 0 To UBound(btn1Array, 1)
            buf = """" & btn1Array(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        strResult = j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
        writeNote strResult
    Next j

    '--- btn2Array（位置情報）
    temp = "btn2Array(""0,0,0,0"","
    myStr = ""
    For i = 1 To UBound(btn2Array, 1)
        buf = """" & btn2Array(i, 0) & "," & btn2Array(i, 1) & "," & _
                    btn2Array(i, 2) & "," & btn2Array(i, 3) & ""","
        var = StrConv(temp & buf, vbFromUnicode)
        If LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    strResult = "位置:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    writeNote strResult
End Sub

'====================================================================
' OutputOptLog：オプションボタンの情報をログファイルに出力
'====================================================================
Sub OutputOptLog()
    Dim i As Long, j As Long
    Dim buf As String, temp As String, myStr As String, strResult As String
    Dim var As Variant
    Dim lmtNo As Long: lmtNo = 60

    strResult = "'--- 取得したオプションボタン情報"
    writeNote strResult
    strResult = "オプションボタン数：" & UBound(opt1Array, 1)
    writeNote strResult

    '--- opt1Array（属性情報）
    For j = 0 To UBound(opt1Array, 2)
        temp = "opt1Array(" & j & ")("
        myStr = ""
        For i = 0 To UBound(opt1Array, 1)
            buf = """" & opt1Array(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        strResult = j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
        writeNote strResult
    Next j

    '--- opt2Array（位置情報）
    temp = "opt2Array(""0,0,0,0"","
    myStr = ""
    For i = 1 To UBound(opt2Array, 1)
        buf = """" & opt2Array(i, 0) & "," & opt2Array(i, 1) & "," & _
                    opt2Array(i, 2) & "," & opt2Array(i, 3) & ""","
        var = StrConv(temp & buf, vbFromUnicode)
        If LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    strResult = "位置:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    writeNote strResult
End Sub

'＊＊＊：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：：＊＊＊
'+++*********************************************************+++
' getShpData：アクティブシートのボタン等の情報取得
' ・シェイプ・フォームコントロール・テキストボックスの情報を吸い取り
' ・WordPress再現用の設定記録ツール
' ・各種配列に格納し、ログファイルに出力
'+++*********************************************************+++
Sub getShpData()

    '--- 初期設定
    myProcd = "getShpData"
    Bln_Err = False
    IsCall = False

    On Error GoTo getShpData_Err
    Call StopUpdating

    '--- 配列初期化とカウント取得
    Call InitShpArrays

    '--- シェイプ情報の抽出
    Call ExtractShpInfo

    '--- ログ出力（各種コントロール）
    Call OutputShpLog
    Call OutputBtnLog
    Call OutputGpbLog
    Call OutputOptLog
    Call OutputTxtbLog

getShpData_Exit:

    '一時的にエラー無視
    On Error Resume Next
    Call Updating

    MsgBox " 完了♪"

    'エラー制御を戻す
    On Error GoTo 0
    Exit Sub

getShpData_Err:

    MsgBox "実行時エラー:" & Err.Number & vbCr & _
           Err.Description & vbCr & _
           "処理を終了します。", vbExclamation, myProcd
    Err.Clear
    GoTo getShpData_Exit

End Sub

'====================================================================
' InitShpArrays：各種配列の初期化とコントロール数の取得
'====================================================================
Sub InitShpArrays()
    Dim shp As Shape
    Dim shpCnt As Long, tgtShpCnt As Long
    Dim btnCnt As Long, gBoxCnt As Long
    Dim optBtnCnt As Long, txtbCnt As Long

    With ActiveSheet
        '--- 全シェイプ数
        shpCnt = .Shapes.Count
        Debug.Print "シェイプ数：" & shpCnt

        For Each shp In .Shapes
            If shp.Type = msoAutoShape Then
                tgtShpCnt = tgtShpCnt + 1
            End If
        Next shp
        Debug.Print "対象シェイプ数：" & tgtShpCnt
        ReDim shp1Array(tgtShpCnt, 7)
        ReDim shp2Array(tgtShpCnt, 3)

        '--- ボタン
        btnCnt = .Buttons.Count
        Debug.Print "ボタン数：" & btnCnt
        ReDim btn1Array(btnCnt, 3)
        ReDim btn2Array(btnCnt, 3)

        '--- グループボックス
        gBoxCnt = .GroupBoxes.Count
        Debug.Print "グループボックス数：" & gBoxCnt
        ReDim gpb1Array(gBoxCnt, 7)
        ReDim gpb2Array(gBoxCnt, 3)

        '--- オプションボタン
        optBtnCnt = .OptionButtons.Count
        Debug.Print "オプションボタン数：" & optBtnCnt
        ReDim opt1Array(optBtnCnt, 7)
        ReDim opt2Array(optBtnCnt, 3)

        '--- テキストボックス
        txtbCnt = .TextBoxes.Count
        Debug.Print "テキストボックス数：" & txtbCnt
        ReDim txtb1Array(txtbCnt, 8)
        ReDim txtb2Array(txtbCnt, 3)
    End With
End Sub
'====================================================================
' ExtractShpInfo：アクティブシート上の各シェイプ情報を抽出
' ・AutoShape / FormControl / TextBox を判定し、各配列に格納
'====================================================================
Sub ExtractShpInfo()
    Dim shp As Shape
    Dim i1 As Long, i0 As Long, i4 As Long, i7 As Long, i17 As Long
    Dim myName As String, myText As String, myMacro As String
    Dim myFontSize As Double, myFontBold As Boolean
    Dim myLeft As Double, myTop As Double, myWidth As Double, myHeight As Double
    Dim mybkClr As Long, mylineClr As Long, mylineW As Double, mylineStl As Double
    Dim myshpType As Double

    On Error Resume Next

    With ActiveSheet
        For Each shp In .Shapes
            With shp
                '--- 初期化
                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
                If .TextFrame.hasText Then
                    With .TextFrame.Characters
                        myText = .Text
                        myFontSize = .Font.Size
                        myFontBold = .Font.Bold
                    End With
                End If
                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

            '--- 判定と格納
            Select Case shp.Type
                Case msoAutoShape
                    i1 = i1 + 1
                    shp1Array(i1, 0) = myName
                    shp1Array(i1, 1) = myText
                    shp1Array(i1, 2) = myFontSize
                    shp1Array(i1, 3) = mybkClr
                    shp1Array(i1, 4) = mylineClr
                    shp1Array(i1, 5) = mylineW
                    shp1Array(i1, 6) = mylineStl
                    shp1Array(i1, 7) = myshpType
                    shp2Array(i1, 0) = Round(myLeft, 3)
                    shp2Array(i1, 1) = Round(myTop, 3)
                    shp2Array(i1, 2) = Round(myWidth, 3)
                    shp2Array(i1, 3) = Round(myHeight, 3)

                Case msoFormControl
                    Select Case shp.FormControlType
                        Case xlButtonControl
                            i0 = i0 + 1
                            btn1Array(i0, 0) = myName
                            btn1Array(i0, 1) = myText
                            btn1Array(i0, 2) = myFontSize
                            btn1Array(i0, 3) = myMacro
                            btn2Array(i0, 0) = Round(myLeft, 3)
                            btn2Array(i0, 1) = Round(myTop, 3)
                            btn2Array(i0, 2) = Round(myWidth, 3)
                            btn2Array(i0, 3) = Round(myHeight, 3)

                        Case xlGroupBox
                            i4 = i4 + 1
                            gpb1Array(i4, 0) = myName
                            gpb1Array(i4, 1) = myText
                            gpb1Array(i4, 2) = myFontSize
                            gpb1Array(i4, 3) = mybkClr
                            gpb1Array(i4, 4) = mylineClr
                            gpb1Array(i4, 5) = mylineW
                            gpb1Array(i4, 6) = mylineStl
                            gpb1Array(i4, 7) = myshpType
                            gpb2Array(i4, 0) = Round(myLeft, 3)
                            gpb2Array(i4, 1) = Round(myTop, 3)
                            gpb2Array(i4, 2) = Round(myWidth, 3)
                            gpb2Array(i4, 3) = Round(myHeight, 3)

                        Case xlOptionButton
                            i7 = i7 + 1
                            opt1Array(i7, 0) = myName
                            opt1Array(i7, 1) = myText
                            opt1Array(i7, 2) = myFontSize
                            opt1Array(i7, 3) = mybkClr
                            opt1Array(i7, 4) = mylineClr
                            opt1Array(i7, 5) = mylineW
                            opt1Array(i7, 6) = mylineStl
                            opt1Array(i7, 7) = myshpType
                            opt2Array(i7, 0) = Round(myLeft, 3)
                            opt2Array(i7, 1) = Round(myTop, 3)
                            opt2Array(i7, 2) = Round(myWidth, 3)
                            opt2Array(i7, 3) = Round(myHeight, 3)
                    End Select

                Case msoTextBox
                    i17 = i17 + 1
                    txtb1Array(i17, 0) = myName
                    txtb1Array(i17, 1) = myText
                    txtb1Array(i17, 2) = myFontSize
                    txtb1Array(i17, 3) = myMacro
                    txtb1Array(i17, 4) = mybkClr
                    txtb1Array(i17, 5) = mylineClr
                    txtb1Array(i17, 6) = mylineW
                    txtb1Array(i17, 7) = mylineStl
                    txtb1Array(i17, 8) = myshpType
                    txtb2Array(i17, 0) = Round(myLeft, 3)
                    txtb2Array(i17, 1) = Round(myTop, 3)
                    txtb2Array(i17, 2) = Round(myWidth, 3)
                    txtb2Array(i17, 3) = Round(myHeight, 3)
            End Select
        Next shp
    End With
End Sub
'====================================================================
' OutputShpLog：AutoShapeの情報をログファイルに出力
'====================================================================
Sub OutputShpLog()
    Dim i As Long, j As Long
    Dim buf As String, temp As String, myStr As String, strResult As String
    Dim var As Variant
    Dim lmtNo As Long: lmtNo = 60

    strResult = "'--- 取得したシェイプ情報"
    writeNote strResult
    strResult = "対象シェイプ数：" & UBound(shp1Array, 1)
    writeNote strResult

    '--- shp1Array（属性情報）
    For j = 0 To UBound(shp1Array, 2)
        temp = "shp1Array(" & j & ")("
        myStr = ""
        For i = 0 To UBound(shp1Array, 1)
            buf = """" & shp1Array(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        strResult = j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
        writeNote strResult
    Next j

    '--- shp2Array（位置情報）
    temp = "shp2Array(""0,0,0,0"","
    myStr = ""
    For i = 1 To UBound(shp2Array, 1)
        buf = """" & shp2Array(i, 0) & "," & shp2Array(i, 1) & "," & _
                    shp2Array(i, 2) & "," & shp2Array(i, 3) & ""","
        var = StrConv(temp & buf, vbFromUnicode)
        If LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    strResult = "位置:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    writeNote strResult
End Sub
'====================================================================
' OutputTxtbLog：テキストボックスの情報をログファイルに出力
'====================================================================
Sub OutputTxtbLog()
    Dim i As Long, j As Long
    Dim buf As String, temp As String, myStr As String, strResult As String
    Dim var As Variant
    Dim lmtNo As Long: lmtNo = 60

    strResult = "'--- 取得したテキストボックス情報"
    writeNote strResult
    strResult = "対象テキストボックス数：" & UBound(txtb1Array, 1)
    writeNote strResult

    '--- txtb1Array（属性情報）
    For j = 0 To UBound(txtb1Array, 2)
        temp = "txtb1Array(" & j & ")("
        myStr = ""
        For i = 0 To UBound(txtb1Array, 1)
            buf = """" & txtb1Array(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        strResult = j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
        writeNote strResult
    Next j

    '--- txtb2Array（位置情報）
    temp = "txtb2Array(""0,0,0,0"","
    myStr = ""
    For i = 1 To UBound(txtb2Array, 1)
        buf = """" & txtb2Array(i, 0) & "," & txtb2Array(i, 1) & "," & _
                    txtb2Array(i, 2) & "," & txtb2Array(i, 3) & ""","
        var = StrConv(temp & buf, vbFromUnicode)
        If LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    strResult = "位置:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    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
'+++*********************************************************+++
' getButtonsData：フォームコントロールのボタン情報取得
' ・名前、文字列、マクロ、位置・サイズを記録
' ・Debug.Printで整形出力
'+++*********************************************************+++
Sub getButtonsData()
    Dim i As Long, j As Long
    Dim btn As Object
    Dim btnCnt As Long
    Dim buf As String, temp As String, myStr As String
    Dim myArray() As Variant
    Dim lmtNo As Long: lmtNo = 60
    Dim var As Variant

    With ActiveSheet
        btnCnt = .Buttons.Count
        ReDim myArray(1 To btnCnt, 0 To 6)

        i = 0
        For Each btn In .Buttons
            i = i + 1
            On Error Resume Next
            With btn
                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

    '--- 属性情報（0_2）
    For j = 0 To 2
        temp = "myArray(" & j & ")("
        myStr = ""
        For i = 1 To UBound(myArray, 1)
            buf = """" & myArray(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        Debug.Print j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    Next j

    '--- 位置・サイズ（3_6）
    temp = "myArray(3)((0,0,0,0),"
    myStr = ""
    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 LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    Debug.Print "3:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
End Sub
'====================================================================
' OutputGpbLog：グループボックスの情報をログファイルに出力
'====================================================================
Sub OutputGpbLog()
    Dim i As Long, j As Long
    Dim buf As String, temp As String, myStr As String, strResult As String
    Dim var As Variant
    Dim lmtNo As Long: lmtNo = 60

    strResult = "'--- 取得したグループボックス情報"
    writeNote strResult
    strResult = "対象グループボックス数：" & UBound(gpb1Array, 1)
    writeNote strResult

    '--- gpb1Array（属性情報）
    For j = 0 To UBound(gpb1Array, 2)
        temp = "gpb1Array(" & j & ")("
        myStr = ""
        For i = 0 To UBound(gpb1Array, 1)
            buf = """" & gpb1Array(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        strResult = j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
        writeNote strResult
    Next j

    '--- gpb2Array（位置情報）
    temp = "gpb2Array(""0,0,0,0"","
    myStr = ""
    For i = 1 To UBound(gpb2Array, 1)
        buf = """" & gpb2Array(i, 0) & "," & gpb2Array(i, 1) & "," & _
                    gpb2Array(i, 2) & "," & gpb2Array(i, 3) & ""","
        var = StrConv(temp & buf, vbFromUnicode)
        If LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    strResult = "位置:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    writeNote strResult
End Sub
'+++*********************************************************+++
' getOptionButtonsData：フォームコントロールのオプションボタン情報取得
' ・名前、文字列、位置・サイズを記録
' ・Debug.Printで整形出力
'+++*********************************************************+++
Sub getOptionButtonsData()
    Dim i As Long, j As Long
    Dim optBtn As Object
    Dim optBtnCnt As Long
    Dim buf As String, temp As String, myStr As String
    Dim myArray() As Variant
    Dim lmtNo As Long: lmtNo = 60
    Dim var As Variant

    With ActiveSheet
        optBtnCnt = .OptionButtons.Count
        Debug.Print "オプションボタン数：" & optBtnCnt
        ReDim myArray(1 To optBtnCnt, 0 To 5)

        i = 0
        For Each optBtn In .OptionButtons
            i = i + 1
            On Error Resume Next
            With optBtn
                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

    '--- 属性情報（0_2）
    For j = 0 To 2
        temp = "myArray(" & j & ")("
        myStr = ""
        For i = 1 To UBound(myArray, 1)
            buf = """" & myArray(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        Debug.Print j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    Next j

    '--- 位置・サイズ（2_5）
    temp = "myArray(3)((0,0,0,0),"
    myStr = ""
    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 LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    Debug.Print "3:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
End Sub
'+++*********************************************************+++
' getGroupBoxData：フォームコントロールのグループボックス情報取得
' ・名前、文字列、位置・サイズを記録
' ・Debug.Printで整形出力
'+++*********************************************************+++
Sub getGroupBoxData()
    Dim i As Long, j As Long
    Dim gBox As Object
    Dim gBoxCnt As Long
    Dim buf As String, temp As String, myStr As String
    Dim myArray() As Variant
    Dim lmtNo As Long: lmtNo = 60
    Dim var As Variant

    With ActiveSheet
        gBoxCnt = .GroupBoxes.Count
        Debug.Print "グループボックス数：" & gBoxCnt
        ReDim myArray(1 To gBoxCnt, 0 To 5)

        i = 0
        For Each gBox In .GroupBoxes
            i = i + 1
            On Error Resume Next
            With gBox
                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 gBox
    End With

    '--- 属性情報（0_1）
    For j = 0 To 1
        temp = "myArray(" & j & ")("
        myStr = ""
        For i = 1 To UBound(myArray, 1)
            buf = """" & myArray(i, j) & """, "
            var = StrConv(temp & buf, vbFromUnicode)
            If LenB(var) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        Debug.Print j & ":" & Left(temp, InStrRev(temp, ",") - 1) & ")"
    Next j

    '--- 位置・サイズ（2_5）
    temp = "myArray(2)((0,0,0,0),"
    myStr = ""
    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 LenB(var) <= lmtNo Then
            temp = temp & buf
        Else
            myStr = myStr & temp & " _" & vbCrLf
            temp = buf
        End If
    Next i
    Debug.Print "2:" & Left(temp, InStrRev(temp, ",") - 1) & ")"
End Sub
'+++*********************************************************+++
' GetRngColorA：アクティブセルの色と文字配置を取得
' ・背景色、文字色、横方向・縦方向の配置をDebug出力
'+++*********************************************************+++
Public Sub GetRngColorA()
    Dim valH As Long, valV As Long
    Dim strH As String, strV As String

    With ActiveCell
        Debug.Print "背景色：" & .Interior.Color
        Debug.Print "文字色：" & .Font.Color

        valH = .HorizontalAlignment
        valV = .VerticalAlignment
    End With

    '--- 横方向の配置
    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, 標準"
        Case Else:  strH = "（未定義）"
    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, 上詰め"
        Case Else:  strV = "（未定義）"
    End Select

    Debug.Print "文字の横方向の配置：" & strH
    Debug.Print "文字の縦方向の配置：" & strV
End Sub
'+++*********************************************************+++
' GetActiveShpColor：選択中のShapeの色・位置・サイズなどを取得
' ・背景色、文字色、透過率、枠線色などをDebug出力
'+++*********************************************************+++
Public Sub GetActiveShpColor()
    Dim shp As Shape
    Dim shpRange As ShapeRange

    On Error Resume Next
    Set shpRange = Selection.ShapeRange
    On Error GoTo 0

    If shpRange Is Nothing Then
        Debug.Print "選択された図形がありません。"
        Exit Sub
    End If

    With shpRange
        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
    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
'+++*********************************************************+++
' GetShpArrayA：アクティブシート上の図形情報を配列に取得
' ・グループ化された図形は対象外
' ・名前、文字列、位置、サイズ、色、表示状態などを記録
'+++*********************************************************+++
Public Sub GetShpArrayA()
    Dim shp As Shape
    Dim cnt As Long, i As Long
    Dim shpArray() As Variant

    cnt = ActiveSheet.Shapes.Count
    Debug.Print "シェイプ数：" & cnt

    If cnt = 0 Then Exit Sub
    ReDim shpArray(1 To cnt, 0 To 9)

    i = 0
    For Each shp In ActiveSheet.Shapes
        i = i + 1
        On Error Resume Next
        With shp
            shpArray(i, 0) = .Name
            shpArray(i, 1) = .TextFrame.Characters.Text
            shpArray(i, 2) = Round(.Left, 3)
            shpArray(i, 3) = Round(.Top, 3)
            shpArray(i, 4) = Round(.Width, 3)
            shpArray(i, 5) = Round(.Height, 3)
            shpArray(i, 6) = .AutoShapeType
            shpArray(i, 7) = .Fill.ForeColor.RGB
            shpArray(i, 8) = .Fill.Transparency
            shpArray(i, 9) = .line.ForeColor.RGB
        End With
        On Error GoTo 0
    Next shp

    '--- 表示確認（任意）
    For i = 1 To cnt
        Debug.Print "図形：" & shpArray(i, 0) & " / " & shpArray(i, 1)
    Next i
End Sub
'+++*********************************************************+++
' SetAry：セル文字列と背景色を配列形式で整形出力
' ・対象列の値と色を折り返し制御付きでDebug出力
' ・myArray1：文字列配列
' ・myArray2：色番号配列
'+++*********************************************************+++
Sub SetAry()
    Dim i As Long
    Dim sttRow As Long, MaxRow As Long, MaxCol As Long
    Dim tgtCol As Long, lmtNo As Long
    Dim buf As String, temp As String, myStr As String
    Dim buf2 As String, temp2 As String, myStr2 As String
    Dim nmlTmn As Boolean

    Bln_Err = False
    nmlTmn = False
    myProcd = "SetAry"

    On Error GoTo SetAry_Err
    Call StopUpdating
    IsCall = False

    With ActiveSheet
        sttRow = 2
        tgtCol = 3      '←切り替え候補：15
        lmtNo = 52      '←切り替え候補：65

        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) & """, "
            If i = MaxRow Then
                myStr = myStr & temp & buf
            ElseIf Len(temp) <= lmtNo Then
                temp = temp & buf
            Else
                myStr = myStr & temp & " _" & vbCrLf
                temp = buf
            End If
        Next i
        Debug.Print Left(myStr, InStrRev(myStr, ",") - 1) & ")"

        '--- 色番号配列出力
        temp2 = "myArray2("""", "
        For i = sttRow To MaxRow
            buf2 = .Cells(i, tgtCol).Interior.Color & ", "
            If i = MaxRow Then
                myStr2 = myStr2 & temp2 & buf2
            ElseIf Len(temp2) <= lmtNo Then
                temp2 = temp2 & buf2
            Else
                myStr2 = myStr2 & temp2 & " _" & vbCrLf
                temp2 = buf2
            End If
        Next i
        Debug.Print Left(myStr2, InStrRev(myStr2, ",") - 1) & ")"
    End With

SetAry_Exit:
    On Error Resume Next
    Call ReSetObject
    Call Updating
    If nmlTmn Then MsgBox "完了♪"
    On Error GoTo 0
    Exit Sub

SetAry_Err:
    Bln_Err = True
    MsgBox "実行時エラー:" & Err.Number & vbCrLf & _
           Err.Description & vbCrLf & "処理を終了します。", vbExclamation, myProcd
    Err.Clear
    GoTo SetAry_Exit
End Sub
'+++*********************************************************+++
' SetShape：アクティブシートに四角形を追加
' ・位置・サイズ・色・文字・フォントを指定
'+++*********************************************************+++
Sub SetShape()
    Dim shp As Shape

    '--- 四角形を追加（左150, 上50, 幅50, 高さ50）
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 150, 50, 50, 50)

    With shp
        .Name = "図形1"
        .Fill.ForeColor.RGB = RGB(100, 200, 255)

        With .TextFrame.Characters
            .Text = "四角形"
            With .Font
                .Size = 10
                .Bold = True
            End With
        End With
    End With
End Sub