- Code: [Select all] [Expand/Collapse] [Download] (Untitled.txt)
- Option Explicit
- Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
- Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
- Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
- Declare Function CloseClipboard Lib "User32" () As Long
- Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
- Declare Function EmptyClipboard Lib "User32" () As Long
- Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
- Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
- Public Const GHND = &H42
- Public Const CF_TEXT = 1
- Public Const MAXSIZE = 4096
- Function ClipBoard_SetData(MyString As String)
- Dim hGlobalMemory As Long, lpGlobalMemory As Long
- Dim hClipMemory As Long, X As Long
- ' Allocate moveable global memory.
- '-------------------------------------------
- hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
- ' Lock the block to get a far pointer
- ' to this memory.
- lpGlobalMemory = GlobalLock(hGlobalMemory)
- ' Copy the string to this global memory.
- lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
- ' Copy the string to this global memory.
- lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
- ' Unlock the memory.
- If GlobalUnlock(hGlobalMemory) <> 0 Then
- MsgBox "Could not unlock memory location. Copy aborted."
- GoTo OutOfHere2
- End If
- ' Open the Clipboard to copy data to.
- If OpenClipboard(0&) = 0 Then
- MsgBox "Could not open the Clipboard. Copy aborted."
- Exit Function
- End If
- ' Clear the Clipboard.
- X = EmptyClipboard()
- ' Copy the data to the Clipboard.
- hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
- OutOfHere2:
- If CloseClipboard() = 0 Then
- MsgBox "Could not close Clipboard."
- End If
- End Function
- GeSHi ©
Source: https://docs.microsoft.com/en-us/office ... -clipboard
- Code: [Select all] [Expand/Collapse] [Download] (Untitled.txt)
- 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
- GeSHi ©