Schlagwort: CloseClipboard

' Aufruf: CopyToClipBoard ("Text für Zwischenablage")
' in ein neues Modul einfügen:

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 CopyToClipBoard(TextToCopy As String) 
   Dim hGlobalMemory As Long
   Dim lpGlobalMemory As Long 
   Dim hClipMemory As Long
   Dim X As Long 

   ' Globalen Speicher reservieren 
   hGlobalMemory = GlobalAlloc(GHND, Len(TextToCopy) + 1) 
   lpGlobalMemory = GlobalLock(hGlobalMemory) 

   ' String in Speicherbereich kopieren 
   lpGlobalMemory = lstrcpy(lpGlobalMemory, TextToCopy) 

   ' Speicherbereich freigeben 
   If GlobalUnlock(hGlobalMemory) <> 0 Then 
      MsgBox "Speicher konnte nicht freigegeben werden." 
   Else 
       ' Zwischenablage öffnen 
       If OpenClipboard(0&) = 0 Then 
          MsgBox "Zwischenablage konnte nicht geöffnet werden." 
          Exit Function 
       End If 
    
       ' Zwischenablage leeren 
       X = EmptyClipboard() 
    
       ' Daten in die Zwischenablage kopieren 
       hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 
   End If 

   If CloseClipboard() = 0 Then 
      MsgBox "Zwischenablage konnte nicht geschlossen werden." 
   End If 
End Function