Dan Appleman's Visual Bas…s Guide to the Win32 API/Dan.Applmans.Visual.Basic.5.0.Programmers.Guide.To.The.Win32.API.1997.Ziff-Davis.Press.CD/VB5PG32.mdf/vbpg32/samples5/ch12/picprint.frm

Visual Basic Form | 1997-02-16 | 14.8 KB | 394 lines

VERSION 5.00
Begin VB.Form Picprint
   Caption         =   "Picture Print Demo"
   ClientHeight    =   4005
   ClientLeft      =   1380
   ClientTop       =   2055
   ClientWidth     =   7365
   BeginProperty Font
      Name            =   "MS Sans Serif"
      Size            =   8.25
      Charset         =   0
      Weight          =   700
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   ForeColor       =   &H80000008&
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4005
   ScaleWidth      =   7365
   Begin VB.CommandButton CmdPrintAPI
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Print: Use API"
      Height          =   495
      Left            =   5160
      TabIndex        =   2
      Top             =   840
      Width           =   2055
   End
   Begin VB.CommandButton CmdPrint
      Appearance      =   0  'Flat
      BackColor       =   &H80000005&
      Caption         =   "Print: Use VB Printer"
      Height          =   495
      Left            =   5160
      TabIndex        =   1
      Top             =   240
      Width           =   2055
   End
   Begin VB.PictureBox Picture1
      Appearance      =   0  'Flat
      AutoRedraw      =   -1  'True
      BackColor       =   &H80000005&
      ForeColor       =   &H80000008&
      Height          =   3615
      Left            =   120
      Picture         =   "PICPRINT.frx":0000
      ScaleHeight     =   3585
      ScaleWidth      =   4785
      TabIndex        =   0
      Top             =   120
      Width           =   4815
   End
   Begin VB.Menu MenuConfigPrinter
      Caption         =   "ConfigPrinter"
      Begin VB.Menu mnuPrinterProperties
         Caption         =   "PrinterProperties"
      End
      Begin VB.Menu mnuConfigurePort
         Caption         =   "Configure LPT1"
      End
      Begin VB.Menu mnuConnectToPrinter
         Caption         =   "ConnectToPrinter"
      End
      Begin VB.Menu mnuDocProperties
         Caption         =   "DocumentProperties"
      End
      Begin VB.Menu MenuPaperSizes
         Caption         =   "PaperSizes"
      End
   End
Attribute VB_Name = "Picprint"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' Copyright
 1997 by Desaware Inc. All Rights Reserved.
' This function is called during the EndPage API function
' to allow the user to abort printing
' Printing using the VB printer object
Private Sub CmdPrint_Click()
    Dim oldcursor&
    oldcursor = Screen.MousePointer
    Screen.MousePointer = 11
    Printer.Print " "   ' Convince VB that something should be printed
    PrintBitmap Printer.hdc
    Printer.NewPage
    Printer.EndDoc
    Screen.MousePointer = oldcursor
