You are currently offline, waiting for your internet to reconnect

How To Call Clipboard API from Visual Basic 4.0

This article was previously published under Q159823
SUMMARY
This article contains sample code that illustrates how to call WindowsClipboard API to copy a disk metafile to the Windows Clipboard usingthe 16-bit and 32-bit versions of Visual Basic 4.0. The code in the articlecan also be used to work around a bug in the SetData method of the VisualBasic Clipboard object. The workaround replaces the SetData method you usewhen you copy a disk metafile to clipboard.
MORE INFORMATION
The following statement loads a metafile from a disk and copies it to theWindows Clipboard:
   'DiskMetaFileName is the path to a WMF file on the disk.   Clipboard.SetData LoadPicture(DiskMetaFileName), vbCFMetafile				

The metafile is successfully copied to the Clipboard. However, the metafilesize in the y dimension suggested in the disk metafile is ignored, and isset to match the suggested size in the x dimension. You can reproduce thebug by using the following code fragment with an Image control (Image1) onthe form:
   Clipboard.Clear                        ' Clear Clipboard.   Clipboard.SetData LoadPicture(DiskMetaFileName), vbCFMetafile   Image1.Stretch = False   'Resize the control to fit the graphics   Image1.Picture = Clipboard.GetData(vbCFMetafile) 'Copy from Clipboard   Debug.Print Image1.Width, Image1.Height				

NOTE: Image1.Width is always the same as Image1.Height.

The sample code in this article provides a subroutine, SetMetaToClp, thatworks around the bug by directly calling Windows API.

