mjwpdf.cls

PDF生成原代码,本原代码解释了如何生成PDF文件!

Property Get PDFGetLayoutMode() As Variant
Attribute PDFGetLayoutMode.VB_HelpID = 2014

    PDFGetLayoutMode = PDFLayoutMode

End Property
Property Let PDFSetUnit(str_Unite As PDFUnitStr)
Attribute PDFSetUnit.VB_HelpID = 2015

    Select Case str_Unite
        Case UNIT_PT
            in_Ech = 1
        Case UNIT_MM
            in_Ech = 72 / 25.4
        Case UNIT_CM
            in_Ech = 72 / 2.54
        Case Else
            MsgBox "Incorrect Unit of Measure : " & str_Unite & "." & _
                   vbNewLine & _
                   "Using centimeter ", vbCritical, "Error in measurement unit - " & mjwPDFVersion
            in_Ech = 72 / 2.54
    End Select

End Property
Property Get PDFGetUnit() As String
Attribute PDFGetUnit.VB_HelpID = 2016

    Select Case in_Ech
        Case 1
            PDFGetUnit = "pt"
        Case 72 / 25.4
            PDFGetUnit = "mm"
        Case 72 / 2.54
            PDFGetUnit = "cm"
    End Select

End Property
Property Let PDFOrientation(str_Orientation As PDFOrientationStr)
Attribute PDFOrientation.VB_HelpID = 2017

Dim tmp_PDFCanvasWidth As Integer
Dim tmp_PDFCanvasHeight As Integer

    ReDim Preserve PDFCanvasWidth(1 To in_Canvas)
    ReDim Preserve PDFCanvasHeight(1 To in_Canvas)
    ReDim Preserve PDFCanvasOrientation(1 To in_Canvas)

    tmp_PDFCanvasWidth = PDFCanvasWidth(in_Canvas)
    tmp_PDFCanvasHeight = PDFCanvasHeight(in_Canvas)

    Select Case str_Orientation
        Case ORIENT_PORTRAIT
            PDFCanvasWidth(in_Canvas) = tmp_PDFCanvasWidth
            PDFCanvasHeight(in_Canvas) = tmp_PDFCanvasHeight
            PDFCanvasOrientation(in_Canvas) = "p"
        Case ORIENT_PAYSAGE
            PDFCanvasWidth(in_Canvas) = tmp_PDFCanvasHeight
            PDFCanvasHeight(in_Canvas) = tmp_PDFCanvasWidth
            PDFCanvasOrientation(in_Canvas) = "l"
        Case Else
            MsgBox "Orientation set incorrectly: " & str_Orientation & "." & _
                   vbNewLine & _
                   "Orientation set to portrait.", vbCritical, "Error in orientation - " & mjwPDFVersion
            PDFCanvasWidth(in_Canvas) = tmp_PDFCanvasWidth
            PDFCanvasHeight(in_Canvas) = tmp_PDFCanvasHeight
            PDFCanvasOrientation(in_Canvas) = "p"
    End Select

    ReDim Preserve PDFCanvasWidth(1 To in_Canvas)
    ReDim Preserve PDFCanvasHeight(1 To in_Canvas)
    ReDim Preserve PDFCanvasOrientation(1 To in_Canvas)

End Property
Property Let PDFFormatPage(str_FormatPage As Variant)
Attribute PDFFormatPage.VB_HelpID = 2018

    ReDim Preserve PDFCanvasWidth(1 To in_Canvas)
    ReDim Preserve PDFCanvasHeight(1 To in_Canvas)
    ReDim Preserve PDFCanvasOrientation(1 To in_Canvas)

    Select Case TypeName(str_FormatPage)
        Case "Long"
            Select Case str_FormatPage
                Case FORMAT_A4
                    PDFCanvasWidth(in_Canvas) = 595.28
                    PDFCanvasHeight(in_Canvas) = 841.89
                Case FORMAT_A3
                    PDFCanvasWidth(in_Canvas) = 841.89
                    PDFCanvasHeight(in_Canvas) = 1190.55
                Case FORMAT_A5
                    PDFCanvasWidth(in_Canvas) = 420.94
                    PDFCanvasHeight(in_Canvas) = 595.28
                Case FORMAT_LETTER
                    PDFCanvasWidth(in_Canvas) = 612
                    PDFCanvasHeight(in_Canvas) = 792
                Case FORMAT_LEGAL
                    PDFCanvasWidth(in_Canvas) = 612
                    PDFCanvasHeight(in_Canvas) = 1008
                Case Else
                    MsgBox "Format page set incorrectly : " & str_FormatPage & "." & _
                           vbNewLine & _
                           "Format page set to A4.", vbCritical, "Format Page - " & mjwPDFVersion
                    PDFCanvasWidth(in_Canvas) = 595.28
                    PDFCanvasHeight(in_Canvas) = 841.89
            End Select
        Case "Double()"
            PDFCanvasWidth(in_Canvas) = str_FormatPage(0)
            PDFCanvasHeight(in_Canvas) = str_FormatPage(1)
        Case Else
            MsgBox "Format page set incorrectly : " & str_FormatPage & "." & _
                   vbNewLine & _
                   "Format page set to A4", vbCritical, "Format Page - " & mjwPDFVersion
            PDFCanvasWidth(in_Canvas) = 595.28
            PDFCanvasHeight(in_Canvas) = 841.89
    End Select

