MakeCommandButtonForRibbon

'MakeCommandButtonForRibbon・・・元場所：IkiAddin.ModOther    
'GetClipboardText          ・・・元場所：IkiAddin.ModClipboard
'F_InputBox                ・・・元場所：IkiAddin.ModMessage  



Public Sub MakeCommandButtonForRibbon()
'選択セル範囲からコマンドボタンを作成
'リボンに設置用
'20220311
'20220610 改良

    '選択セル取得
    Dim Dummy As Object: Set Dummy = Selection
    Dim Cell  As Range
    If TypeName(Dummy) = "Range" Then
        Set Cell = Dummy
    Else
        Exit Sub
    End If
    
    'クリップボードから格納してある文字列取得
    On Error Resume Next 'クリップボードに格納されているのが文字列でなかった場合のエラー回避
    Dim ClipStr As String: ClipStr = GetClipboardText
    On Error GoTo 0
    
    'ボタンの名前設定
    Dim ButtonName As String: ButtonName = F_InputBox("ボタンのテキストを入力してください", "ボタンのテキスト入力", ClipStr, , , True)
    If ButtonName = "" Then '何も入力されなかったらキャンセル 20220610
        Exit Sub
    End If
    
    'ボタンの作成
    Dim Sheet  As Worksheet: Set Sheet = Cell.Parent '対象シートの参照
    Dim Button As Button:    Set Button = Sheet.Buttons.Add(Cell.Left, Cell.Top, Cell.Width, Cell.Height) 'セルの大きさと同じものを作成する
    Button.Text = ButtonName
        
    'ボタンの登録マクロ設定
    Dim RegistMacro As String: RegistMacro = F_InputBox("ボタンに登録するマクロ名を入力してください", "ボタン登録のマクロ入力", ClipStr, , , True)
    RegistMacro = Replace(RegistMacro, vbLf, "")
    RegistMacro = Replace(RegistMacro, vbCr, "")
    If RegistMacro <> "" And RegistMacro <> "False" Then
        Button.OnAction = "'" & ActiveWorkbook.Name & "'!" & RegistMacro
    End If

End Sub

Private Function GetClipboardText()
'クリップボードに格納中の文字列データを取得する
'Microsoft Forms 2.0 Object Libraryを参照
'参考：http://officetanaka.net/excel/vba/tips/tips20.htm
'20210916

    Dim OutputStr As String
    Dim Clip      As New DataObject
    With Clip
        .GetFromClipboard
        OutputStr = .GetText
    End With
    
    GetClipboardText = OutputStr

End Function

Private Function F_InputBox(ByRef Prompt As String, _
                   Optional ByRef Title As String, _
                 Optional ByRef Default As String, _
                 Optional ByRef Formula As Boolean = False, _
                   Optional ByRef Value As Boolean = False, _
                 Optional ByRef String_ As Boolean = False, _
                Optional ByRef Boolean_ As Boolean = False, _
                 Optional ByRef RefCell As Boolean = False, _
                   Optional ByRef Error As Boolean = False, _
                  Optional ByRef Array_ As Boolean = False) As Variant
'Application.InputBoxのType引数の処理を個別に指定できる
'20211222
'20220118修正
'20220317改良
'紹介済み

'引数
'Prompt    ・・・表示メッセージ
'[Title]   ・・・タイトル
'[Default] ・・・デフォルト値
'[Formula] ・・・数式かどうか
'[Value]   ・・・数値かどうか
'[String_] ・・・文字列かどうか
'[Boolean_]・・・ブール値かどうか
'[RefCell] ・・・セル参照かどうか
'[Error]   ・・・エラー値かどうか
'[Array_]  ・・・値の配列かどうか

    'InputBoxのType引数を計算する
    Dim TypeNum As Long: TypeNum = 0
    If Formula Then TypeNum = TypeNum + 0
    If Value Then TypeNum = TypeNum + 1
    If String_ Then TypeNum = TypeNum + 2
    If Boolean_ Then TypeNum = TypeNum + 4
    If RefCell Then TypeNum = TypeNum + 8
    If Error Then TypeNum = TypeNum + 16
    If Array_ Then TypeNum = TypeNum + 64
    
    If TypeNum = 0 Then
        TypeNum = 2 'デフォルトでは文字列とする
    End If
    
    If RefCell = True Then
        Set F_InputBox = Nothing '20220317(セル選択にてキャンセルとなった場合はNothingを返す処理)
        On Error Resume Next
        If Default <> "" Then
            Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default)
        Else
            Set F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum)
        End If
        On Error GoTo 0
    Else
        If Default <> "" Then
            F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum, Default:=Default)
        Else
            F_InputBox = Application.InputBox(Prompt, Title, Type:=TypeNum)
        End If
    End If
    
End Function