gcommondialog.cls

一個文件合成原碼!!!(VB)

                    Optional DisablePageNumbers As Boolean, _
                    Optional FromPage As Long = 1, _
                    Optional ToPage As Long = &HFFFF, _
                    Optional DisableSelection As Boolean, _
                    Optional Copies As Integer, _
                    Optional ShowPrintToFile As Boolean, _
                    Optional DisablePrintToFile As Boolean = True, _
                    Optional PrintToFile As Boolean, _
                    Optional Collate As Boolean, _
                    Optional PreventWarning As Boolean, _
                    Optional Owner As Long, _
                    Optional Printer As Object, _
                    Optional flags As Long, _
                    Optional Hook As Boolean = False, _
                    Optional EventSink As Object _
                ) As Boolean
    Dim afFlags As Long
    
    m_lApiReturn = 0
    m_lExtendedError = 0
    
    ' Set PRINTDLG flags
    afFlags = flags
    afFlags = afFlags Or (Abs(DisablePageNumbers) * PD_NOPAGENUMS) Or _
              (Abs(DisablePrintToFile) * PD_DISABLEPRINTTOFILE) Or _
              (Abs(DisableSelection) * PD_NOSELECTION) Or _
              (Abs(PrintToFile) * PD_PRINTTOFILE) Or _
              (Abs(Not ShowPrintToFile) * PD_HIDEPRINTTOFILE) Or _
              (Abs(PreventWarning) * PD_NOWARNING) Or _
              (Abs(Collate) * PD_COLLATE) Or _
              PD_USEDEVMODECOPIESANDCOLLATE Or _
              PD_RETURNDC
    If PrintRange = eprPageNumbers Then
        afFlags = afFlags Or PD_PAGENUMS
    ElseIf PrintRange = eprSelection Then
        afFlags = afFlags Or PD_SELECTION
    End If
    ' Mask out unwanted bits
    afFlags = afFlags And Not PD_ENABLEPRINTHOOK
    afFlags = afFlags And Not PD_ENABLEPRINTTEMPLATE
    afFlags = afFlags And Not PD_ENABLESETUPHOOK
    afFlags = afFlags And Not PD_ENABLESETUPTEMPLATE
        
    ' Fill in PRINTDLG structure
    Dim pd As TPRINTDLG
    pd.lStructSize = Len(pd)
    pd.hWndOwner = Owner
    pd.flags = afFlags
    pd.nFromPage = FromPage
    pd.nToPage = ToPage
    pd.nMinPage = 1
    pd.nMaxPage = &HFFFF
    If (Hook) Then
        'HookedDialog = Me
        'Set m_oEventSink = EventSink
        If (pd.flags And PD_PRINTSETUP) = PD_PRINTSETUP Then
            'pd.flags = pd.flags Or PD_ENABLESETUPHOOK
            'pd.lpfnSetupHook = lHookAddress(AddressOf PrintSetupHookProc)
        Else
            'pd.flags = pd.flags Or PD_ENABLEPRINTHOOK
            'pd.lpfnPrintHook = lHookAddress(AddressOf PrintHookProc)
        End If
    End If
    
    ' Show Print dialog
    m_lApiReturn = PrintDlg(pd)
    'ClearHookedDialog
    Set m_oEventSink = Nothing
    Select Case m_lApiReturn
    Case 1
        VBPrintDlg = True
        ' Return dialog values in parameters
        hdc = pd.hdc
        If (pd.flags And PD_PAGENUMS) Then
            PrintRange = eprPageNumbers
        ElseIf (pd.flags And PD_SELECTION) Then
            PrintRange = eprSelection
        Else
            PrintRange = eprAll
        End If
        FromPage = pd.nFromPage
        ToPage = pd.nToPage
        PrintToFile = (pd.flags And PD_PRINTTOFILE)
        ' Get DEVMODE structure from PRINTDLG
        
        Dim pDevMode As Long
        pDevMode = GlobalLock(pd.hDevMode)
        CopyMemory m_dvmode, ByVal pDevMode, Len(m_dvmode)
        GlobalUnlock pd.hDevMode
        If (pd.flags And PD_COLLATE) = PD_COLLATE Then
            ' User selected collate option but printer driver
            ' does not support collation.
            ' Collation option must be set from the
            ' PRINTDLG structure:
            Collate = True
            Copies = pd.nCopies
        Else
            ' Print driver supports collation or collation
            ' not switched on.
            ' DEVMODE structure contains Collation and copy
            ' information
            ' Get Copies and Collate settings from DEVMODE structure
            Collate = (m_dvmode.dmCollate = DMCOLLATE_TRUE)
            Copies = m_dvmode.dmCopies
        End If
        
        ' Set default printer properties
        On Error Resume Next
        If Not (Printer Is Nothing) Then
            Printer.Copies = Copies
            Printer.Orientation = m_dvmode.dmOrientation
            Printer.PaperSize = m_dvmode.dmPaperSize
            Printer.PrintQuality = m_dvmode.dmPrintQuality
        End If
        On Error GoTo 0
    Case 0
        ' Cancelled
        VBPrintDlg = False
    Case Else
        ' Extended error:
        m_lExtendedError = CommDlgExtendedError()
        VBPrintDlg = False
    End Select
    