End Property
Property Get PDFPageNumber() As Integer
Attribute PDFPageNumber.VB_HelpID = 2019

    PDFPageNumber = FPageNumber

End Property
Property Get PDFNbPage() As Integer
Attribute PDFNbPage.VB_HelpID = 2020

    PDFNbPage = UBound(PageNumberList)

End Property
Property Let PDFProducer(str_Producer As String)
Attribute PDFProducer.VB_HelpID = 2021

    FProducer = str_Producer

End Property
Property Let PDFSubject(str_Subject As String)
Attribute PDFSubject.VB_HelpID = 2022

    FSubject = str_Subject

End Property
Property Let PDFKeywords(str_Keywords As String)
Attribute PDFKeywords.VB_HelpID = 2023

    FKeywords = str_Keywords

End Property
Property Let PDFCreator(str_Creator As String)
Attribute PDFCreator.VB_HelpID = 2024

    FCreator = str_Creator

End Property
Property Let PDFAuthor(str_Author As String)
Attribute PDFAuthor.VB_HelpID = 2025

    FAuthor = str_Author

End Property
Property Let PDFTitle(str_Title As String)
Attribute PDFTitle.VB_HelpID = 2027

    FTitle = str_Title

End Property
Property Let PDFFileName(str_FileName As String)
Attribute PDFFileName.VB_HelpID = 2028

