Home  Mini-EMF-Printer  docPrint  docPrint-Pro  Support  ScreenShots

Mini EMF Printer VB Example Code

Mini EMF Printer is a virtual printer software that saves any document you print as EMF, WMF and raster bitmap formats. Below are some examples that can help you to accomplish your task with Mini EMF Printer.

Download Evaluation Version of Mini EMF Printer Driver SDK
Purchase Mini EMF Printer Driver SDK

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

Copyright 2000-2006 by VeryPDF, Inc.
Send comments about this site to the webmaster.