cdlg.cls

超经典的打印预览动态库源码 版权： 本资源版权归作者所有 说明： 本资源由源码天空搜集,仅提供学习参考

            ShowFont

        Case 5  'Printer
            ShowPrinter

        Case 6  'WinHelp32.exe
            ShowHelp

        Case Else
    End Select
End Property

'---------------------------------------------
'Methods

Public Sub ShowSave() 'Displays the CommonDialog control's Save As dialog box.
Attribute ShowSave.VB_Description = "Displays the Save As dialog box."
    Dim l As Long
    piAction = 2

    With OFN
        .nStructSize = Len(OFN)
        .hWndOwner = 0&
        .sFilter = Replace(Filter, "|", vbNullChar)
        .nFilterIndex = FilterIndex
        .sFile = Left$(FileName & SPACE$(1024), MaxFileSize - 2) & vbNullChar & vbNullChar
        .nMaxFile = MaxFileSize
        .sDefFileExt = DefaultExt & vbNullChar & vbNullChar
        .sFileTitle = vbNullChar & SPACE$(512) & vbNullChar & vbNullChar
        .nMaxTitle = Len(OFN.sFileTitle)
        .sInitialDir = InitDir & vbNullChar & vbNullChar
        .sDialogTitle = DialogTitle
        .Flags = Flags
    End With
    l = GetSaveFileName(OFN)

    Select Case l

        Case 1
            FileName = TrimNull(OFN.sFile)     'Path and File
            FileTitle = TrimNull(OFN.sFileTitle)  'File Only

        Case Else
            ' Extended error:
            HandleDlgError CommDlgExtendedError()
    End Select
End Sub

Public Sub ShowHelp() 'Runs Winhelp.EXE and displays the Help file you specify.
Attribute ShowHelp.VB_Description = "Runs WinHelp.EXE and displays the help file you specify."
    piAction = 6

    If HelpFile <> "" Then

        Select Case HelpCommand

            Case cdlHelpKey
                OSWinHelp 0&, HelpFile, HelpCommand, HelpKey

            Case cdlHelpContext, cdlHelpSetIndex
                OSWinHelp 0&, HelpFile, HelpCommand, HelpContext

            Case Else
                OSWinHelp 0&, HelpFile, HelpCommand, 0
        End Select
    End If
End Sub

Public Sub ShowOpen() 'Displays the CommonDialog control's Open dialog box.
Attribute ShowOpen.VB_Description = "Displays the Open dialog box."
    Dim l As Long
    piAction = 1

    With OFN
        .nStructSize = Len(OFN)
        .hWndOwner = 0&
        .sFilter = Replace(Filter, "|", vbNullChar)
        .nFilterIndex = FilterIndex
        .sFile = Left(FileName & SPACE$(1024), MaxFileSize - 2) & vbNullChar & vbNullChar
        .nMaxFile = MaxFileSize
        .sDefFileExt = DefaultExt & vbNullChar & vbNullChar
        .sFileTitle = vbNullChar & SPACE$(512) & vbNullChar & vbNullChar
        .nMaxTitle = Len(OFN.sFileTitle)
        .sInitialDir = InitDir & vbNullChar & vbNullChar
        .sDialogTitle = DialogTitle
        .Flags = Flags
    End With
    l = GetOpenFileName(OFN)

    Select Case l

        Case 1
            FileName = TrimNull(OFN.sFile)     'Path and File
            FileTitle = TrimNull(OFN.sFileTitle)  'File Only

        Case Else
            ' Extended error:
            HandleDlgError CommDlgExtendedError()
    End Select
End Sub