Dim Items()     As String
Dim sFilePath   As String
Dim sFileName   As String
Dim hWnd        As Long
Dim retval      As Long
Dim in_i        As Long

    On Error GoTo Err_File
    
    FFileName = str_FileName
    
    Items = Split(str_FileName, "\")
    If UBound(Items) = -1 Then Exit Property
    
    sFileName = Items(UBound(Items))
    sFilePath = Left(str_FileName, Len(str_FileName) - Len(Items(UBound(Items))))
    
    sPDFName = Fso.BuildPath(sFilePath, sFileName)
    Set Strm = Fso.CreateTextFile(sPDFName, True)
    
    Exit Property
    
Err_File:
    If Err = 70 Then
        hWnd = FindWindow(vbNullString, "Adobe Reader - [" & sFileName & "]")
        retval = PostMessage(hWnd, WM_CLOSE, 0&, 0&)
        Sleep 17

        Set Strm = Fso.CreateTextFile(sPDFName, True)
        Resume Next
    End If
    
End Property
Property Get PDFGetFileName() As String

    PDFGetFileName = FFileName
    
End Property
Property Let PDFConfirm(boConfirm As Boolean)
Attribute PDFConfirm.VB_HelpID = 2029

    boPDFConfirm = boConfirm

End Property
Property Let PDFView(boView As Boolean)

    boPDFView = boView
    
End Property
Property Let PDFPageHeight(in_PageHeight As Double)
Attribute PDFPageHeight.VB_HelpID = 2030

    PDFCanvasHeight(in_Canvas) = in_PageHeight

End Property
Property Get PDFGetPageHeight() As Double
Attribute PDFGetPageHeight.VB_HelpID = 2031

    PDFGetPageHeight = PDFCanvasHeight(in_Canvas)

End Property
Property Let PDFPageWidth(in_PageWidth As Double)
Attribute PDFPageWidth.VB_HelpID = 2032

    PDFCanvasWidth(in_Canvas) = in_PageWidth

End Property
Property Get PDFGetPageWidth() As Double
Attribute PDFGetPageWidth.VB_HelpID = 2033

    PDFGetPageWidth = PDFCanvasWidth(in_Canvas)

End Property
Property Let PDFSetLeftMargin(in_left As Double)
Attribute PDFSetLeftMargin.VB_HelpID = 2034

    PDFlMargin = in_left

End Property
Property Get PDFGetLeftMargin() As Double
Attribute PDFGetLeftMargin.VB_HelpID = 2035

    PDFGetLeftMargin = PDFlMargin

End Property
Property Let PDFSetRightMargin(in_right As Double)
Attribute PDFSetRightMargin.VB_HelpID = 2036

    PDFrMargin = in_right

End Property
Property Get PDFGetRightMargin() As Double
Attribute PDFGetRightMargin.VB_HelpID = 2037

    PDFGetRightMargin = PDFrMargin

End Property
Property Let PDFSetTopMargin(in_top As Double)
Attribute PDFSetTopMargin.VB_HelpID = 2038

    PDFtMargin = in_top

End Property
Property Get PDFGetTopMargin() As Double
Attribute PDFGetTopMargin.VB_HelpID = 2039

    PDFGetTopMargin = PDFtMargin

End Property
Property Let PDFSetBottomMargin(in_bottom As Double)
Attribute PDFSetBottomMargin.VB_HelpID = 2040

    PDFbMargin = in_bottom

End Property
Property Get PDFGetBottomMargin() As Double
Attribute PDFGetBottomMargin.VB_HelpID = 2041

    PDFGetBottomMargin = PDFbMargin

End Property
Property Let PDFSetCellMargin(in_cell As Double)
Attribute PDFSetCellMargin.VB_HelpID = 2042

    PDFcMargin = in_cell

End Property
Property Get PDFGetCellMargin() As Double
Attribute PDFGetCellMargin.VB_HelpID = 2043

    PDFGetCellMargin = PDFcMargin

End Property
Public Sub PDFSetMargins(in_left As Integer, in_top As Integer, Optional in_right As Integer = -1, Optional in_bottom As Integer = -1)
Attribute PDFSetMargins.VB_HelpID = 2044

    PDFlMargin = in_left
    PDFtMargin = in_top

    If in_right = -1 Then in_right = in_left
    If in_bottom = -1 Then in_bottom = in_top

    PDFrMargin = in_right
    PDFbMargin = in_bottom

End Sub
Property Get PDFGetX() As Integer
Attribute PDFGetX.VB_HelpID = 2045

    PDFGetX = in_xCurrent

End Property
Property Get PDFGetY() As Integer
Attribute PDFGetY.VB_HelpID = 2046

    PDFGetY = in_yCurrent

End Property
Property Let PDFSetLineStyle(pLineStyle As PDFStyleLgn)
Attribute PDFSetLineStyle.VB_HelpID = 2047

    PDFLnStyle = PDFLineStyle(pLineStyle)

End Property
Property Let PDFSetLineWidth(pLineWidth As Double)
Attribute PDFSetLineWidth.VB_HelpID = 2048

    PDFLnWidth = pLineWidth
    
End Property
Property Let PDFSetDrawMode(pDrawMode As PDFDrawMd)
Attribute PDFSetDrawMode.VB_HelpID = 2049

Dim pTmpDrawMode As String

    pTmpDrawMode = LCase(pDrawMode)

    Select Case pTmpDrawMode
        Case DRAW_NORMAL
            PDFDrawMode = ""
        Case DRAW_DRAW
            PDFDrawMode = "D"
        Case DRAW_DRAWBORDER
            PDFDrawMode = "DB"
        Case Else
            MsgBox "Draw Mode set incorrectly : " & pDrawMode & "." & _
                    vbNewLine & _
                    "Draw mode set to normal", vbCritical, "Object Rectangle - " & mjwPDFVersion
            PDFDrawMode = ""
    End Select

End Property
Private Function PDFLineStyle(pLineStyle As PDFStyleLgn) As String
Attribute PDFLineStyle.VB_HelpID = 2050

Dim pTmpLineStyle As PDFStyleLgn

    PDFLineStyle = ""
    pTmpLineStyle = pLineStyle

    Select Case pTmpLineStyle
        Case pPDF_SOLID
            PDFLineStyle = "[] 0 d"
        Case pPDF_DASH
            PDFLineStyle = "[" & Int(16 * in_Ech) & " " & Int(8 * in_Ech) & " ] 0 d"
        Case pPDF_DASHDOT
            PDFLineStyle = "[" & Int(8 * in_Ech) & " " & Int(7 * in_Ech) & " " & _
                               Int(2 * in_Ech) & " " & Int(7 * in_Ech) & " ] 0 d"
        Case pPDF_DASHDOTDOT
            PDFLineStyle = "[" & Int(8 * in_Ech) & " " & Int(4 * in_Ech) & " " & _
                               Int(2 * in_Ech) & " " & Int(4 * in_Ech) & " " & _
                               Int(2 * in_Ech) & " " & Int(4 * in_Ech) & " ] 0 d"
        Case Else
            MsgBox "Line style set incorrectly : " & pLineStyle & "." & _
                   vbNewLine & _
                   "Line style set to solid.", vbCritical, "Line Style - " & mjwPDFVersion
            PDFLineStyle = "[] 0 d"
    End Select

End Function
Public Sub PDFSetFont(str_Fontname As PDFFontNme, in_FontSize As Integer, Optional str_Style As PDFFontStl)
Attribute PDFSetFont.VB_HelpID = 2051

Dim str_TmpFontName As String
Dim str_TmpFontNm   As String

    If str_Fontname <> FONT_ARIAL And _
       str_Fontname <> FONT_COURIER And _
       str_Fontname <> FONT_SYMBOL And _
       str_Fontname <> FONT_TIMES And _
       str_Fontname <> FONT_ZAPFDINGBATS Then
        MsgBox "Font name set incorrectly : " & str_Style & "." & _
                vbNewLine & _
                "Font set to Times New Roman.", vbCritical, "Font name - " & mjwPDFVersion
        str_TmpFontName = "TimesRoman"
        boPDFItalic = False