Managing the Microsoft Word clipboard-content from VB6

Our VB6 module creates and mangage documents, allmost without using files. Pretty cool - and my deep respect goes to my colleague who designed this implementation.

To complete this module, we needed to disable the classic MS-Word warning,

"You placed a large amount of text on the clipboard.
Do you want this text to available to other applications after you quit Word"

To solve this problem, and still keep the clipboard content available for other applications, I had to take the control of the clipboard.


First of all, I will remind you how to enforce that warning - a good point to test the solution:

• Create a new document
• Paste a lot of content (text, images, tables and so on. I copied the result of a Google search whitch contains formatted text, images, links, tables)
• Mark all the content of the document, and then copy the stuff to the clipboard.
• Then close the word application.

Now you got a lot of data stored on the clipboard, with Word as the owner. If you don't get the message, you havn't copied enough data from the Word application.

VB6 has the clipboard object, but actually it only could paste a pure text or a pure image of the document. I think.

Then I went implementing the solution in good old Windows API.

Here are some short codesnippets as examples:

Dim WithEvents wApp As Word.Application
Dim WithEvents wDoc As Document

'<--- create a local APIClipboard variable --->
Dim oAPI as APIClipboard

Private Sub wApp_DocumentBeforeClose(ByVal Doc As Word.Document, Cancel As Boolean)

'<--- if this is the last document in the Word instance ---->
If wApp.Documents.Count = 1 Then
    Set oAPI = New APIClipboard
'<---- puts the clipboard into a buffer in the oAPI-class --->
    Call oAPI.Backup
'<---- clear the clipboard content, and release the Word link --->
    Clipboard.Clear  
  End If
End Sub

Private Sub wApp_Quit()
'<-- Restoring the clipboard, reloads the data to the clipboard
' with a new owner -->
  Call oAPI.Restore 
End Sub

Though, it could have been implemented in the same event.

The APIClipboard class:

Option Explicit

Private lCurrentformat as long
Private myMemory As APIGlobalmemory

Public Sub Backup()
    dim lret as long

    lCurrentFormat = RegisterClipboardFormat("Rich Text Format")
    lRet = OpenClipboard(Me.ParenthWnd)

    If lRet Then
        Call SaveMemory(lCurrentFormat)
        lRet = CloseClipboard()
    End If
End Sub

Public Sub Restore()
    Dim lRet As Long

    If Me.BackedUp Then
        lRet = OpenClipboard(Me.ParenthWnd)
        If lRet Then
            myMemory.AllocationType = GMEM_FIXED
            lRet = SetClipboardData(lCurrentFormat, myMemory.Handle)
            myMemory.Free

            lRet = CloseClipboard()
        End If
    End If
End Sub

Private Sub SaveMemory(lFormat As Long)

  Dim lRet As Long

  lRet = GetClipboardData(lFormat)
  If lRet > 0 Then
      Set myMemory = New APIGlobalmemory
      Call myMemory.CopyFromHandle(lRet)
  End If

End Sub

The APIGlobalMemory class:

Option Explicit
Private mMyData() As Byte
Private mMyDataSize As Long
Private mHmem As Long
Private mAllocationType As enGlobalmemoryAllocationConstants

Public Property Let AllocationType(ByVal newType As enGlobalmemoryAllocationConstants)
    mAllocationType = newType
End Property

Public Property Get AllocationType() As enGlobalmemoryAllocationConstants
    AllocationType = mAllocationType
End Property

Private Sub CopyDataToGlobal()
    Dim lRet As Long

    If mHmem > 0 Then
        lRet = GlobalLock(mHmem)

        If lRet > 0 Then
            Call CopyMemory(ByVal mHmem, mMyData(0), mMyDataSize)
            Call GlobalUnlock(mHmem)
        End If
    End If
End Sub

Public Sub CopyFromHandle(ByVal hMemHandle As Long)
    Dim lRet As Long
    Dim lPtr As Long
    lRet = GlobalSize(hMemHandle)

    If lRet > 0 Then
        mMyDataSize = lRet
        lPtr = GlobalLock(hMemHandle)

        If lPtr > 0 Then
            ReDim mMyData(0 To mMyDataSize - 1) As Byte
            CopyMemory mMyData(0), ByVal lPtr, mMyDataSize
            Call GlobalUnlock(hMemHandle)
        End If
    End If
End Sub

Public Sub CopyToHandle(ByVal hMemHandle As Long)
    Dim lSize As Long
    Dim lPtr As Long
    '\\ Don't copy if its empty

    If Not Me.IsEmpty Then
        lSize = GlobalSize(hMemHandle)
        '\\ Don't attempt to copy if zero size..
        If lSize > 0 Then

            If lPtr > 0 Then
                CopyMemory ByVal lPtr, mMyData(0), lSize
                Call GlobalUnlock(hMemHandle)
            End If
        End If
    End If
End Sub

'<--[Handle]--------------------------
'     ----------------------------
' Returns a Global Memroy handle that
'     is valid and filled with the
' info held in this object's private b
'     yte array
' ------------------------------------ >

Public Property Get Handle() As Long
    If mHmem = 0 Then
        If mMyDataSize > 0 Then
            mHmem = GlobalAlloc(AllocationType, mMyDataSize)
        End If
    End If
    Call CopyDataToGlobal
    Handle = mHmem
End Property

Public Property Get IsEmpty() As Boolean
    IsEmpty = (mMyDataSize = 0)
End Property

Public Sub Free()
    If mHmem > 0 Then
        Call GlobalFree(mHmem)
        mHmem = 0
        mMyDataSize = 0
        ReDim mMyData(0) As Byte
    End If
End Sub

Private Sub Class_Terminate()
    If mHmem > 0 Then
        Call GlobalFree(mHmem)
    End If
End Sub

And then som API-declerations:

Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function GetClipboardFormatName Lib "user32" Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, ByVal lpString As String, ByVal nMaxCount As Long) As Long
Public Declare Function GetClipboardOwner Lib "user32" () As Long
Public Declare Function GetClipboardViewer Lib "user32" () As Long
Public Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
public Declare Function SetClipboardViewer Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function RegisterClipboardFormat Lib "user32" Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long

Public Enum enClipboardFormats
    CF_BITMAP = 2
    CF_DIB = 8
    CF_DIF = 5
    CF_ENHMETAFILE = 14
    CF_METAFILEPICT = 3
    CF_OEMTEXT = 7
    CF_PALETTE = 9
    CF_PENDATA = 10
    CF_RIFF = 11
    CF_SYLK = 4
    CF_TEXT = 1
    CF_TIFF = 6
    CF_UNICODETEXT = 13
    CF_WAVE = 12
End Enum
'\\ API Global memory class
'\\ Global memory management functions

Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
Public Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long

Public Enum enGlobalmemoryAllocationConstants
    GMEM_FIXED = &H0
    GMEM_DISCARDABLE = &H100
    GMEM_MOVEABLE = &H2
    GMEM_NOCOMPACT = &H10
    GMEM_NODISCARD = &H20
    GMEM_ZEROINIT = &H40
End Enum

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Conclussion:

The main-issue was the line:

RegisterClipboardFormat("Rich Text Format")