modprintcomdlg.bas

AddPrintPreviewtoVBV2 增加打印预览的功能

            -typ_PageSetupDlgFlags.EnablePageSetupTemplate * PSD_ENABLEPAGESETUPTEMPLATE Or _
            -typ_PageSetupDlgFlags.EnablePageSetupTemplateHandle * PSD_ENABLEPAGESETUPTEMPLATEHANDLE Or _
            -typ_PageSetupDlgFlags.Margins * PSD_MARGINS Or _
            -typ_PageSetupDlgFlags.MinMargins * PSD_MINMARGINS Or _
            -typ_PageSetupDlgFlags.NoWarning * PSD_NOWARNING Or _
            -typ_PageSetupDlgFlags.ReturnDefault * PSD_RETURNDEFAULT Or _
            -typ_PageSetupDlgFlags.ShowHelp * PSD_SHOWHELP

    If typ_PageSetupDlgFlags.InHundredthsOfMillimeters Then
        typ_PrintSetupDlg.flags = typ_PrintSetupDlg.flags Or PSD_INHUNDREDTHSOFMILLIMETERS
    Else
        typ_PrintSetupDlg.flags = typ_PrintSetupDlg.flags Or PSD_INTHOUSANDTHSOFINCHES
    End If

    'Set DEVMODE structure from TPRINTDLG
    m_lng_DevMode = GlobalLock(typ_PrintSetupDlg.hDevMode)
    If m_lng_DevMode > 0 Then
        Call CopyMemory(ByVal m_lng_DevMode, typ_DevMode, Len(typ_DevMode))
        hResult = GlobalUnlock(typ_PrintSetupDlg.hDevMode)
    End If

    'Set DEVNAMES structure from TPRINTDLG
    m_lng_DevNames = GlobalLock(typ_PrintSetupDlg.hDevNames)
    If m_lng_DevNames > 0 Then
        Call CopyMemory(ByVal m_lng_DevNames, typ_DevNames, Len(typ_DevNames))
        hResult = GlobalUnlock(typ_PrintSetupDlg.hDevNames)
    End If

    ' Show Print dialog
    If PageSetupDlg(typ_PrintSetupDlg) Then
        vbPageSetupDlg = True

        If Not GetPrinterStructs(typ_PrintSetupDlg.hDevMode, typ_PrintSetupDlg.hDevNames, typ_DevMode, typ_DevNames, True) Then
            vbPageSetupDlg = False
        End If

    End If
End Function

'PageSetupDlg wrapper
Public Function vbInitPageSetupDlg( _
    ByRef hWndOwner As Long, _
    ByRef typ_PrintSetupDlg As TPAGESETUPDLG, _
    ByRef typ_PrintDlg As TPRINTDLG, _
    ByRef typ_DevMode As DEVMODE, _
    ByRef typ_DevNames As DEVNAMES, _
    ByRef enum_PrinterUnits As PrinterUnitsConstants _
    ) As Boolean

    Dim hResult As Long

    'Set the Flags
    typ_PrintSetupDlg.lStructSize = Len(typ_PrintSetupDlg)
    If enum_PrinterUnits = puThousandthsOfInches Then
        typ_PrintSetupDlg.flags = PSD_RETURNDEFAULT Or PSD_INTHOUSANDTHSOFINCHES
    Else
        typ_PrintSetupDlg.flags = PSD_RETURNDEFAULT Or PSD_INHUNDREDTHSOFMILLIMETERS
    End If
    
    '**************************************
    ' The following code produces a Dr. Watson visit
    ' in certain versions of Windows... I still
    ' never understood why.
    '**************************************

    '    'Memory allocation must be done...
    '    typ_PrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(typ_DevMode))
    '    typ_PrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(typ_DevNames))
    '
    '    'Set DEVMODE structure from TPRINTDLG
    '    m_lng_DevMode = GlobalLock(typ_PrintDlg.hDevMode)
    '    If m_lng_DevMode > 0 Then
    '        Call CopyMemory(ByVal m_lng_DevMode, typ_DevMode, Len(typ_DevMode))
    '        hResult = GlobalUnlock(typ_PrintDlg.hDevMode)
    '    End If
    '
    '    'Set DEVNAMES structure from TPRINTDLG
    '    m_lng_DevNames = GlobalLock(typ_PrintDlg.hDevNames)
    '    If m_lng_DevNames > 0 Then
    '        Call CopyMemory(ByVal m_lng_DevNames, typ_DevNames, Len(typ_DevNames))
    '        hResult = GlobalUnlock(typ_PrintDlg.hDevNames)
    '    End If
    '
    '    'Set DEVMODE structure from TPRINTDLG
    '    m_lng_DevMode = GlobalLock(typ_PrintSetupDlg.hDevMode)
    '    If m_lng_DevMode > 0 Then
    '        Call CopyMemory(ByVal m_lng_DevMode, typ_DevMode, Len(typ_DevMode))
    '        hResult = GlobalUnlock(typ_PrintSetupDlg.hDevMode)
    '    End If
    '
    '    'Set DEVNAMES structure from TPRINTDLG
    '    m_lng_DevNames = GlobalLock(typ_PrintSetupDlg.hDevNames)
    '    If m_lng_DevNames > 0 Then
    '        Call CopyMemory(ByVal m_lng_DevNames, typ_DevNames, Len(typ_DevNames))
    '        hResult = GlobalUnlock(typ_PrintSetupDlg.hDevNames)
    '    End If

    ' Show Print dialog
    If PageSetupDlg(typ_PrintSetupDlg) Then
        vbInitPageSetupDlg = True

        If Not GetPrinterStructs(typ_PrintSetupDlg.hDevMode, typ_PrintSetupDlg.hDevNames, typ_DevMode, typ_DevNames) Then
            vbInitPageSetupDlg = False
        End If

    Else
        vbInitPageSetupDlg = False
    End If