End Sub
' This function shows how you can use the API to obtain
'   a printer device context for printing.
'   Note how this function also switches to print in
'   landscape mode without changing the default printer
'   configuration.
Private Sub CmdPrintAPI_Click()
    Dim DeviceName$
    Dim dm As DEVMODE, dmout As DEVMODE
    Dim bufsize&
    Dim dmInBuf() As Byte
    Dim dmOutBuf() As Byte
    Dim prhdc&
    Dim dinfo As DOCINFO
    Dim docname$
    Dim oldcursor&
    Dim hPrinter&
    Dim res&, di&
    hPrinter = OpenDefaultPrinter(DeviceName$)

    ' Get a copy of the DEVMODE structure for this printer
    ' First find out how big the DEVMODE structure is
    bufsize& = DocumentProperties(hwnd, hPrinter, DeviceName$, 0, 0, 0)
    ' Allocate buffers of that size
    ReDim dmInBuf(bufsize&)
    ReDim dmOutBuf(bufsize&)
    ' Get the output DEVMODE structure
    res = DocumentProperties(hwnd, hPrinter, DeviceName$, agGetAddressForObject(dmOutBuf(0)), agGetAddressForObject(dmInBuf(0)), DM_OUT_BUFFER)
    ' Copy the data buffer into the DEVMODE structure
     agCopyData dmOutBuf(0), dmout, Len(dmout)
    ' Set the orientation, and set the dmField flag so that
    ' the function will know that it is valid.
    dmout.dmOrientation = DMORIENT_LANDSCAPE
    dmout.dmFields = dm.dmFields Or DM_ORIENTATION
    ' Now copy the data back to the buffer
    agCopyData dmout, dmOutBuf(0), Len(dmout)
    ' We now have need DC to the default printer
    ' This DC is also initialized to landscape mode
    prhdc = CreateDCBynum("WINSPOOL", DeviceName$, vbNullString, agGetAddressForObject&(dmOutBuf(0)))
    If prhdc = 0 Then GoTo cleanup2
    ' The DOCINFO structure is the information that the
    ' print manager will show. This also gives you the
    ' opportunity of dumping output to a file.
    docname$ = "Sample Document"
    dinfo.cbSize = Len(dinfo)
    dinfo.lpszDocName = docname$
    dinfo.lpszOutput = vbNullString
    ' We set up the abort procdure here
    AbortPrinting% = 0
    di = SetAbortProc(prhdc, AddressOf Callback1_AbortProc)
    ' And show the abort form which will be system modal
    AbortForm.Show
    Call BringWindowToTop(AbortForm.hwnd)
    AbortForm.Refresh
    Enabled = False ' Disable the main form
    ' The usual print sequence here
    di = StartDoc(prhdc, dinfo)
    di = StartPage(prhdc)
    PrintBitmap prhdc
    ' The system will spend a long time in the EndPage
    ' function, but it will periodically call the Abort
    ' procedure which in turn triggers the Callback1
    ' AbortProc event.
    di = EndPage(prhdc)
    If di >= 0 Then di = EndDocAPI(prhdc)
    Unload AbortForm
    Enabled = True
cleanup2:
    If prhdc <> 0 Then di = DeleteDC(prhdc)
    If hPrinter <> 0 Then Call ClosePrinter(hPrinter)
End Sub
'   This function retrieves the definition of the default
'   printer on this system
Private Function GetDefPrinter$()
    Dim def$
    Dim di&
    def$ = String$(128, 0)
    di = GetProfileString("WINDOWS", "DEVICE", "", def$, 127)
    def$ = agGetStringFromLPSTR$(def$)
    GetDefPrinter$ = def$
End Function
'   This function returns the driver module name
Private Function GetDeviceDriver$(dev$)
    Dim firstpos%, nextpos%
    firstpos% = InStr(dev$, ",")
    nextpos% = InStr(firstpos% + 1, dev$, ",")
    GetDeviceDriver$ = Mid$(dev$, firstpos% + 1, nextpos% - firstpos% - 1)
End Function
'   Retrieves the name portion of a device string
Private Function GetDeviceName$(dev$)
    Dim npos%
    npos% = InStr(dev$, ",")
    GetDeviceName$ = Left$(dev$, npos% - 1)
End Function
'   Returns the output destination for the specified device
Private Function GetDeviceOutput$(dev$)
    Dim firstpos%, nextpos%
    firstpos% = InStr(dev$, ",")
    nextpos% = InStr(firstpos% + 1, dev$, ",")
    GetDeviceOutput$ = Mid$(dev$, nextpos% + 1)
End Function
'   Demonstration of the DocumentProperties function
Private Sub mnuDocProperties_Click()
    Dim dm As DEVMODE, dmout As DEVMODE
    Dim bufsize&, res&
    Dim dmInBuf() As Byte
    Dim dmOutBuf() As Byte
    Dim hPrinter&
    Dim DeviceName$

    hPrinter = OpenDefaultPrinter(DeviceName$)
    If hPrinter = 0 Then
        MsgBox "Unable to open default printer"
        Exit Sub
    End If
    ' The output DEVMODE structure will reflect any changes
    ' made by the printer setup dialog box.
    ' Note that no changes will be made to the default
    ' printer settings!
    bufsize = DocumentProperties(hwnd, hPrinter, DeviceName$, 0, 0, 0)
    ReDim dmInBuf(bufsize)
    ReDim dmOutBuf(bufsize)
    res = DocumentProperties(hwnd, hPrinter, DeviceName$, agGetAddressForObject(dmOutBuf(0)), agGetAddressForObject(dmInBuf(0)), DM_IN_PROMPT Or DM_OUT_BUFFER)

    ' Copy the data buffer into the DEVMODE structure
    agCopyData dmOutBuf(0), dmout, Len(dmout)
    ShowDevMode dmout
    ClosePrinter hPrinter