Public Sub ShowColor() 'Displays the CommonDialog control's Color dialog box.
Attribute ShowColor.VB_Description = "Displays the Color dialog box."
    piAction = 3
    Dim chclr As CHOOSECOLORS, l As Long
    chclr.lStructSize = Len(chclr)
    ' Color must get reference variable to receive result
    ' Flags can get reference variable or constant with bit flags
    ' Owner can take handle of owning window
    chclr.hWndOwner = 0&
    ' Assign color (default uninitialized value of zero is good default)
    chclr.rgbResult = Color
    ' Pass in flags
    chclr.Flags = Flags
    ' If first time, initialize custom colors to white

    If Not fNotFirst Then InitColors
    chclr.lpCustColors = VarPtr(alCustom(0))
    ' All other fields zero
    l = ChooseColor(chclr)

    Select Case l

        Case 1
            ' Success
            Color = chclr.rgbResult

        Case Else
            ' Extended error:
            HandleDlgError CommDlgExtendedError()
    End Select
End Sub

Public Sub ShowPrinter()   'Displays the CommonDialog control's Printer dialog box.
Attribute ShowPrinter.VB_Description = "Displays the Printer dialog box."
    piAction = 5
    Dim l As Long
    ' Fill in PRINTDLG structure
    Dim pd As TPRINTDLG
    pd.lStructSize = Len(pd)
    pd.hWndOwner = 0&
    pd.Flags = Flags
    pd.nFromPage = FromPage
    pd.nToPage = ToPage
    pd.nMinPage = Min
    pd.nMaxPage = IIf(Max = 0, &HFFFF, Max)
    pd.nCopies = Copies
    ' Show Print dialog
    l = PrintDlg(pd)

    Select Case l

        Case 1
            ' Return dialog values in parameters
            FromPage = pd.nFromPage
            ToPage = pd.nToPage
            ' Get DEVMODE structure from PRINTDLG
            Dim pDevMode As Long
            pDevMode = GlobalLock(pd.hDevMode)
            CopyMemory m_dvmode, ByVal pDevMode, Len(m_dvmode)
            Call GlobalUnlock(pd.hDevMode)
            ' Get Copies and Collate settings from DEVMODE structure
            Copies = m_dvmode.dmCopies
            Orientation = m_dvmode.dmOrientation
            ' Set default printer properties
            On Error Resume Next

            If (Not (Printer Is Nothing)) And PrinterDefault 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 Else
            ' Extended error:
            HandleDlgError CommDlgExtendedError()
    End Select
End Sub

Public Sub ShowFont() 'Displays the CommonDialog control's Font dialog box
Attribute ShowFont.VB_Description = "Displays the Font dialog box."
    piAction = 4
    Dim l As Long, PrinterDC As Long
    ' Flags can get reference variable or constant with bit flags
    ' PrinterDC can take printer DC
    PrinterDC = 0

    If Flags And cdlCFPrinterFonts Then PrinterDC = Printer.hdc
    ' Color can take initial color, receive chosen color

    If Color <> vbBlack Then Flags = Flags Or cdlCFEffects
    ' MinSize can be minimum size accepted

    If Min Then Flags = Flags Or cdlCFLimitSize
    ' MaxSize can be maximum size accepted

    If Max Then Flags = Flags Or cdlCFLimitSize
    ' Initialize LOGFONT variable
    Dim fnt As LOGFONT
    Const PointsPerTwip = 1440 / 72
    fnt.lfHeight = -(FontSize * (PointsPerTwip / Screen.TwipsPerPixelY))
    fnt.lfWeight = 400
    fnt.lfItalic = FontItalic
    fnt.lfUnderline = FontUnderLine
    fnt.lfStrikeOut = FontStrikeThru
    ' Other fields zero
    StrToBytes fnt.lfFaceName, FontName
    ' Initialize TCHOOSEFONT variable
    Dim cf As TCHOOSEFONT
    cf.lStructSize = Len(cf)
    cf.hWndOwner = 0
    cf.hdc = PrinterDC
    cf.lpLogFont = VarPtr(fnt)
    cf.iPointSize = FontSize * 10
    cf.Flags = Flags
    cf.rgbColors = Color
    cf.nSizeMin = Min
    cf.nSizeMax = Max
    ' All other fields zero
    l = ChooseFont(cf)

    Select Case l

        Case 1
            ' Success
            Flags = cf.Flags
            Color = cf.rgbColors
            FontBold = cf.nFontType And Bold_FontType
            FontItalic = fnt.lfItalic
            FontStrikeThru = fnt.lfStrikeOut
            FontUnderLine = fnt.lfUnderline
            FontSize = cf.iPointSize / 10
            FontName = BytesToStr(fnt.lfFaceName)

        Case Else
            ' Extended error
            HandleDlgError CommDlgExtendedError()
    End Select
