mjwpdf.cls

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

        If in_i <> 0 Then iNbCar = iNbCar + 1
    Loop
    
    PDFGetNumberOfCar = iNbCar
    
End Function
Private Sub PDFCell2(str_Text As String, x As Double, y As Double, w As Double, h As Double, Optional URLLink As String = "")
Attribute PDFCell2.VB_HelpID = 2073

Dim j               As Integer
Dim dx              As Integer
Dim ltmp            As Integer

Dim in_PositionFont As Integer
Dim str_Tmp         As String
Dim str_TmpSTR      As String
Dim str_TmpText     As String

Dim in_Px           As Integer
Dim in_Pw           As String
Dim in_Py           As String
Dim iWidthMax       As Double

Dim str_Tmp1        As String

    str_TmpText = Replace(str_Text, "\", "\\")
    str_TmpText = Replace(str_TmpText, "\\", "\\\\")
    str_TmpText = Replace(str_TmpText, "(", "\(")
    str_TmpText = Replace(str_TmpText, ")", "\)")

    str_Tmp1 = ""

    dx = 0
    'x = x + PDFcMargin

    If PDFFontName = "" Then
        in_PositionFont = 1
    Else
        For j = 0 To UBound(Arr_Font)
            If Arr_Font(j) = PDFFontName Then
                in_PositionFont = j + 1
                Exit For
            End If
        Next j
    End If

    If PDFFontSize = 0 Then PDFFontSize = 10
    If PDFLineColor <> "" Then PDFOutStream sTempStream, Trim(PDFLineColor)
    If PDFDrawColor <> "" Then PDFOutStream sTempStream, PDFDrawColor

    If PDFboTempFill = True Or PDFstrTempBorder = "1" Then
        If PDFboTempFill = True Then
            If PDFstrTempBorder = "1" Then
                str_Tmp = "B"
            Else
                str_Tmp = "f"
            End If
        Else
            str_Tmp = "S"
        End If
        
        str_TmpSTR = PDFFormatDouble(x * in_Ech) & " " & _
                     PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " " & _
                     PDFFormatDouble(w * in_Ech) & " " & _
                     PDFFormatDouble(-h * in_Ech) & " re " & str_Tmp & vbCr
    End If

    If PDFstrTempBorder <> "0" And PDFstrTempBorder <> "1" Then
        PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w"
    
        If InStr(1, PDFstrTempBorder, "L", 1) <> 0 Then _
            str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m " & PDFFormatDouble(x * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l S" & vbCr
        If InStr(1, PDFstrTempBorder, "T", 1) <> 0 Then _
            str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m " & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " l S " & vbCr
        If InStr(1, PDFstrTempBorder, "R", 1) <> 0 Then _
            str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m " & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l S " & vbCr
        If InStr(1, PDFstrTempBorder, "B", 1) <> 0 Then _
            str_TmpSTR = str_TmpSTR & PDFFormatDouble(x * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " m " & PDFFormatDouble(x * in_Ech + w * in_Ech) & " " & _
                         PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l S " & vbCr
    End If

    PDFstrTempBorder = "0"
    
    If PDFstrTempAlign = "" Then PDFstrTempAlign = "L"
    
    Select Case PDFstrTempAlign
        Case "R"
            ltmp = PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize)
            dx = w * in_Ech - PDFcMargin - Format(ltmp, "###0.00")
        Case "C"
            ltmp = PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize)
            dx = (w * in_Ech - ltmp) / 2
        Case "L"
            dx = 2 * PDFcMargin
        Case "FJ"
            iWidthMax = (w * in_Ech - (PDFGetNumberOfCar(str_Text, " ") + 1) * PDFcMargin)
            iWidthStr = (iWidthMax - PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize)) / IIf(PDFGetNumberOfCar(str_Text, " ") <> 0, PDFGetNumberOfCar(str_Text, " "), 1)
            PDFOutStream sTempStream, PDFFormatDouble(iWidthStr * in_Ech, 3) & " Tw"
            dx = 2 * PDFcMargin
    End Select

    If str_TmpSTR <> "" Then PDFOutStream sTempStream, str_TmpSTR

    If URLLink <> "" Then
        boPDFUnderline = True
        PDFTabLinks (x + dx), _
                (y + 0.5 * h - 0.5 * PDFFontSize), _
                PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize), _
                CDbl(PDFFontSize), _
                str_Text, URLLink
    End If

    If boPDFUnderline Then str_Tmp1 = PDFUnderline(True, str_Text, CDbl((x * in_Ech + dx)), _
                                                PDFCanvasHeight(in_Canvas) - (y * in_Ech + 0.5 * h * in_Ech + 0.3 * PDFFontSize))

    If PDFTextColor <> "" Then
        PDFOutStream sTempStream, "q " & PDFTextColor & " "
        If boPDFUnderline = True Then
            PDFOutStream sTempStream, str_Tmp1
        End If
    End If

    xlink = 0
    xlink = x

    yLink = 0
    yLink = y
    
    PDFOutStream sTempStream, "BT"
    PDFOutStream sTempStream, "/F" & in_PositionFont & " " & PDFFontSize & " Tf"
    PDFOutStream sTempStream, PDFFormatDouble((x * in_Ech + dx)) & " " & _
                              PDFFormatDouble((PDFCanvasHeight(in_Canvas) - (y * in_Ech + 0.5 * h * in_Ech + 0.3 * PDFFontSize))) & _
                              " Td"
    PDFOutStream sTempStream, "(" & str_TmpText & ") Tj"

    If PDFTextColor <> "" Then
        PDFOutStream sTempStream, "ET"
        PDFOutStream sTempStream, "Q"
    Else
        PDFOutStream sTempStream, "ET"
    End If
    
    strTLink = str_Text
    strTyLink = "CELL"
    
    PDFSetLink URLLink, "CELL", xlink, yLink
    strTyLink = ""
    
    in_xCurrent = x + w
    in_yCurrent = y + h

