Attribute VB_Name = "Mo_クリップボードにコピペ"
Option Compare Database
Option Explicit

'「Microsoft Forms 2.0 Object Library」に要参照設定
'「Microsoft Forms 2.0 Object Library」が一覧に表示されない場合は、ツール＞参照設定　の画面において、参照ボタンを押して
'C:\windows\system32\FM20.DLL　を参照し、開くを押すと自動的に「Microsoft Forms 2.0 Object Library」にチェックが入った状態になる

Private Sub クリップボードにコピーボタン_Click()

    Dim trgCtrl As Control
    Set trgCtrl = Screen.PreviousControl
    Call CopyToClipboard(trgCtrl)
    
End Sub

Private Sub クリップボードをペーストボタン_Click()

    Dim trgCtrl As Control
    Set trgCtrl = Screen.PreviousControl
    Call PasteFromClipboard(trgCtrl)
    
End Sub


Sub CopyToClipboard(trgCtrl As Control)

    Call ClearClipboard
    
    Const cstErrMsg As String = "値をコピーする「テキストボックス」または「コンボボックス」を選択してください"
'    Dim objData As New DataObject
'    Set objData = CreateObject("Forms.DataObject")
'    Set objData = CreateObject("MSForms.DataObject")
    Dim objData As Object
    Set objData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
    Dim errMsg As String
    Select Case TypeName(trgCtrl)
        Case "Textbox", "Combobox"
            If Nz(trgCtrl.Value, "") = "" Then
                errMsg = cstErrMsg
            Else
                With objData
                    .SetText trgCtrl.Value
                    .PutInClipboard
                End With
        '        MsgBox "クリップボードにコピーしました！"
            End If
        Case Else: errMsg = cstErrMsg
    End Select
    
    If errMsg <> "" Then MsgBox errMsg
    
    Set objData = Nothing
    
End Sub

Sub PasteFromClipboard(trgCtrl As Control)

    On Error Resume Next
    
    Dim objData As New DataObject
    
    objData.GetFromClipboard
    Dim cbValue As Variant
    cbValue = objData.GetText
    If Nz(cbValue, "") = "" Then MsgBox "ペーストしたい値をコピーしてください": Exit Sub
    Select Case TypeName(trgCtrl)
        Case "Textbox", "Combobox"
            If Nz(trgCtrl.Value, "") = "" Then
                trgCtrl.Value = cbValue
            Else
                trgCtrl.Value = trgCtrl.Value & vbLf & cbValue
            End If
        Case Else: MsgBox "ペーストする「テキストボックス」または「コンボボックス」を選択してください"
    End Select
    
End Sub

Sub ClearClipboard()

    Dim objData As Object
    Set objData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    With objData
        .SetText Text:=""
        .PutInClipboard
    End With
    Set objData = Nothing
    
End Sub