End Sub
'---------------------------------------------
'Utility functions

Private Function TrimNull(item As String) As String
    Dim pos As Integer
    pos = InStr(item, Chr$(0))

    If pos Then
        TrimNull = Left$(item, pos - 1)
        Else: TrimNull = item
    End If
End Function

Private Sub InitColors()
    Dim i As Integer
    ' Initialize with white

    For i = 0 To 15
        alCustom(i) = vbWhite
    Next
    fNotFirst = True
End Sub

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)
        CopyMemoryStr ab(LBound(ab)), s, cab
    End If
End Sub

Private Function BytesToStr(ab() As Byte) As String
    BytesToStr = StrConv(ab, vbUnicode)
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

Private Sub HandleDlgError(errCode As Long)
    Dim sDesc As String

    Select Case errCode

        Case cdlAlloc
            sDesc = "Couldn't allocate memory for FileName or Filter property"

        Case cdlCancel, 0

            If CancelError Then
                errCode = cdlCancel
                sDesc = "Cancel was selected"

            Else
                errCode = 0
            End If

        Case cdlDialogFailure
            sDesc = "The function failed to load the dialog box"

        Case cdlFindResFailure
            sDesc = "The function failed to load a specified resource"

        Case cdlHelp
            sDesc = "Call to Windows Help failed"

        Case cdlInitialization
            sDesc = "The function failed during initialization"

        Case cdlLoadResFailure, cdlLoadStrFailure
            sDesc = "The function failed to load a specified string"

        Case cdlLockResFailure
            sDesc = "The function failed to lock a specified resource"

        Case cdlMemAllocFailure
            sDesc = "The function was unable to allocate memory for internal data structures"

        Case cdlMemLockFailure
            sDesc = "The function was unable to lock the memory associated with a handle"

        Case cdlNoFonts
            sDesc = "No fonts exist"

        Case cdlBufferTooSmall
            sDesc = "The buffer at which the member lpstrFile points is too small"

        Case cdlInvalidFileName
            sDesc = "Filename is invalid"

        Case cdlSubclassFailure
            sDesc = "An attempt to subclass a list box failed due to insufficient memory"

        Case cdlCreateICFailure
            sDesc = "The PrintDlg function failed when it attempted to create an information context"

        Case cdlDndmMismatch
            sDesc = "Data in the DevMode and DevNames data structures describe two different printers"

        Case cdlGetDevModeFail
            sDesc = "The printer device driver failed to initialize a DevMode data structure"

        Case cdlInitFailure
            sDesc = "The PrintDlg function failed during initialization"

        Case cdlLoadDrvFailure
            sDesc = "The PrintDlg function failed to load the specified printer's device driver"

        Case cdlNoDefaultPrn
            sDesc = "A default printer doesn't exist"

        Case cdlNoDevices
            sDesc = "No printer device drivers were found"

        Case cdlParseFailure
            sDesc = "The CommonDialog function failed to parse the strings in the [devices] section of registry"

        Case cdlPrinterCodes
            sDesc = "The PDReturnDefault flag was set, but either the hDevMode or hDevNames field was nonzero"

        Case cdlPrinterNotFound
            sDesc = "The [devices] section of the registry doesn't contain an entry for the requested printer"

        Case cdlRetDefFailure
            sDesc = "The PDReturnDefault flag was set, but either the hDevMode or hDevNames field was nonzero"

        Case cdlSetupFailure
            sDesc = "Failed to load required resources"

        Case Else
            Err.Raise errCode, "CommonDialog"
            Exit Sub
    End Select

    If errCode <> 0 Then Err.Raise errCode, "CommonDialog", sDesc, "cmdlg98.chm", errCode
End Sub