End Sub
Private Sub PDFSetLink(URLLink As String, OType As String, x As Double, y As Double)
Attribute PDFSetLink.VB_HelpID = 2074

    If TypeName(URLLink) = "String" Then
        If OType = "IMAGE" Then
            PDFboImage = True
        Else
            PDFboImage = False
        End If

        If URLLink <> "" Then PDFLink x, y, URLLink
        strTLink = ""
        PDFboImage = False
    Else
        Select Case OType
            Case "CELL"
                MsgBox "Invalid URL link : " & URLLink & "." & _
                        vbNewLine & _
                        "Unable to include link.", vbCritical, "Url Link - " & mjwPDFVersion
            Case "IMAGE"
                MsgBox "Invalid URL image object: " & URLLink & "." & _
                        vbNewLine & _
                        "Unable to include URL image.", vbCritical, "Url Link Image - " & mjwPDFVersion
            Case "RECT"
                MsgBox "Invalid URL rectangle: " & URLLink & "." & _
                        vbNewLine & _
                        "Unable to include URL rectangle.", vbCritical, "Url Link Rectangle - " & mjwPDFVersion
            Case "ELLIPSE"
                MsgBox "Invalid URL Ellipse : " & URLLink & "." & _
                        vbNewLine & _
                        "Unable ot include URL Ellipse.", vbCritical, "Url Link Ellipse - " & mjwPDFVersion
        End Select
    End If

End Sub
Public Function PDFImageWidth(pFileName As String) As Double

Dim ArrInfo  As Variant
Dim in_pos   As Integer

    in_pos = InStr(1, pFileName, ".", 1)

    If in_pos = 0 Then
        MsgBox "File " & pFileName & " does not have an extension" & _
                vbNewLine & _
                "Invalid filename specified.", vbCritical, "Image File - " & mjwPDFVersion
        Exit Function
    End If

    If Right(pFileName, 3) = "jpg" Or Right(pFileName, 4) = "jpeg" Then
        ArrInfo = PDFParseJPG(pFileName)
        If TypeName(ArrInfo) = "Boolean" Then
            If ArrInfo = False Then Exit Function
        End If
    Else
        MsgBox "Image format not supported." & _
                vbNewLine & _
                "Only JPEG images are supported." & _
                vbNewLine & _
                "Impossible to include image in PDF file.", vbCritical, "Image File - " & mjwPDFVersion
        Exit Function
    End If

    PDFImageWidth = ArrInfo(0)
    
End Function
Public Function PDFImageHeight(pFileName As String) As Double

Dim ArrInfo  As Variant
Dim in_pos   As Integer

    in_pos = InStr(1, pFileName, ".", 1)

    If in_pos = 0 Then
        MsgBox "File " & pFileName & " does not have an extension" & _
                vbNewLine & _
                "Invalid filename specified.", vbCritical, "Image File - " & mjwPDFVersion
        Exit Function
    End If

    If Right(pFileName, 3) = "jpg" Or Right(pFileName, 4) = "jpeg" Then
        ArrInfo = PDFParseJPG(pFileName)
        If TypeName(ArrInfo) = "Boolean" Then
            If ArrInfo = False Then Exit Function
        End If
    Else
        MsgBox "Image format not supported." & _
                vbNewLine & _
                "Only JPEG images are supported." & _
                vbNewLine & _
                "Impossible to include image in PDF file.", vbCritical, "Image File - " & mjwPDFVersion
        Exit Function
    End If

    PDFImageHeight = ArrInfo(1)
    
End Function
Public Sub PDFImage(pFileName As String, x As Double, y As Double, Optional w As Double = 0, Optional h As Double = 0, Optional URLLink As String = "")
Attribute PDFImage.VB_HelpID = 2075