Step-by-Step Example

  1. Start Visual Basic 4.0. If it is already running, choose New Project from the File menu. Form1 is created by default.
  2. Add two CommandButtons, Command1 and Command2, to Form1.
  3. Add one Image control, Image1, to Form1.
  4. Clear all the code for Form1, and then paste the following code to the code window of Form1:
    'Please change the path so that it points to a valid metafile.Private Const strFileName = "d:\vb4\metafile\arrows\Smallarw.wmf"Private Sub Command1_Click()    Clipboard.Clear                ' Clear Clipboard.    Clipboard.SetData LoadPicture(strFileName), vbCFMetafile    Image1.Stretch = False    Image1.Picture = Clipboard.GetData(vbCFMetafile) 'Copy from Clipboard    Debug.Print Image1.Width, Image1.Height'Image1.Width is always the same as Image1.Height. Bug!End SubPrivate Sub Command2_Click()    Clipboard.Clear                       ' Clear Clipboard.    SetMetaToClp strFileName    Image1.Stretch = False    Image1.Picture = Clipboard.GetData(vbCFMetafile) 'Copy from Clipboard    Debug.Print Image1.Width, Image1.Height'Image1.Width and Image1.Height now display the metafile size suggested'in the disk metafileEnd Sub						
  5. Insert a module, Module1, into the project. Copy and paste the following code to Module1:
    Public Const OFS_MAXPATHNAME = 128Public Const OF_READ = &H0Public Const GMEM_SHARE = &H2000Public Const GMEM_MOVEABLE = &H2Public Const GMEM_ZEROINIT = &H40Public Const GHND = (GMEM_MOVEABLE Or GMEM_ZEROINIT)Public Const HFILE_ERROR = &HFFFFType OFSTRUCT        cBytes As Byte        fFixedDisk As Byte        nErrCode As Integer        Reserved1 As Integer        Reserved2 As Integer        szPathName(OFS_MAXPATHNAME) As ByteEnd TypeType RECT        Left As Integer        Top As Integer        Right As Integer        Bottom As IntegerEnd TypeType APMFILEHEADER    key As Long    hmf As Integer    bbox As RECT    inch As Integer    reserved As Long    checksum As IntegerEnd Type#If Win16 Then  Type METAHEADER        mtType As Integer        mtHeaderSize As Integer        mtVersion As Integer        dummy1 As Integer        mtSize As Long        mtNoObjects As Integer        dummy2 As Integer        mtMaxRecord As Long        mtNoParameters As Integer  End Type  Type METAFILEPICT    mm As Integer    xExt As Integer    yExt As Integer    hmf As Integer  End Type#Else  Type METAHEADER        mtType As Integer        mtHeaderSize As Integer        mtVersion As Integer        mtSize As Long        mtNoObjects As Integer        mtMaxRecord As Long        mtNoParameters As Integer  End Type  Type METAFILEPICT    mm As Long    xExt As Long    yExt As Long    hmf As Long  End Type#End If#If Win16 ThenDeclare Function OpenClipboard Lib "User" (ByVal hwnd As Integer) _    As IntegerDeclare Function CloseClipboard Lib "User" () As IntegerDeclare Function EmptyClipboard Lib "User" () As IntegerDeclare Function SetClipboardData Lib "User" (ByVal wFormat As _    Integer, ByVal hMem As Integer) As IntegerDeclare Function GlobalAlloc Lib "Kernel" (ByVal wFlags As Integer, _    ByVal dwBytes As Long) As IntegerDeclare Function GlobalLock Lib "Kernel" (ByVal hMem As Integer) As LongDeclare Function GlobalUnlock Lib "Kernel" (ByVal hMem As _Integer) As IntegerDeclare Function GlobalFree Lib "Kernel" (ByVal hMem As Integer) _As IntegerDeclare Sub CopyMemory Lib "Kernel" Alias "hmemcpy" (hpvDest As Any, _    ByVal hpvSource As Long, ByVal cbCopy As Long)Declare Sub CopyMemory2 Lib "Kernel" Alias "hmemcpy" (ByVal hpvDest _    As Long, hpvSource As Any, ByVal cbCopy As Long)Declare Function OpenFile Lib "Kernel" (ByVal lpFileName As String, _    lpReOpenBuff As OFSTRUCT, ByVal wStyle As Integer) As IntegerDeclare Function llseek Lib "Kernel" Alias "_llseek" (ByVal hFile As _    Integer, ByVal lOffset As Long, ByVal iOrigin As Integer) As LongDeclare Function lread Lib "Kernel" Alias "_lread" (ByVal hFile As _Integer, lpBuffer As Any, ByVal wBytes As Integer) As IntegerDeclare Function lread2 Lib "Kernel" Alias "_lread" (ByVal hFile As _    Integer, ByVal lpBuffer As Long, ByVal wBytes As Integer) As IntegerDeclare Function hread2 Lib "Kernel" Alias "_hread" (ByVal hFile As _    Integer, ByVal lpBuffer As Long, ByVal wBytes As Long) As LongDeclare Function lclose Lib "Kernel" Alias "_lclose" (ByVal hFile As _    Integer) As IntegerDeclare Function SetMetaFileBits Lib "GDI" (ByVal hMem As _Integer) As Integer#ElseDeclare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongDeclare Function CloseClipboard Lib "user32" () As LongDeclare Function EmptyClipboard Lib "user32" () As LongDeclare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _    ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "Kernel32" (ByVal wFlags As Long, _    ByVal dwBytes As Long) As LongDeclare Function GlobalLock Lib "Kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalUnlock Lib "Kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalFree Lib "Kernel32" (ByVal hMem As Long) As LongDeclare Sub CopyMemory Lib "Kernel32" Alias "RtlMoveMemory" ( _    hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)Declare Sub CopyMemory2 Lib "Kernel32" Alias "RtlMoveMemory" (ByVal _    hpvDest As Long, hpvSource As Any, ByVal cbCopy As Long)Declare Function OpenFile Lib "Kernel32" (ByVal lpFileName As String, _    lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As LongDeclare Function llseek Lib "Kernel32" Alias "_llseek" (ByVal hFile As _    Long, ByVal lOffset As Long, ByVal iOrigin As Long) As LongDeclare Function lread Lib "Kernel32" Alias "_lread" (ByVal hFile _    As Long, lpBuffer As Any, ByVal wBytes As Long) As LongDeclare Function lread2 Lib "Kernel32" Alias "_lread" (ByVal hFile _    As Long, ByVal lpBuffer As Long, ByVal wBytes As Long) As LongDeclare Function lclose Lib "Kernel32" Alias "_lclose" (ByVal hFile _    As Long) As LongDeclare Function SetMetaFileBitsEx Lib "gdi32" (ByVal nSize As Long, _    ByVal lpData As Long) As Long#End IfPublic Const CF_METAFILEPICT = 3Public Const MM_ANISOTROPIC = 8Public Const MM_ISOTROPIC = 7Public Const MM_TWIPS = 6Public Const MM_HIENGLISH = 5Public Const MM_HIMETRIC = 3Public Const MM_LOENGLISH = 4Public Const MM_LOMETRIC = 2Public Const MM_TEXT = 1Public Sub SetMetaToClp(szFileName As String)    Dim inof As OFSTRUCT    Dim APMHeader As APMFILEHEADER    Dim mfHeader As METAHEADER#If Win16 Then    Dim fh As Integer    Dim hData As Integer    Dim hmf As Integer    Dim hGlobal As Integer#Else    Dim fh As Long    Dim hData As Long    Dim hmf As Long    Dim hGlobal As Long#End If    fh = OpenFile(szFileName, inof, OF_READ)    If fh = HFILE_ERROR Then        Debug.Print "openfile fails"        Exit Sub    End If    llseek fh, 0, 0    lread fh, APMHeader, LenB(APMHeader)    llseek fh, LenB(APMHeader), 0    lread fh, mfHeader, LenB(mfHeader)    hData = GlobalAlloc(GHND, (mfHeader.mtSize * 2))    If hData = 0 Then        Debug.Print "fail to allocate memory"        lclose fh        Exit Sub    End If    Dim lpData As Long    lpData = GlobalLock(hData)    llseek fh, LenB(APMHeader), 0#If Win16 Then    hread2 fh, lpData, mfHeader.mtSize * 2    GlobalUnlock (hData)    hmf = SetMetaFileBits(hData)#Else    lread2 fh, lpData, mfHeader.mtSize * 2    hmf = SetMetaFileBitsEx(mfHeader.mtSize * 2, lpData)#End If    lclose fh     'if any above file op's fail, hmf will be 0     'or you can check each file op return to see if it is HFILE_ERROR     'but that will be a big waste of code    If hmf = 0 Then        Debug.Print "openfile or SetMetaFile fails"        GlobalFree hData        Exit Sub    End If    Dim myMetaFilePict As METAFILEPICT    myMetaFilePict.mm = MM_ANISOTROPIC    myMetaFilePict.xExt = 2540& * (APMHeader.bbox.Right - _        APMHeader.bbox.Left) / APMHeader.inch    myMetaFilePict.yExt = 2540& * (APMHeader.bbox.Bottom - _        APMHeader.bbox.Top) / APMHeader.inch    myMetaFilePict.hmf = hmf 'cannot directly put myMetaFilePict to clipboard 'memory block for clipboard has to have the flag GMEM_SHARE    hGlobal = GlobalAlloc(GMEM_SHARE, LenB(myMetaFilePict))    Dim lpPict As Long    lpPict = GlobalLock(hGlobal)    CopyMemory2 lpPict, myMetaFilePict, LenB(myMetaFilePict)    GlobalUnlock hGlobal    OpenClipboard 0    EmptyClipboard    SetClipboardData CF_METAFILEPICT, hGlobal    CloseClipboardEnd Sub						

(c) Microsoft Corporation 1996, All Rights Reserved.
Contributions by Wei Hua, Microsoft Corporation
Properties

Article ID: 159823 - Last Review: 07/14/2004 18:36:00 - Revision: 2.2

  • Microsoft Visual Basic 4.0 Professional Edition
  • Microsoft Visual Basic 4.0 Professional Edition
  • Microsoft Visual Basic 4.0 16-bit Enterprise Edition
  • Microsoft Visual Basic 4.0 32-Bit Enterprise Edition
  • kbhowto kbwndw kbcode KB159823
Feedback