Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Dieser Code kopiert beliebigen Unicode-Text in die Zwischenablage. VB6 verwendet UTF-16-kodierte Strings, die alle Unicode-Zeichen enthalten können. Das Clipboard-Objekt kann jedoch nicht mit beliebigen Zeichen umgehen. Dieser Tipp schafft Abhilfe, indem er direkt die Clipboard-API aufruft.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

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 ---------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.