End Sub
'   This function shows how to use the DeviceCapabilities
'   function to find out how many paper names the device
'   supports. This technique can be used for any
'   device capability
Private Sub MenuPaperSizes_Click()
    Dim dev$, devname$, devoutput$
    Dim papercount&
    Dim papername$
    Dim a$, tname$
    Dim x&, di&
    dev$ = GetDefPrinter$() ' Get default printer info
    If dev$ = "" Then Exit Sub
    devname$ = GetDeviceName$(dev$)
    devoutput$ = GetDeviceOutput$(dev$)
    ' Find out how many paper names there are
    papercount = DeviceCapabilities(devname$, devoutput$, DC_PAPERNAMES, vbNullString, 0)
    If papercount = 0 Then
        MsgBox "No paper names available", 0, "Paper name capability"
        Exit Sub
    End If
    ' Now dimension the string large enough to hold them all
    papername$ = String$(64 * papercount, 0)
    di = DeviceCapabilities(devname$, devoutput$, DC_PAPERNAMES, papername$, 0)
    ' Now display the results
    For x = 1 To papercount
        tname$ = Mid$(papername$, (x - 1) * 64 + 1)
        a$ = a$ + agGetStringFromLPSTR$(tname$) & vbCrLf
    Next x
    MsgBox a$, 0, "Paper Names for Default Printer"
End Sub
'   Prints the bitmap in the picture1 control to the
'   printer context specified.
Private Sub PrintBitmap(hdc&)
    Dim bi As BITMAPINFO
    Dim dctemp&, dctemp2&
    Dim msg$
    Dim bufsize&
    Dim bm As BITMAP
    Dim ghnd&
    Dim gptr&
    Dim xpix&, ypix&
    Dim doscale&
    Dim uy&, ux&
    Dim di&
    ' Create a temporary memory DC and select into it
    ' the background picture of the picture1 control.
    dctemp& = CreateCompatibleDC(Picture1.hdc)
    ' Get the size of the picture bitmap
    di = GetObjectAPI(Picture1.Picture, Len(bm), bm)
    ' Can this printer handle the DIB?
    If (GetDeviceCaps(dctemp, RASTERCAPS)) And RC_DIBTODEV = 0 Then
        msg$ = "This device does not support DIB's" + vbCrLf + "See source code for further info"
        MsgBox msg$, 0, "No DIB support"
    End If
    ' Fill the BITMAPINFO for the desired DIB
    bi.bmiHeader.biSize = Len(bi.bmiHeader)
    bi.bmiHeader.biWidth = bm.bmWidth
    bi.bmiHeader.biHeight = bm.bmHeight
    bi.bmiHeader.biPlanes = 1
    ' Set to 24 here to create a 24 bit DIB
    ' Set to 8 here to create an 8 bit DIB
    bi.bmiHeader.biBitCount = 4
    bi.bmiHeader.biCompression = BI_RGB
    ' Now calculate the data buffer size needed
    bufsize& = bi.bmiHeader.biWidth
    ' Figure out the number of bytes based on the
    ' number of pixels in each byte. In this case we
    ' really don't need all this code because this example
    ' always uses a 16 color DIB, but the code is shown
    ' here for your future reference
    Select Case bi.bmiHeader.biBitCount
        Case 1
            bufsize& = (bufsize& + 7) / 8
        Case 4
            bufsize& = (bufsize& + 1) / 2
        Case 24
            bufsize& = bufsize& * 3
    End Select
    ' And make sure it aligns on a long boundary
    bufsize& = ((bufsize& + 3) / 4) * 4
    ' And multiply by the # of scan lines
    bufsize& = bufsize& * bi.bmiHeader.biHeight
    ' Now allocate a buffer to hold the data
    ' We use the global memory pool because this buffer
    ' could easily be above 64k bytes.
    ghnd = GlobalAlloc(GMEM_MOVEABLE, bufsize&)
    gptr& = GlobalLock&(ghnd)
    di = GetDIBits(dctemp, Picture1.Picture, 0, bm.bmHeight, ByVal gptr&, bi, DIB_RGB_COLORS)
    di = SetDIBitsToDevice(hdc, 0, 0, bm.bmWidth, bm.bmHeight, 0, 0, 0, bm.bmHeight, ByVal gptr&, bi, DIB_RGB_COLORS)
    ' Now see if we can also print a scaled version
    xpix = GetDeviceCaps(hdc, HORZRES)
    ' We subtract off the size of the bitmap already
    ' printed, plus some extra space
    ypix = GetDeviceCaps(hdc, VERTRES) - (bm.bmHeight + 50)
    ' Find out the largest multiplier we can use and still
    ' fit on the page
    doscale = xpix / bm.bmWidth
    If (ypix / bm.bmHeight < doscale) Then doscale = ypix / bm.bmHeight
    If doscale > 1 Then
        doscale = doscale
        ux = bm.bmWidth * doscale
        uy = bm.bmHeight * doscale
        ' Now how this is offset a bit so that we don't
        ' print over the 1:1 scaled bitmap
        di = StretchDIBits(hdc, 0, bm.bmHeight + 50, ux, uy, 0, 0, bm.bmWidth, bm.bmHeight, ByVal gptr&, bi, DIB_RGB_COLORS, SRCCOPY)
    End If
    ' Dump the global memory block
    di = GlobalUnlock(ghnd)
    di = GlobalFree(ghnd)
    di = DeleteDC(dctemp)
