Const sPrinterName = "VeryPDF Demo EMF Printer"
'You can set the output filename at here
'Const szOutputFilename = "C:\out.bmp"
Const szOutputFilename = "C:\out.emf"

Private MyPrinter As MyPrinterInfo


Function RegQueryStringValue(ByVal hKey As Long, ByVal strValueName As String) As String
    
    Dim lResult As Long, lValueType As Long, strBuf As String, lDataBufSize As Long
    
    'retrieve information about the key
    lResult = RegQueryValueEx(hKey, strValueName, 0, lValueType, ByVal 0, lDataBufSize)
    
    If lResult = 0 Then
        If lValueType = REG_SZ Then
            'Create a buffer
            strBuf = String(lDataBufSize, Chr$(0))
            'retrieve the key's content
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, ByVal strBuf, lDataBufSize)
            If lResult = 0 Then
                'Remove the unnecessary chr$(0)'s
                RegQueryStringValue = Left$(strBuf, InStr(1, strBuf, Chr$(0)) - 1)
            End If
        ElseIf lValueType = REG_BINARY Then
            Dim strData As Integer
            'retrieve the key's value
            lResult = RegQueryValueEx(hKey, strValueName, 0, 0, strData, lDataBufSize)
            If lResult = 0 Then
                RegQueryStringValue = strData
            End If
        End If
    End If
End Function