End Function
Friend Property Get DevMode() As DevMode
    DevMode = m_dvmode
End Property
Public Function VBPageSetupDlg2( _
        Optional Owner As Long, _
        Optional DisableMargins As Boolean, _
        Optional DisableOrientation As Boolean, _
        Optional DisablePaper As Boolean, _
        Optional DisablePrinter As Boolean, _
        Optional LeftMargin As Single, _
        Optional MinLeftMargin As Single, _
        Optional RightMargin As Single, _
        Optional MinRightMargin As Single, _
        Optional TopMargin As Single, _
        Optional MinTopMargin As Single, _
        Optional BottomMargin As Single, _
        Optional MinBottomMargin As Single, _
        Optional PaperSize As EPaperSize = epsLetter, _
        Optional Orientation As EOrientation = eoPortrait, _
        Optional PrintQuality As EPrintQuality = epqDraft, _
        Optional Units As EPageSetupUnits = epsuInches, _
        Optional Printer As Object, _
        Optional flags As Long, _
        Optional Hook As Boolean = False, _
        Optional EventSink As Object _
    ) As Boolean
Dim afFlags As Long, afMask As Long
        
    m_lApiReturn = 0
    m_lExtendedError = 0
    ' Mask out unwanted bits
    afMask = Not (PSD_EnablePagePaintHook Or _
                  PSD_EnablePageSetupHook Or _
                  PSD_EnablePageSetupTemplate)
    ' Set TPAGESETUPDLG flags
    afFlags = (-DisableMargins * PSD_DISABLEMARGINS) Or _
              (-DisableOrientation * PSD_DISABLEORIENTATION) Or _
              (-DisablePaper * PSD_DISABLEPAPER) Or _
              (-DisablePrinter * PSD_DISABLEPRINTER) _
               And afMask
    If (flags And PSD_Defaultminmargins) = PSD_Defaultminmargins Then
        afFlags = afFlags Or PSD_Defaultminmargins
    Else
        afFlags = afFlags Or PSD_MARGINS
    End If
    Dim lUnits As Long
    If Units = epsuInches Then
        afFlags = afFlags Or PSD_INTHOUSANDTHSOFINCHES
        lUnits = 1000
    Else
        afFlags = afFlags Or PSD_INHUNDREDTHSOFMILLIMETERS
        lUnits = 100
    End If
    
    Dim psd As TPAGESETUPDLG
    ' Fill in PRINTDLG structure
    psd.lStructSize = Len(psd)
    psd.hWndOwner = Owner
    psd.rtMargin.Top = TopMargin * lUnits
    psd.rtMargin.Left = LeftMargin * lUnits
    psd.rtMargin.Bottom = BottomMargin * lUnits
    psd.rtMargin.Right = RightMargin * lUnits
    psd.rtMinMargin.Top = MinTopMargin * lUnits
    psd.rtMinMargin.Left = MinLeftMargin * lUnits
    psd.rtMinMargin.Bottom = MinBottomMargin * lUnits
    psd.rtMinMargin.Right = MinRightMargin * lUnits
    psd.flags = afFlags
    If (Hook) Then
        'HookedDialog = Me
        'Set m_oEventSink = EventSink
        'psd.lpfnPageSetupHook = lHookAddress(AddressOf PageSetupHook)
        'psd.flags = psd.flags Or PSD_EnablePageSetupHook
    End If
    
    ' Show Print dialog
    If PageSetupDlg(psd) Then
        VBPageSetupDlg2 = True
        ' Return dialog values in parameters
        TopMargin = psd.rtMargin.Top / lUnits
        LeftMargin = psd.rtMargin.Left / lUnits
        BottomMargin = psd.rtMargin.Bottom / lUnits
        RightMargin = psd.rtMargin.Right / lUnits
        MinTopMargin = psd.rtMinMargin.Top / lUnits
        MinLeftMargin = psd.rtMinMargin.Left / lUnits
        MinBottomMargin = psd.rtMinMargin.Bottom / lUnits
        MinRightMargin = psd.rtMinMargin.Right / lUnits
        
        ' Get DEVMODE structure from PRINTDLG
        Dim dvmode As DevMode, pDevMode As Long
        pDevMode = GlobalLock(psd.hDevMode)
        CopyMemory dvmode, ByVal pDevMode, Len(dvmode)
        GlobalUnlock psd.hDevMode
        PaperSize = dvmode.dmPaperSize
        Orientation = dvmode.dmOrientation
        PrintQuality = dvmode.dmPrintQuality
        ' Set default printer properties
        On Error Resume Next
        If Not (Printer Is Nothing) Then
            Printer.Copies = dvmode.dmCopies
            Printer.Orientation = dvmode.dmOrientation
            Printer.PaperSize = dvmode.dmPaperSize
            Printer.PrintQuality = dvmode.dmPrintQuality
        End If
        On Error GoTo 0
    End If
    Set m_oEventSink = Nothing
    'ClearHookedDialog
    