End Sub
' Shows information about the current device mode
Private Sub ShowDevMode(dm As DEVMODE)
    Dim crlf$
    Dim a$
    crlf$ = Chr$(13) + Chr$(10)
    a$ = "Device name = " + agGetStringFromLPSTR$(dm.dmDeviceName) + crlf$
    a$ = a$ + "Devmode Version: " + Hex$(dm.dmSpecVersion) + ", Driver version: " + Hex$(dm.dmDriverVersion) + crlf$
    a$ = a$ + "Orientation: "
    If dm.dmOrientation = DMORIENT_PORTRAIT Then a$ = a$ + "Portrait" Else a$ = a$ + "Landscape"
    a$ = a$ + crlf$
    a$ = a$ + "Field mask = " + Hex$(dm.dmFields) + crlf$
    a$ = a$ + "Copies = " + Str$(dm.dmCopies) + crlf$
    If dm.dmFields And DM_YRESOLUTION <> 0 Then
        a$ = a$ + "X,Y resolution = " + Str$(dm.dmPrintQuality) + "," + Str$(dm.dmYResolution) + crlf$
    End If
    MsgBox a$, 0, "Devmode structure"
End Sub
Private Sub mnuConfigurePort_Click()
    Dim dev$, devname$, devoutput$
    Dim hPrinter&, res&
    dev$ = GetDefPrinter$() ' Get default printer info
    If dev$ = "" Then Exit Sub
    devname$ = GetDeviceName$(dev$)
    devoutput$ = GetDeviceOutput$(dev$)
    Call ConfigurePort(vbNullString, hwnd, "LPT1:")
End Sub
Private Sub mnuConnectToPrinter_Click()
    Call ConnectToPrinterDlg(hwnd, 0)
End Sub
Private Sub mnuPrinterProperties_Click()
    Dim hPrinter&
    hPrinter& = OpenDefaultPrinter()
    If hPrinter = 0 Then
        MsgBox "Can't open default printer"
        Exit Sub
    End If
    Call PrinterProperties(hwnd, hPrinter)
    Call ClosePrinter(hPrinter)
End Sub
Public Function OpenDefaultPrinter(Optional DeviceName) As Long
    Dim dev$, devname$, devoutput$
    Dim hPrinter&, res&
    Dim pdefs As PRINTER_DEFAULTS
    pdefs.pDatatype = vbNullString
    pdefs.pDevMode = 0
    pdefs.DesiredAccess = PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE
    dev$ = GetDefPrinter$() ' Get default printer info
    If dev$ = "" Then Exit Function
    devname$ = GetDeviceName$(dev$)
    devoutput$ = GetDeviceOutput$(dev$)
    If Not IsMissing(DeviceName) Then
        DeviceName = devname$
    End If
    ' You can use OpenPrinterBynum to pass a zero as the
    ' third parameter, but you won't have full access to
    ' edit the printer properties
    res& = OpenPrinter(devname$, hPrinter, pdefs)
    If res <> 0 Then OpenDefaultPrinter = hPrinter
End Function