Function GetString(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    'Open the key
    RegOpenKey hKey, strPath, Ret
    'Get the key's content
    GetString = RegQueryStringValue(Ret, strValue)
    'Close the key
    RegCloseKey Ret
End Function

Sub SaveString(hKey As Long, strPath As String, strValue As String, strData As String)
    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Save a string to the key
    RegSetValueEx Ret, strValue, 0, REG_SZ, ByVal strData, LenB(strData)
    'close the key
    RegCloseKey Ret
End Sub

Sub SaveStringLong(hKey As Long, strPath As String, strValue As String, strData As Long)
    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Set the key's value
    RegSetValueEx Ret, strValue, 0, REG_DWORD, strData, 4
    'close the key
    RegCloseKey Ret
End Sub

Sub DelSetting(hKey As Long, strPath As String, strValue As String)
    Dim Ret
    'Create a new key
    RegCreateKey hKey, strPath, Ret
    'Delete the key's value
    RegDeleteValue Ret, strValue
    'close the key
    RegCloseKey Ret
End Sub

Private Sub SetOutputFileName(ByVal strOutputFile As String)
    
    Dim szIniFilename As String
    
    szIniFilename = GetString(HKEY_LOCAL_MACHINE, "SOFTWARE\verypdf\docprint", "ConfigFile")

    SetDefaultPrinter sPrinterName
    'Set the output filename to mini EMF Printer

    WritePrivateProfileString "AutoSave", "OutputFile", strOutputFile, szIniFilename

    WritePrivateProfileString "AutoSaveOptions", "m_bCreateFileForEachPage", "1", szIniFilename
    WritePrivateProfileString "AutoSaveOptions", "m_strColorDepth", "24", szIniFilename
    WritePrivateProfileString "AutoSaveOptions", "m_strResolution", "200x200", szIniFilename
    WritePrivateProfileString "AutoSaveOptions", "m_bGrayscale", "0", szIniFilename
    
    SetDefaultPrinter sPrinterName
End Sub

Private Function GetMyPrinter() As Boolean
    CommonDialog1.PrinterDefault = False
    CommonDialog1.Flags = cdlPDReturnDC Or cdlPDPrintSetup
    CommonDialog1.CancelError = True
    On Error GoTo UserCancel
    CommonDialog1.ShowPrinter
    MyPrinter.Handle = CommonDialog1.hdc
    MyPrinter.dpiX = GetDeviceCaps(MyPrinter.Handle, LOGPIXELSX)
    MyPrinter.dpiY = GetDeviceCaps(MyPrinter.Handle, LOGPIXELSY)
    MyPrinter.OffsetX = GetDeviceCaps(MyPrinter.Handle, PHYSICALOFFSETX)
    MyPrinter.OffsetY = GetDeviceCaps(MyPrinter.Handle, PHYSICALOFFSETY)
    GetMyPrinter = True
    Exit Function
UserCancel:
    GetMyPrinter = False
End Function

Private Sub PrinterText(s1 As String, x As Single, y As Single)
    Dim xpos As Long, ypos As Long
    xpos = x * MyPrinter.dpiX - MyPrinter.OffsetX
    ypos = y * MyPrinter.dpiY - MyPrinter.OffsetY
    TextOut MyPrinter.Handle, xpos, ypos, s1, Len(s1)
End Sub

Public Sub ShellAndWait(cmdline$)
    Dim NameOfProc As PROCESS_INFORMATION
    Dim NameStart As STARTUPINFO
    Dim x As Long

    NameStart.cb = Len(NameStart)
    x = CreateProcessA(0&, cmdline$, 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, _
        0&, 0&, NameStart, NameOfProc)
    x = WaitForSingleObject(NameOfProc.hProcess, INFINITE)
    x = CloseHandle(NameOfProc.hProcess)
End Sub

Private Sub DocumentConverterDLL_Click()
    Dim iret As Long
    Dim strOptions As String
    
    docPrint_Register "XXXXXXXXXX", "XXXX Corporation"
    
    'Copyright @2003-2006 verypdf.com Inc
    'Web: http://www.verypdf.com
    'Email: support@ verypdf.com
    'Release Date: Oct 20 2006
    '--------------------------------------------
    'Usage: miniprint.exe [Options] < office - file > [<EMF-Bitmap-file>]
    '  -width <int>       : Set page width to image file
    '  -height <int>      : Set page height to image file
    '  -xres <int>        : Set X resolution to image file
    '  -yres <int>        : Set Y resolution to image file
    '  -bitcount <int>    : Set color depth for image conversion
    '  -grayscale <int>   : Create grayscale image file
    strOptions = strOptions + "-bitcount 1"        'Create 1 bit image file
    strOptions = strOptions + " -xres 100 -yres 100" 'Set 300 DPI for conversion
    
    'Convert XLS to a multipage TIFF file
    iret = docPrint_DocumentConverter("C:\test_excel.xls", "C:\test_excel.emf", strOptions)
    
    'Convert XLS to a multile single page TIFF files
    iret = docPrint_DocumentConverter("C:\test_excel.xls", "C:\test_excel.bmp", strOptions)
    MsgBox "Conversion Finished"
End Sub

Private Sub GDIDrawing_Click()
    Dim iret As Long, n As Long
    Dim s1 As String, xpos As Long, ypos As Long
    Dim docinf As DOCINFO
    ' set up an initial font
    Dim log_font As LOGFONT, new_font As Long, old_font As Long
    
    SetOutputFileName szOutputFilename

    If Not GetMyPrinter Then Exit Sub
    With log_font
      .lfEscapement = 0 ' desired rotation in tenths of a degree
      .lfHeight = 12 * (-MyPrinter.dpiY / 72) ' 12 points
      .lfFaceName = "Times New Roman" & vbNullChar
      .lfWeight = 400 ' standard (bold = 700)
      .lfItalic = False
      .lfUnderline = False
    End With
    new_font = CreateFontIndirect(log_font)
    old_font = SelectObject(MyPrinter.Handle, new_font)
    ' start a document
    docinf.cbSize = Len(docinf) ' Size of DOCINFO structure
    iret = StartDoc(MyPrinter.Handle, docinf) 'Start new document
    iret = StartPage(MyPrinter.Handle)    'Start a new page
    '
    ' print a simple line of text at position (1, 1) (inches)
    For n = 1 To 10
        PrinterText "This is Line " & Format(n), 1, 1 * 0.16 * n
    Next n
    ' end page
    iret = EndPage(MyPrinter.Handle) 'End the page
    ' end the document
    SelectObject MyPrinter.Handle, old_font
    DeleteObject new_font ' clear up the font
    iret = EndDoc(MyPrinter.Handle) 'End the print job
    iret = DeleteDC(MyPrinter.Handle)
    
    MsgBox "Printing finished."

End Sub

Private Sub GDIFuncs_Click()
    Dim mytest As String
    Dim width As Long
    Dim height As Long
    
    SetOutputFileName szOutputFilename
    
    mytest = "This is a test!"
    width = Printer.TextWidth(mytest) / 2
    height = Printer.TextHeight(mytest) / 2
    Printer.CurrentX = Printer.ScaleWidth / 2 - width
    Printer.CurrentY = Printer.ScaleHeight / 2 - height
    
    Printer.Print mytest
    Printer.Circle (200, 200), 1200, RGB(255, 0, 0)

    Printer.EndDoc

    MsgBox "Printing finished."

End Sub

Private Sub PrintAccess_Click()
    Dim bFlag As Boolean
    
    SetOutputFileName szOutputFilename
    
    On Error GoTo FileOpenDlg_ErrHandler
    FileOpenDlg.CancelError = True
    FileOpenDlg.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNLongNames
    FileOpenDlg.Filter = "MS PowerPoint presentations (*.mdb)|*.mdb"
    FileOpenDlg.FilterIndex = 1
    FileOpenDlg.ShowOpen
    
    Dim appAccess As Object
    Set appAccess = CreateObject("Access.Application")
    With appAccess
        .OpenCurrentDatabase (FileOpenDlg.FileName)
        '.Reports("myreport").Print   ' --OR--
        '.DoCmd.OpenReport "myreport", acViewNormal
        .DoCmd.OpenReport ("myreport")
        .CloseCurrentDatabase
        .Quit
    End With
    Set appAccess = Nothing
    MsgBox "Printing finished."

FileOpenDlg_ErrHandler:
  Exit Sub

End Sub

Private Sub PrintBMP_Click()

    SetOutputFileName szOutputFilename
    
    On Error GoTo FileOpenDlg_ErrHandler
    FileOpenDlg.CancelError = True
    FileOpenDlg.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNLongNames
    FileOpenDlg.Filter = "Image file (Bitmap, JPEG, GIF or Metafile)|*.bmp;*.jpg;*.gif;*.wmf;*.emf"
    FileOpenDlg.FilterIndex = 1
    FileOpenDlg.ShowOpen
    
    On Error GoTo LoadPic_ErrHandler
    Picture1.Picture = LoadPicture(FileOpenDlg.FileName)
    
    On Error GoTo 0
    
    Printer.CurrentX = 0
    Printer.CurrentY = 0
    Call Printer.PaintPicture(Picture1.Picture, 0, 0)

    Printer.EndDoc
    Picture1.Picture = Nothing
    MsgBox "Printing finished."
    
FileOpenDlg_ErrHandler:
LoadPic_ErrHandler:

End Sub

Private Sub PrintPDF_Click()
' You need install the full version of Acrobat into order to get function to work

    SetOutputFileName szOutputFilename

    On Error GoTo FileOpenDlg_ErrHandler
    FileOpenDlg.CancelError = True
    FileOpenDlg.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNLongNames
    FileOpenDlg.Filter = "Adobe Acrobat documents (*.pdf)|*.pdf"
    FileOpenDlg.FilterIndex = 1
    FileOpenDlg.ShowOpen

    On Error GoTo 0
    Dim acroApp As Object
    Dim acroAVDoc As Object
    Dim acroPDDoc As Object
    Dim nPages As Long
    
    Set acroApp = CreateObject("AcroExch.App")
    Set acroAVDoc = CreateObject("AcroExch.AVDoc")
    
    If acroAVDoc.Open(FileOpenDlg.FileName, "") = True Then
        Set acroPDDoc = acroAVDoc.GetPDDoc()
        nPages = acroPDDoc.GetNumPages()
        
        acroAVDoc.PrintPages 0, nPages - 1, 0, 1, 1
        
        acroAVDoc.Close 1
        Set acroAVDoc = Nothing
        Set acroPDDoc = Nothing
    End If
    
    Call acroApp.Exit
    Set acroApp = Nothing
    MsgBox "Printing finished."

FileOpenDlg_ErrHandler:
  Exit Sub

End Sub

Private Sub PrintPPT_Click()
' You need install MS PowerPoint in order to get this function to work

    Dim bFlag As Boolean
    
    SetOutputFileName szOutputFilename
    
    On Error GoTo FileOpenDlg_ErrHandler
    FileOpenDlg.CancelError = True
    FileOpenDlg.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNLongNames
    FileOpenDlg.Filter = "MS PowerPoint presentations (*.ppt)|*.ppt"
    FileOpenDlg.FilterIndex = 1
    FileOpenDlg.ShowOpen
    
    On Error Resume Next
    Dim pptApp As Object
    Dim ppPresent As Object
        
    Set pptApp = CreateObject("PowerPoint.Application")
    
    Err = 0
    Set ppPresent = pptApp.Presentations.Open(FileOpenDlg.FileName, 1, 1, 0)
    If Err = 0 Then
        ppPresent.PrintOptions.PrintInBackground = 0
        ppPresent.PrintOptions.ActivePrinter = sPrinterName
    
    With ppPresent
         bFlag = .PrintOptions.PrintInBackground
        .PrintOptions.PrintInBackground = False
        .PrintOptions.PrintColorType = 1
        .PrintOut Copies:=1, Collate:=True
        .PrintOptions.PrintInBackground = bFlag
        .Saved = True
        .Close
    End With
        
        Call ppPresent.Close
        Set ppPresent = Nothing
    End If
    
    Call pptApp.Quit
    Set pptApp = Nothing
    MsgBox "Printing finished."

FileOpenDlg_ErrHandler:
  Exit Sub

End Sub

Private Sub PrintVisio_Click()
' You need install MS Visio 2000 in order to get this function to work

    SetOutputFileName szOutputFilename

    On Error GoTo FileOpenDlg_ErrHandler
    FileOpenDlg.CancelError = True
    FileOpenDlg.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNLongNames
    FileOpenDlg.Filter = "MS Visio drawings (*.vsd)|*.vsd"
    FileOpenDlg.FilterIndex = 1
    FileOpenDlg.ShowOpen
    
    On Error Resume Next
    Dim visioApp As Object
    Dim drawing As Object
    Dim Page As Object
    
    Set visioApp = CreateObject("Visio.Application")
    
    Err = 0
    Set drawing = visioApp.Documents.OpenEx(FileOpenDlg.FileName, &H20 And &H8)
    If Err = 0 Then
    
        drawing.Mode = 0
        drawing.PrintCenteredH = 1
        drawing.PrintCenteredV = 1
        drawing.PrintFitOnPages = 1
        
        drawing.PrintOut (0)
        
        drawing.Saved = 1
        drawing.Close
        
        Set drawing = Nothing
    End If
    
    Call visioApp.Quit
    Set visioApp = Nothing
    MsgBox "Printing finished."

FileOpenDlg_ErrHandler:
  Exit Sub

End Sub

Private Sub PrintWord_Click()
' You need install MS Word in order to get this function to work

    SetOutputFileName szOutputFilename

    On Error GoTo FileOpenDlg_ErrHandler
    FileOpenDlg.CancelError = True
    FileOpenDlg.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNLongNames
    FileOpenDlg.Filter = "MS Word documents (*.doc)|*.doc"
    FileOpenDlg.FilterIndex = 1
    FileOpenDlg.ShowOpen
    
    On Error Resume Next
    Dim wordApp As Object
    Dim wDoc As Object
    
    Set wordApp = CreateObject("Word.Application")
    
    Err = 0
    Set wDoc = wordApp.Documents.Open(FileOpenDlg.FileName, , 1)
    
    If Err = 0 Then
        wordApp.ActivePrinter = sPrinterName
        Call wordApp.PrintOut(False)
        
        wDoc.Close
        Set wDoc = Nothing
    End If
    
    Call wordApp.Quit
    Set wordApp = Nothing
    MsgBox "Printing finished."
    
FileOpenDlg_ErrHandler:
  Exit Sub

End Sub

Private Sub PrintXLS_Click()
' You need install MS Excel in order to get this function to work

    SetOutputFileName szOutputFilename

    On Error GoTo FileOpenDlg_ErrHandler
    FileOpenDlg.CancelError = True
    FileOpenDlg.Flags = cdlOFNFileMustExist Or cdlOFNPathMustExist Or cdlOFNExplorer Or cdlOFNLongNames
    FileOpenDlg.Filter = "MS Excel worksheets (*.xls)|*.xls"
    FileOpenDlg.FilterIndex = 1
    FileOpenDlg.ShowOpen
    
    On Error Resume Next
    Dim exclApp As Object
    Dim xlWB As Object
        
    Set exclApp = CreateObject("Excel.Application")
    
    Err = 0
    Set xlWB = exclApp.Workbooks.Open(FileOpenDlg.FileName, , True)
    If Err = 0 Then
    
        Call exclApp.Worksheets.PrintOut(, , , , sPrinterName)
        
        Call xlWB.Close
        Set xlWB = Nothing
    End If
    
    Call exclApp.Quit
    Set exclApp = Nothing
    MsgBox "Printing finished."

FileOpenDlg_ErrHandler:
  Exit Sub

End Sub