【ワンポイントVBA】Windows10以降のクリップボードの操作

会社でOSをアップデート(Windows10)したところ
セルの内容をコピーするマクロが動かなくなってしまいました。

Sub cpy_code()
    Dim str As String
    str = "Text here"

    With New MSForms.DataObject
        .SetText str      '変数の値をDataObjectに格納する
        .PutInClipboard   'DataObjectのデータをクリップボードに格納する
    End With
End Sub

動かないと困るので
代替え案を調べてみました。

参考 DataObjectを使ったクリップボード操作が上手くいかない場合の対処法初心者備忘録

Private Sub cb_code()
Call Copy_ClipBoard("Text here") '指定したテキストをコピーする
Debug.Print Paste_ClipBoard 'イミディエイトウィンドウに貼り付け
End Sub

Private Sub Copy_ClipBoard(cpy_txt As String)
With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    .text = cpy_txt
    .SelStart = 0
    .SelLength = .TextLength
    .Copy
End With
End Sub

Private Function Paste_ClipBoard() As String
    Dim Form As Object: Set Form = CreateObject("Forms.TextBox.1")
    Form.MultiLine = True
    If Form.CanPaste = True Then Form.Paste
    Paste_ClipBoard = Form.text
End Function

これをVBAエディタに貼り付けると使えるようになります。

実用となるともう少し手を加える必要がありますが･･･

コード上でフォームとtextboxを定義して、
指定した文字列をtextbox経由でコピーするようです。

API関数経由のコピーもできるようですが
こちらはシンプルなコードで実行できるのが良いですね。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
With Target
    Copy_ClipBoard (Cells(.Row, .Column))
    Cancel = True
End With
End Sub

Private Sub Copy_ClipBoard(cpy_txt As String)
With CreateObject("Forms.TextBox.1")
    .MultiLine = True
    .text = cpy_txt
    .SelStart = 0
    .SelLength = .TextLength
    .Copy
End With
End Sub

こんな感じにすると
ダブルクリックしたセルの内容をコピーすることができます。