Кнопка «Command» для копирования текста из текстового поля в буфер обмена не работает

Question

У меня есть пользовательская форма с текстовым полем (Textbox1) и командной кнопкой (cmdButton). Я получил код VBA от YouTube, кажется, работает в видео, но когда я пытаюсь это сделать, текст в текстовом поле не будет скопирован в буфер обмена. Как я могу это исправить?

Я переименовал CommandButton1 в cmdButton

Private Sub cmdButton_Click()
    Dim strClipBoard As String
    Set objData = New DataObject

    strClipBoard = Textbox1.Text
    objData.SetText strClipBoard
    objData.PutInClipBoard

    objData.GetFromClipboard
    strClipBoard = ""
   strClipBoard = ObjData.GetText
End Sub

Answer 1

Попробуйте следующий код из здесь

Option Explicit

Private Declare Function OpenClipboard Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" (ByVal wFormat As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32.dll" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32.dll" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpy Lib "kernel32.dll" Alias "lstrcpyW" (ByVal lpString1 As Long, ByVal lpString2 As Long) As Long

Public Sub SetClipboard(sUniText As String)
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Const GMEM_MOVEABLE As Long = &H2
    Const GMEM_ZEROINIT As Long = &H40
    Const CF_UNICODETEXT As Long = &HD
    OpenClipboard 0&
    EmptyClipboard
    iLen = LenB(sUniText) + 2&
    iStrPtr = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, iLen)
    iLock = GlobalLock(iStrPtr)
    lstrcpy iLock, StrPtr(sUniText)
    GlobalUnlock iStrPtr
    SetClipboardData CF_UNICODETEXT, iStrPtr
    CloseClipboard
End Sub

Public Function GetClipboard() As String
    Dim iStrPtr As Long
    Dim iLen As Long
    Dim iLock As Long
    Dim sUniText As String
    Const CF_UNICODETEXT As Long = 13&
    OpenClipboard 0&
    If IsClipboardFormatAvailable(CF_UNICODETEXT) Then
        iStrPtr = GetClipboardData(CF_UNICODETEXT)
        If iStrPtr Then
            iLock = GlobalLock(iStrPtr)
            iLen = GlobalSize(iStrPtr)
            sUniText = String$(iLen \ 2& - 1&, vbNullChar)
            lstrcpy StrPtr(sUniText), iLock
            GlobalUnlock iStrPtr
        End If
        GetClipboard = sUniText
    End If
    CloseClipboard
End Function

Мне кажется, я где-то читал, что DataObject не работает из-за обновления для Win 10 или причиной является 64-битный офис, а неконечно. Я постараюсь найти источник и опубликую его здесь.

PS Если вы используете 64-битный Office, вам нужно изменить объявления API на longptr.

Обновление : Не ссылка , которую я искал, но, по крайней мере, кажется, что не работающий DataObject является своего рода ошибкой