End Function

' PageSetupDlg wrapper
Function VBPageSetupDlg(Optional Owner As Long, _
                        Optional DisableMargins As Boolean, _
                        Optional DisableOrientation As Boolean, _
                        Optional DisablePaper As Boolean, _
                        Optional DisablePrinter As Boolean, _
                        Optional LeftMargin As Long, _
                        Optional MinLeftMargin As Long, _
                        Optional RightMargin As Long, _
                        Optional MinRightMargin As Long, _
                        Optional TopMargin As Long, _
                        Optional MinTopMargin As Long, _
                        Optional BottomMargin As Long, _
                        Optional MinBottomMargin As Long, _
                        Optional PaperSize As EPaperSize = epsLetter, _
                        Optional Orientation As EOrientation = eoPortrait, _
                        Optional PrintQuality As EPrintQuality = epqDraft, _
                        Optional Units As EPageSetupUnits = epsuInches, _
                        Optional Printer As Object, _
                        Optional flags As Long, _
                        Optional Hook As Boolean = False, _
                        Optional EventSink As Object _
                    ) As Boolean
Dim fLeftMargin As Single
Dim fMinLeftMargin As Single
Dim fRightMargin As Single
Dim fMinRightMargin As Single
Dim fTopMargin As Single
Dim fMinTopMargin As Single
Dim fBottomMargin As Single
Dim fMinBottomMargin As Single

    VBPageSetupDlg2 _
        Owner, _
        DisableMargins, _
        DisableOrientation, _
        DisablePaper, _
        DisablePrinter, _
        fLeftMargin, _
        fMinLeftMargin, _
        fRightMargin, _
        fMinRightMargin, _
        fTopMargin, _
        fMinTopMargin, _
        fBottomMargin, _
        fMinBottomMargin, _
        PaperSize, _
        Orientation, _
        PrintQuality, _
        Units, _
        Printer, _
        flags, _
        Hook, _
        EventSink
    LeftMargin = fLeftMargin
    MinLeftMargin = fMinLeftMargin
    RightMargin = fRightMargin
    MinRightMargin = fMinRightMargin
    TopMargin = fTopMargin
    MinTopMargin = fMinTopMargin
    BottomMargin = fBottomMargin
    MinBottomMargin = fMinBottomMargin
End Function

#If fComponent = 0 Then
Private Sub ErrRaise(e As Long)
    Dim sText As String, sSource As String
    If e > 1000 Then
        sSource = App.EXEName & ".CommonDialog"
        Err.Raise COMError(e), sSource, sText
    Else
        ' Raise standard Visual Basic error
        sSource = App.EXEName & ".VBError"
        Err.Raise e, sSource
    End If
End Sub
#End If


Private Sub StrToBytes(ab() As Byte, s As String)
    If IsArrayEmpty(ab) Then
        ' Assign to empty array
        ab = StrConv(s, vbFromUnicode)
    Else
        Dim cab As Long
        ' Copy to existing array, padding or truncating if necessary
        cab = UBound(ab) - LBound(ab) + 1
        If Len(s) < cab Then s = s & String$(cab - Len(s), 0)
        'If UnicodeTypeLib Then
        '    Dim st As String
        '    st = StrConv(s, vbFromUnicode)
        '    CopyMemoryStr ab(LBound(ab)), st, cab
        'Else
            CopyMemoryStr ab(LBound(ab)), s, cab
        'End If
    End If
End Sub


Private Function BytesToStr(ab() As Byte) As String
    BytesToStr = StrConv(ab, vbUnicode)
End Function

Private Function COMError(e As Long) As Long
    COMError = e Or vbObjectError
End Function
'
Private Function IsArrayEmpty(va As Variant) As Boolean
    Dim v As Variant
    On Error Resume Next
    v = va(LBound(va))
    IsArrayEmpty = (Err <> 0)
End Function