Dim in_pos   As Integer
Dim ArrInfo  As Variant

    in_pos = InStr(1, pFileName, ".", 1)

    If in_pos = 0 Then
        MsgBox "File " & pFileName & " does not have an extension" & _
                vbNewLine & _
                "Invalid filename specified.", vbCritical, "Image File - " & mjwPDFVersion
        Exit Sub
    End If

    If Right(pFileName, 3) = "jpg" Or Right(pFileName, 4) = "jpeg" Then
        ArrInfo = PDFParseJPG(pFileName)
        If TypeName(ArrInfo) = "Boolean" Then
            If ArrInfo = False Then Exit Sub
        End If
    Else
        MsgBox "Image format not supported." & _
                vbNewLine & _
                "Only JPEG images are supported." & _
                vbNewLine & _
                "Impossible to include image in PDF file.", vbCritical, "Image File - " & mjwPDFVersion
        Exit Sub
    End If

    If w = 0 And h = 0 Then
        w = ArrInfo(0) / in_Ech
        h = ArrInfo(1) / in_Ech
    End If

    If w = 0 Then w = h * ArrInfo(0) / ArrInfo(1)
    If h = 0 Then h = w * ArrInfo(1) / ArrInfo(0)

    NumberofImages = NumberofImages + 1
       
    PDFOutStream sTempStream, "q"
        
    PDFOutStream sTempStream, PDFFormatDouble(w * in_Ech) & " 0 0 " & _
                              PDFFormatDouble(h * in_Ech) & " " & _
                              PDFFormatDouble(x * in_Ech) & " " & _
                              PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " cm /ImgJPEG" & _
                              NumberofImages & " Do Q"
    
    ImgWidth = w
    ImgHeight = h

    PDFSetLink URLLink, "IMAGE", x, y

    in_xCurrent = (x + w) * in_Ech
    in_yCurrent = (y + h) * in_Ech

End Sub
Private Function PDFParseJPG(pFileName As String) As Variant
Attribute PDFParseJPG.VB_HelpID = 2076

Const OPEN_EXISTING = 3
Const FILE_SHARE_READ = &H1
Const GENERIC_READ = &H80000000
Const FILE_BEGIN = 0

Dim in_File    As Long
Dim in_Bytes   As Long

Dim str_TChar  As String
Dim in_res     As Long

Dim sIMG       As Long
Dim inIMG

Dim in_PEnd     As Long
Dim in_idx      As Long
Dim str_SegmMk  As String
Dim in_SegmSz   As Long
Dim bChar       As Byte
Dim in_TmpColor As Long
Dim in_bpc      As Long

Dim ArrBFile()  As Byte

    ReDim Preserve ArrIMG(1 To NumberofImages + 1)

    ' Extract info from a JPEG file
    inIMG = FreeFile

    in_File = PDFCreateFile(pFileName, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
    sIMG = PDFGetFileSize(in_File, 0)

    If sIMG < 250 Then
        MsgBox "File Image is non JPEG" & _
                vbNewLine & _
                "Cannot add image to PDF file.", vbCritical, "File Image - " & mjwPDFVersion
        PDFParseJPG = False
        PDFCloseHandle in_File
        Exit Function
    End If

    ArrIMG(NumberofImages + 1).in_8 = sIMG

    ReDim Preserve ArrBFile(1 To 1, 1 To sIMG) As Byte
    in_res = PDFReadFile(in_File, ArrBFile(1, 1), sIMG, in_Bytes, ByVal 0&)

    in_PEnd = UBound(ArrBFile, 2) - 1

    If PDFIntAsHex(ArrBFile, 1) <> "FFD8" Or PDFIntAsHex(ArrBFile, in_PEnd) <> "FFD9" Then
        MsgBox "Invalid JPEG marker" & _
                vbNewLine & _
                "Cannot add iamge to PDF file.", vbCritical, "File Image - " & mjwPDFVersion
        PDFParseJPG = False
        PDFCloseHandle in_File
        Exit Function
    End If

    in_idx = 3
    Do While in_idx < in_PEnd
        str_SegmMk = PDFIntAsHex(ArrBFile, in_idx)
        in_SegmSz = PDFIntVal(ArrBFile, in_idx + 2)

        If str_SegmMk = "FFFF" Then
            Do While ArrBFile(1, in_idx + 1) = &HFF
                in_idx = in_idx + 1
            Loop
            in_SegmSz = PDFIntVal(ArrBFile, in_idx + 2)
        End If

        Select Case str_SegmMk
            Case "FFE0"
                bChar = ArrBFile(1, in_idx + 11)
                If bChar = 0 Then
                    ArrIMG(NumberofImages + 1).in_7 = "Dots"
                ElseIf bChar = 1 Then
                    ArrIMG(NumberofImages + 1).in_7 = "Dots/inch (DPI)"
                ElseIf bChar = 2 Then
                    ArrIMG(NumberofImages + 1).in_7 = "Dots/cm"
                Else
                    MsgBox "Invalid image resolution" & bChar & _
                            "Valid resolution is: 0, 1, 2." & _
                            vbNewLine & _
                            "Cannot add image to PDF file.", vbCritical, "File Image - " & mjwPDFVersion
                    PDFParseJPG = False