MakeCodeProtectSheetFromActiveSheet

'MakeCodeProtectSheetFromActiveSheet・・・元場所：IkiAddin.ModRibbonGeneral
'ClipText                           ・・・元場所：IkiAddin.ModClipboard



Public Sub MakeCodeProtectSheetFromActiveSheet()
'ActiveSheetの保護状態から、そのシートの保護を設定するコードを自動生成する
'20241205

    '保護対象のシート取得
    Dim Sheet As Worksheet: Set Sheet = ActiveSheet
    
    Dim Str As String
    Str = Str & "Public Sub UnProtect_保護解除_" & Sheet.Name & "シート()" & vbLf
    Str = Str & "    Dim Sheet As Worksheet: Set Sheet = " & Sheet.CodeName & vbLf
    Str = Str & "    Sheet.Unprotect" & vbLf
    Str = Str & "End Sub" & vbLf & vbLf
    Str = Str & vbLf
    Str = Str & "Public Sub Protect_保護設定_" & Sheet.Name & "シート()" & vbLf
    Str = Str & "    " & vbLf
    Str = Str & "    Dim Sheet As Worksheet: Set Sheet = " & Sheet.CodeName & vbLf
    Str = Str & "    " & vbLf
    Str = Str & "    Call Sheet.Protect(DrawingObjects:=" & Sheet.ProtectDrawingObjects & ", _" & vbLf
    Str = Str & "                             Contents:=" & Sheet.ProtectContents & ", _" & vbLf
    Str = Str & "                            Scenarios:=" & Sheet.ProtectScenarios & ", _" & vbLf
    Str = Str & "                 AllowFormattingCells:=" & Sheet.Protection.AllowFormattingCells & ", _" & vbLf
    Str = Str & "               AllowFormattingColumns:=" & Sheet.Protection.AllowFormattingColumns & ", _" & vbLf
    Str = Str & "                  AllowFormattingRows:=" & Sheet.Protection.AllowFormattingRows & ", _" & vbLf
    Str = Str & "                AllowInsertingColumns:=" & Sheet.Protection.AllowInsertingColumns & ", _" & vbLf
    Str = Str & "                   AllowInsertingRows:=" & Sheet.Protection.AllowInsertingRows & ", _" & vbLf
    Str = Str & "             AllowInsertingHyperlinks:=" & Sheet.Protection.AllowInsertingHyperlinks & ", _" & vbLf
    Str = Str & "                 AllowDeletingColumns:=" & Sheet.Protection.AllowDeletingColumns & ", _" & vbLf
    Str = Str & "                    AllowDeletingRows:=" & Sheet.Protection.AllowDeletingRows & ", _" & vbLf
    Str = Str & "                         AllowSorting:=" & Sheet.Protection.AllowSorting & ", _" & vbLf
    Str = Str & "                       AllowFiltering:=" & Sheet.Protection.AllowFiltering & ", _" & vbLf
    Str = Str & "                AllowUsingPivotTables:=" & Sheet.Protection.AllowUsingPivotTables & ")" & vbLf
    Str = Str & "End Sub" & vbLf
    Str = Str & ""
    
    'コードをクリップボード格納
    Call ClipText(Str)
    
    '音で知らせる
    Call Beep
    
    'VBEとイミディエイトウィンドウ表示
    Dim wsh As New WshShell  ': Set WSH = CreateObject("WScript.Shell")
    wsh.SendKeys "%{F11}" 'Alt+F11
    wsh.SendKeys "^G" 'Ctrl+G
    
    'イミディエイトウィンドウに表示
    Debug.Print "下記コードをクリップボードにコピーしました"
    Debug.Print Str
    
End Sub

Private Sub ClipText(ByVal Text As Variant)
'テキストをクリップボードに格納
'テキストが配列ならば列方向をTab区切り、行方向を改行
'https://www.softex-celware.com/post/cliptext

'引数
'Text・・・クリップボードに格納するテキスト
'          文字列、一次元配列、二次元配列に対応
    
    '※※※※※※※※※※※※※※※※※※※※※※※※※※
    '引数処理
    '入力した引数が文字列、一次元配列、二次元配列のどれかを判定
    Dim Dimension  As Long
    Dim Dummy      As Long
    If IsArray(Text) = False Then '配列でない場合
        Dimension = 0
    Else '配列の場合
        On Error Resume Next
        Dummy = UBound(Text, 2)
        On Error GoTo 0
        If Dummy = 0 Then
            Dimension = 1 '一次元配列と判定
        Else
            Dimension = 2 '二次元配列と判定
        End If
    End If
    
    '※※※※※※※※※※※※※※※※※※※※※※※※※※
    '処理
    'クリップボードに格納用のテキスト変数を作成
    Dim Output As String
    Dim I      As Long
    Dim J      As Long
    
    If Dimension = 0 Then
        '文字列の場合
        Output = Text
        
    ElseIf Dimension = 1 Then
        '一次元配列の場合
        Output = ""
        For I = LBound(Text, 1) To UBound(Text, 1)
            If I = LBound(Text, 1) Then
                Output = Text(I)
            Else
                Output = Output & vbCrLf & Text(I)
            End If
        Next I
        
    ElseIf Dimension = 2 Then
        '二次元配列の場合
        Output = ""
        For I = LBound(Text, 1) To UBound(Text, 1)
            For J = LBound(Text, 2) To UBound(Text, 2)
                If J < UBound(Text, 2) Then
                    '列方向Tab区切り
                    Output = Output & Text(I, J) & Chr(9)
                Else
                    Output = Output & Text(I, J)
                End If
            Next J
            
            If I < UBound(Text, 1) Then
                '行方向を改行
                Output = Output & vbCrLf
            End If
        Next I
    End If
    
    'クリップボードに格納
    With CreateObject("Forms.TextBox.1")
        .MultiLine = True
        .Text = Output
        .SelStart = 0
        .SelLength = .TextLength
        .Copy
    End With
    
End Sub