Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0722: Unicode-Text in die Zwischenablage kopieren

VB 5/6-Tipp 0722: Unicode-Text in die Zwischenablage kopieren

 von Philipp Stephani

Schwierigkeitsgrad:

Verwendete API-Aufrufe: CloseClipboard, EmptyClipboard, GetClipboardData, GlobalAlloc, GlobalLock, GlobalSize, GlobalUnlock, MessageBoxW, OpenClipboard, RtlMoveMemory, SetClipboardData

Download: Download des Beispielprojektes [2,83 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'-------- Anfang Projektdatei prjCopyUnicodeText.vbp --------
'--- Anfang Modul "modCopyUnicodeText" alias modCopyUnicodeText.bas ---
Option Explicit

Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
                    ByVal Destination As Long, _
                    ByVal Source As Long, _
                    ByVal Length As Long)
                    
Private Declare Function GlobalAlloc Lib "kernel32.dll" ( _
                         ByVal uFlags As Long, _
                         ByVal dwBytes As Long) As Long
                         
Private Declare Function GlobalSize Lib "kernel32.dll" ( _
                         ByVal hMem 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 OpenClipboard Lib "user32.dll" ( _
                         ByVal hWndNewOwner As Long) As Long
                         
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long

Private Declare Function GetClipboardData Lib "user32.dll" ( _
                         ByVal uFormat As Long) As Long
                         
Private Declare Function SetClipboardData Lib "user32.dll" ( _
                         ByVal uFormat As Long, _
                         ByVal hMem As Long) As Long
                         
Private Declare Function CloseClipboard Lib "user32.dll" () As Long

Private Const GMEM_MOVEABLE As Long = &H2&
Private Const CF_UNICODETEXT As Long = 13

Public Function ClipboardGetText(ByVal Window As Long) As String
    Dim Memory As Long
    Dim Size As Long
    Dim Pointer As Long
    
    If OpenClipboard(Window) Then
        Memory = GetClipboardData(CF_UNICODETEXT)
        
        If Memory Then
            Size = GlobalSize(Memory)
            
            If Size Then
                Pointer = GlobalLock(Memory)
                
                If Pointer Then
                    ClipboardGetText = Space$((Size \ 2) - 1)
                    RtlMoveMemory StrPtr(ClipboardGetText), Pointer, Size
                    GlobalUnlock Memory
                End If
            End If
        End If
        
        CloseClipboard
    End If
End Function

Public Function ClipboardSetText(ByVal Window As Long, ByRef Text As String, _
    Optional ByVal EmptyBefore As Boolean = True) As Boolean
    
    Dim Size As Long
    Dim Memory As Long
    Dim Pointer As Long
    
    If OpenClipboard(Window) Then
        If EmptyBefore Then EmptyClipboard
        
        Size = LenB(Text) + 2
        Memory = GlobalAlloc(GMEM_MOVEABLE, Size)
        
        If Memory Then
            Pointer = GlobalLock(Memory)
            
            If Pointer Then
                RtlMoveMemory Pointer, StrPtr(Text), Size
                GlobalUnlock Memory
                
                If SetClipboardData(CF_UNICODETEXT, Memory) Then _
                    ClipboardSetText = True
            End If
        End If
        
        CloseClipboard
    End If
End Function


'--- Ende Modul "modCopyUnicodeText" alias modCopyUnicodeText.bas ---
'--- Anfang Formular "frmCopyUnicodeText" alias frmCopyUnicodeText.frm  ---
' Steuerelement: Schaltfläche "cmdTest"
Option Explicit

Private Declare Function MessageBoxW Lib "user32.dll" ( _
                         ByVal hWnd As Long, _
                         ByVal lpText As Long, _
                         ByVal lpCaption As Long, _
                         ByVal uType As Long) As Long
                         
Private Sub cmdTest_Click()
    Dim s As String
    Dim i As Long
    
    ' s mit den kleinen griechischen Buchstaben füllen
    For i = &H3B1& To &H3C9&
        s = s & ChrW$(i)
    Next i
    
    ' s in die Zwischenablage kopieren
    ClipboardSetText Me.hWnd, s
    
    ' s wieder aus der Zwischenablage auslesen
    s = ClipboardGetText(Me.hWnd)
    
    ' s in einem Nachrichtendialogfeld ausgeben
    MessageBoxW Me.hWnd, StrPtr(s), StrPtr("Test"), vbInformation
End Sub

'--- Ende Formular "frmCopyUnicodeText" alias frmCopyUnicodeText.frm  ---
'--------- Ende Projektdatei prjCopyUnicodeText.vbp ---------