How to Extract the Metafile from an OLE Control (119395)

MORE INFORMATION

1. Start Visual Basic, or if Visual Basic is already running, choose New Project from the File menu (Alt+F, N) to create a new project.
2. On Form1, add the OLE Control, and select the object you want to insert.
3. On Form1, add a Picture Box and two Command Buttons. Set the Picture Box AutoRedraw property to True.
4. Create a new module by choosing File New Module (Alt+F, M). This will create "module1.bas". Enter the following code for "module1.bas" (making sure that the declare statements below each fit on one line):

      Option Explicit
   
      Type METAFILEPICT
          mm As Integer
          xext As Integer
          yext As Integer
          hmf As Integer
      End Type
   
      Type POINTAPI
          x As Integer
          y As Integer
      End Type
   
      Declare Function GLobalLock Lib "kernel" (ByVal hMem As Integer) As Long
      Declare Function GlobalUnlock Lib "kernel" (ByVal hMem As Integer)
                                                 As Integer
      Declare Sub hmemcpy Lib "kernel" (hpvDest As Any,
                                        ByVal hpvSource As Any,
                                        ByVal cbCopy As Long)
      Declare Sub hmemcpy2 Lib "kernel" Alias "hmemcpy" (hpvDest As Any,
                                                         hpvSource As Any,
                                                         ByVal cbCopy As Long)
      Declare Function PlayMetafile% Lib "GDI" (ByVal hDC%, ByVal hmf%)
      Declare Function SetMapMode Lib "GDI" (ByVal hDC As Integer,
                                             ByVal nMapMode As Integer)
                                            As Integer
      Declare Function SetViewPortExt Lib "GDI" (ByVal hDC As Integer,
                                                 ByVal x As Integer,
                                                 ByVal y As Integer)
                                                As Long
   
      ' A Special declare of SetViewPortExt that allows us
      ' to pass the x,y coordinates in one long variable.
      Declare Function SetViewPortExtd Lib "GDI" Alias "SetViewPortExt"
                                                (ByVal hDC As Integer,
                                                 ByVal viewport As Long)
                                                As Long
      Declare Function LPtoDP Lib "GDI" (ByVal hDC As Integer,
                                         lpPoints As POINTAPI,
                                         ByVal nCount As Integer) As Integer
   
      Global Const MM_HIMETRIC = 3
      Global Const MM_ANISOTROPIC = 8
   
   
      Function DrawMetaFile (MFPict As METAFILEPICT, zoomfactor As Integer,
                             hDC As Integer) As Integer
         Dim mappoint As POINTAPI  ' Stores a point (x,y) to help
                                   ' convert from HIMETRIC to pixels.
         Dim oldmapmode As Integer ' Stores the old map mode.
         Dim picwidth As Integer   ' Holds picture width in pixels.
         Dim picheight As Integer  ' Holds picture height in pixels.
         Dim oldviewport As Long   ' Stores the old viewport.
         Dim retvalue As Long      ' Holds API return values.
   
         DrawMetaFile = True
   
         ' The metafile coordinates are in HIMETRIC units.
         ' Set the mapmode of the hdc to HIMETRIC
         ' so you can calculate the size in pixels.
         oldmapmode = SetMapMode(hDC, MM_HIMETRIC)
   
         mappoint.x = MFPict.xext ' HIMETRIC width
         mappoint.y = MFPict.yext ' HIMETRIC height
   
         ' LPtoDP will convert the width and height to pixels.
         If (False = LPtoDP(hDC, mappoint, 1)) Then
            ' ReEstablish oldmapmode and exit with error.
            retvalue = SetMapMode(hDC, oldmapmode)
            GoTo DMFError
         End If
   
         ' Now set the mapmode to ANISOTROPIC to match the
         ' mapmode of the metafile.
         retvalue = SetMapMode(hDC, MM_ANISOTROPIC)
   
         ' Retrieve the converted width and height.
         ' Some values will be negative, so use Abs.
         picwidth = Abs(mappoint.x)
         picheight = Abs(mappoint.y)
   
         ' Scale to Zoom factor.
         picheight = picheight * zoomfactor
         picwidth = picwidth * zoomfactor
   
         ' Set the viewport to match our zoom.
         oldviewport = SetViewPortExt(hDC, picwidth, picheight)
   
         ' Play the metafile to the hdc.
         If (False = PlayMetafile(hDC, MFPict.hmf)) Then GoTo DMFError
   
         ' ReEstablish old viewport and map mode for the hdc.
         retvalue = SetViewPortExtd(hDC, oldviewport)
         retvalue = SetMapMode(hDC, oldmapmode)
   
         Exit Function
   
      DMFError:
         DrawMetaFile = False
      End Function
   
      Sub GetMetaFile (MFPict As METAFILEPICT, olectrl As OLE)
         Dim hGlbMem As Integer  ' Handle to Global Memory Object.
         Dim lpMem As Long       ' Long Pointer to Memory.
         Dim APISuccess As Integer ' Return value for errors (if any)
         Dim tempdata As Long      ' temporary for storing data property.
   
         ' OLE Control must be activated to get MetaFile.
         olectrl.Action = 7
   
         ' Tell the OLE Control what format we want.
         olectrl.Format = "CF_METAFILEPICT"
   
         ' Retrieve the Global Memory Handle from Data Property.
         ' Copy low 2 bytes to hGlbMem.
         ' hmemcpy2 lets us copy the unsigned integer part of tempdata.
         tempdata = olectrl.Data
         Call hmemcpy2(hGlbMem, tempdata, 2)
   
         ' Retrieve pointer to Global Memory.
         lpMem = GLobalLock(hGlbMem)
   
         ' Copy Metafile to MFPict.
         Call hmemcpy(MFPict, lpMem, Len(MFPict))
   
         ' Release pointer to Global Memory.
         APISuccess = GlobalUnlock(hGlbMem)
      End Sub
   						

5. For the Form1 Command1 Click event, enter the following code:

      Sub Command1_Click ()
         ' Draw Metafile to Printer.
         Dim MFPict As METAFILEPICT
         GetMetaFile MFPict, ole1
   
         ' Initialize the printer.
         printer.Print " "
   
         ' Draw to printer and double the size.
         If Not DrawMetaFile(MFPict, 2, (printer.hDC)) Then
            MsgBox "DrawMetaFile failed"
         End If
         printer.EndDoc
      End Sub
   						

6. For the Form1 Command2 Click event, enter the following code:

      Sub Command2_Click ()
         ' Draw Metafile to picture1.
         Dim MFPict As METAFILEPICT
         GetMetaFile MFPict, ole1
   
         If Not DrawMetaFile(MFPict, 1, (picture1.hDC)) Then
            MsgBox "DrawMetaFile failed"
         End If
         picture1.Refresh
      End Sub
   						

7. Save the project and run it. Choose Command1 to draw the metafile displayed by the OLE control to the printer. Choose Command2 to draw it to the picture box.