End Function

Private Function GetPrinterStructs( _
    ByRef in_lng_hDevMode As Long, _
    ByRef in_lng_hDevNames As Long, _
    ByRef in_typ_DevMode As DEVMODE, _
    ByRef in_typ_DevNames As DEVNAMES, _
    Optional in_bool_SetPrntr As Boolean = False) As Boolean

    Dim str_DevName     As String
    Dim SelPrinter      As Printer
    Dim hResult         As Long

    GetPrinterStructs = True

    'Get DEVMODE structure from TPRINTDLG
    m_lng_DevMode = GlobalLock(in_lng_hDevMode)
    Call CopyMemory(in_typ_DevMode, ByVal m_lng_DevMode, Len(in_typ_DevMode))
    hResult = GlobalUnlock(m_lng_DevMode)

    'Get DEVNAMES structure from TPRINTDLG
    m_lng_DevNames = GlobalLock(in_lng_hDevNames)
    Call CopyMemory(in_typ_DevNames, ByVal m_lng_DevNames, Len(in_typ_DevNames))
    hResult = GlobalUnlock(m_lng_DevNames)

    If in_bool_SetPrntr Then
        'Set Selected Printer
        On Error Resume Next
        str_DevName = StripNulls(BytesToStr(in_typ_DevMode.dmDeviceName))
        If UCase(Printer.DeviceName) <> UCase(str_DevName) Then
            g_int_CurrentPrinterIndex = -1
            For Each SelPrinter In Printers
                g_int_CurrentPrinterIndex = g_int_CurrentPrinterIndex + 1
                If UCase(SelPrinter.DeviceName) = UCase(str_DevName) Then
                    If Not ISetDfltPrinter.SetPrinterAsDefault(SelPrinter.DeviceName) Then GetPrinterStructs = False
                    Exit For
                End If
            Next SelPrinter
        End If

        ' Set default printer properties
        On Error Resume Next
        Printer.Print "";

        #If ShowDebugPrints = 1 Then
            Debug.Print "***************Pre-setting***************"
            Debug.Print "Printer.ColorMode:", Printer.ColorMode
            Debug.Print "Printer.Copies:", Printer.Copies
            Debug.Print "Printer.Duplex:", Printer.Duplex
            Debug.Print "Printer.Orientation:", Printer.Orientation
            Debug.Print "Printer.PaperBin:", Printer.PaperBin
            Debug.Print "Printer.PaperSize:", Printer.PaperSize
            Debug.Print "Printer.PrintQuality:", Printer.PrintQuality
            Debug.Print "***************Setting***************"
        #End If

        Printer.ColorMode = in_typ_DevMode.dmColor
        Printer.Copies = in_typ_DevMode.dmCopies
        Printer.Duplex = in_typ_DevMode.dmDuplex
        Printer.Orientation = in_typ_DevMode.dmOrientation
        Printer.PaperBin = in_typ_DevMode.dmDefaultSource
        Printer.PaperSize = in_typ_DevMode.dmPaperSize
        Printer.PrintQuality = in_typ_DevMode.dmPrintQuality

        #If ShowDebugPrints = 1 Then
            Debug.Print "***************Checking***************"
            Debug.Print "Printer.ColorMode:", Printer.ColorMode
            Debug.Print "Printer.Copies:", Printer.Copies
            Debug.Print "Printer.Duplex:", Printer.Duplex
            Debug.Print "Printer.Orientation:", Printer.Orientation
            Debug.Print "Printer.PaperBin:", Printer.PaperBin
            Debug.Print "Printer.PaperSize:", Printer.PaperSize
            Debug.Print "Printer.PrintQuality:", Printer.PrintQuality
            Debug.Print "***************DONE***************"
        #End If
    End If
End Function

' Convert an ANSI string in a byte array to a VB Unicode string
Public Function BytesToStr(ab() As Byte) As String
    BytesToStr = StrConv(ab, vbUnicode)
End Function

Public Function StripNulls(OriginalStr As String) As String
    If (InStr(OriginalStr, Chr(0)) > 0) Then
        OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function