mjwpdf.cls

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

    PDFGetDrawColor = PDFstrDrawColor

End Property
Private Function PDFStreamColor(PDFRgbColor As PDFRGB, str_Type As String) As String
Attribute PDFStreamColor.VB_HelpID = 2069

Dim int_r        As Integer
Dim int_g        As Integer
Dim int_b        As Integer
Dim str_TxtColor As String

    int_r = PDFRgbColor.in_r
    int_g = PDFRgbColor.in_g
    int_b = PDFRgbColor.in_b

    Select Case str_Type
        Case "TEXT", "BORDER"
            str_TxtColor = Replace(Format(int_r / 255, "0.000"), ",", ".") & " " & _
                           Replace(Format(int_g / 255, "0.000"), ",", ".") & " " & _
                           Replace(Format(int_b / 255, "0.000"), ",", ".") & " rg"
        Case "LINE"
            str_TxtColor = Replace(Format(int_r / 255, "0.000"), ",", ".") & " " & _
                           Replace(Format(int_g / 255, "0.000"), ",", ".") & " " & _
                           Replace(Format(int_b / 255, "0.000"), ",", ".") & " RG"
    End Select

    PDFStreamColor = str_TxtColor

End Function
Property Let PDFSetAlignement(gAlignement As PDFAlignValue)

    Select Case gAlignement
        Case 2
            PDFstrTempAlign = "R"
        Case 0
            PDFstrTempAlign = "C"
        Case 1
            PDFstrTempAlign = "L"
        Case 3
            PDFstrTempAlign = "FJ"
        Case Else
            MsgBox "Invalid alignment set. : " & gAlignement & "." & _
                   vbNewLine & _
                   "Using left alignment.", vbCritical, "Alignment - " & mjwPDFVersion
            PDFstrTempAlign = "L"
    End Select

End Property
Property Get PDFGetAlignement() As String

Dim strTempAlign As String

    Select Case PDFstrTempAlign
        Case "C"
            strTempAlign = "Center"
        Case "R"
            strTempAlign = "Right"
        Case "L"
            strTempAlign = "Left"
        Case Else
            strTempAlign = "Left"
    End Select
    
    PDFGetAlignement = strTempAlign

End Property
Public Sub PDFLink(x As Double, y As Double, str_Text As String, Optional str_Link As String = "")
Attribute PDFLink.VB_HelpID = 2070

Dim w As Integer
Dim h As Integer

    pTempAngle = 0
    
    PDFOutStream sTempStream, "%DEBUT_LINK/%"
    
    boPDFUnderline = True
    
        If PDFboImage = True Then
            PDFSetTextColor = vbBlue
            w = Int(ImgWidth)
            h = Int(ImgHeight)
            PDFTextOut "", x, y
        Else
            Select Case strTyLink
                Case "ELLIPSE"
                    w = Int(PDFGetStringWidth(strTLink, PDFFontName, PDFFontSize))
                    h = Int(PDFFontSize)
                    PDFTextOut "", x, y
                Case "RECTANGLE"
                    w = wRect
                    h = Int(PDFFontSize)
                    PDFTextOut "", x, y
                Case "CELL"
                    w = Int(PDFGetStringWidth(strTLink, PDFFontName, PDFFontSize))
                    h = Int(PDFFontSize)
                    PDFTextOut "", x, y
                Case Else
                    w = Int(PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize))
                    h = Int(PDFFontSize)
                    PDFTextOut str_Text, x, y
            End Select
        End If

    PDFboImage = False
    boPDFUnderline = False
    
    strTyLink = ""
    If str_Link = "" Then str_Link = str_Text
    
    PDFTabLinks x, y, w, h, str_Text, str_Link

    PDFOutStream sTempStream, "%FIN_LINK/%"
    
End Sub
Private Sub PDFTabLinks(x As Double, y As Double, w As Integer, h As Integer, str_Text As String, Optional str_Link As Variant = 0)
Attribute PDFTabLinks.VB_HelpID = 2071

    FPageLink = FPageLink + 1
    ReDim Preserve LinksList(1 To FPageLink)
    LinksList(FPageLink) = Array(FPageNumber, y, str_Link)

    If str_Link <> 0 Then
        PageLinksList(FPageNumber, FPageLink) = Array(x * in_Ech, PDFCanvasHeight(in_Canvas) - y * in_Ech, w * in_Ech, h * in_Ech, str_Link)
    Else
        PageLinksList(FPageNumber, FPageLink) = Array(x * in_Ech, PDFCanvasHeight(in_Canvas) - y * in_Ech, w * in_Ech, h * in_Ech, str_Text)
    End If

    ReDim Preserve boPageLinksList(1 To FPageNumber)
    ReDim Preserve NbPageLinksList(1 To FPageNumber)

    boPageLinksList(FPageNumber) = True
    NbPageLinksList(FPageNumber) = FPageLink

End Sub
Property Get PDFTextHeight() As Double

    PDFTextHeight = PDFFontSize * in_Ech
    
End Property
Property Let PDFSetRotation(pAngle As Double)

    PDFAngle = -1 * pAngle

End Property
Private Sub PDFStreamRotate(pAngle As Double, x As Double, y As Double)

Dim dSin     As Double
Dim dCos     As Double
Dim CenterX  As Double
Dim CenterY  As Double

    If pAngle <> 0 Then
        pAngle = pAngle * 3.1416 / 180
        dCos = Cos(pAngle)
        dSin = Sin(pAngle)
        CenterX = x * in_Ech
        CenterY = PDFCanvasHeight(in_Canvas) - y * in_Ech
        
        PDFOutStream sTempStream, PDFFormatDouble(dCos, 5) & " " & _
                                  PDFFormatDouble(-1 * dSin, 5) & " " & _
                                  PDFFormatDouble(dSin, 5) & " " & _
                                  PDFFormatDouble(dCos, 5) & " " & _
                                  PDFFormatDouble(CenterX) & " " & _
                                  PDFFormatDouble(CenterY) & " Tm"
    End If
    
    bAngle = True
    
End Sub
Public Sub PDFTextOut(str_Text As String, Optional x As Double = 0, Optional y As Double = 0)
Attribute PDFTextOut.VB_HelpID = 2072

Dim j               As Integer
Dim in_PositionFont As Integer
Dim str_Tmp         As String
Dim str_TmpText     As String

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

    If x = 0 Then x = in_xCurrent
    If y = 0 Then y = in_yCurrent
    
    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 PDFTextColor <> "" Then PDFOutStream sTempStream, "q " & PDFTextColor & " "
    If boPDFUnderline Then str_Tmp = PDFUnderline(False, str_Text, CDbl(x * in_Ech), CDbl(y * in_Ech))
    
    PDFOutStream sTempStream, "%DEBUT_TEXT/%"
    PDFOutStream sTempStream, "BT"
    
    If PDFAngle = 0 Then
        PDFOutStream sTempStream, PDFFormatDouble((x + PDFlMargin) * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " Td"
    Else
        PDFStreamRotate PDFAngle, x, y
        PDFAngle = 0
    End If
    
    PDFOutStream sTempStream, "/F" & in_PositionFont & " " & PDFFormatDouble(PDFFontSize) & " Tf"
    PDFOutStream sTempStream, "(" & str_TmpText & ") Tj"
    
    If PDFTextColor <> "" Then
        PDFOutStream sTempStream, "ET"

        If boPDFUnderline = True Then
            PDFOutStream sTempStream, str_Tmp
        End If

        PDFOutStream sTempStream, "Q"
    Else
        PDFOutStream sTempStream, "ET"

        If boPDFUnderline = True Then
            PDFOutStream sTempStream, str_Tmp
        End If
    End If
    
    PDFOutStream sTempStream, "%FIN_TEXT/%"
    
    boPDFUnderline = False

    in_xCurrent = x + PDFGetStringWidth(str_Text, PDFFontName, PDFFontSize)
    in_yCurrent = y + PDFFontSize

End Sub
Property Let PDFSetBorder(gBorder As PDFBorderValue)

    PDFstrTempBorder = ""

    Select Case gBorder
        Case BORDER_ALL
            PDFstrTempBorder = "1"
        Case BORDER_NONE
            PDFstrTempBorder = "0"
        Case BORDER_TOP
            PDFstrTempBorder = "T"
        Case BORDER_BOTTOM
            PDFstrTempBorder = "B"
        Case BORDER_LEFT
            PDFstrTempBorder = "L"
        Case BORDER_RIGHT
            PDFstrTempBorder = "R"
        Case Else
            If InStr(1, gBorder, BORDER_LEFT, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "L"
            If InStr(1, gBorder, BORDER_RIGHT, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "R"
            If InStr(1, gBorder, BORDER_TOP, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "T"
            If InStr(1, gBorder, BORDER_BOTTOM, 1) <> 0 Then PDFstrTempBorder = PDFstrTempBorder & "B"
    End Select

End Property
Property Let PDFSetFill(bFill As Boolean)

    PDFboTempFill = bFill

End Property
Public Sub PDFCell(str_Text As String, x As Double, y As Double, w As Double, h As Double, Optional URLLink As String = "")
  
Dim WidthMax    As Double
Dim lText       As Integer
Dim sCar        As String
Dim tWidth      As Double
Dim tBorder     As String
Dim yPos        As Double
Dim bMulti      As Boolean
Dim bBorder1    As String
Dim bBorder2    As String
Dim iSep        As Integer
Dim I, j, l     As Integer
Dim nl          As Integer

    tWidth = w
    yPos = y
    
    WidthMax = (w - 2 * PDFcMargin) * 10 / PDFFontSize
    lText = Len(str_Text)
    
    If lText > 0 And Right(str_Text, lText - 1) = vbNewLine Then
        lText = lText - 1
    End If
 
    bBorder1 = ""
        
    tBorder = PDFstrTempBorder
    If PDFstrTempBorder = "LRTB" Or PDFstrTempBorder = 1 Then
        bBorder1 = "LRT"
        bBorder2 = "LR"
    Else
        bBorder2 = ""
        If InStr(1, PDFstrTempBorder, "L", 1) <> 0 Then bBorder2 = bBorder2 & BORDER_LEFT
        If InStr(1, PDFstrTempBorder, "R", 1) <> 0 Then bBorder2 = bBorder2 & BORDER_RIGHT
        bBorder1 = IIf(InStr(1, PDFstrTempBorder, "T", 1) <> 0, bBorder2 = bBorder2 & BORDER_TOP, bBorder2)
    End If
    
    iSep = -1
    I = 1
    j = 1
    l = 0

    nl = 1
    
    PDFOutStream sTempStream, "%DEBUT_CELL/%"
    
    While I <= lText
        sCar = Mid(str_Text, I, 1)
        
        If sCar = vbCrLf Then
            PDFstrTempBorder = bBorder1
            PDFCell2 Mid(str_Text, j, I - j), x, yPos, tWidth, h
            yPos = in_yCurrent
            
            bMulti = True
            
            I = I + 1
            
            iSep = -1
            j = I
            l = 0

            nl = nl + 1
            
            If nl = 2 Then bBorder1 = bBorder2
         End If
        
        If sCar = " " Then
            iSep = I
        End If
        
        l = l + PDFGetStringWidth(sCar, PDFFontName, PDFFontSize)
        
        If l > WidthMax Then
            If iSep = -1 Then
                If I = j Then I = I + 1
                
                PDFstrTempBorder = bBorder1
                PDFCell2 Mid(str_Text, j, I - j), x, yPos, tWidth, h
                yPos = in_yCurrent
                               
                bMulti = True
            Else
                PDFstrTempBorder = bBorder1
                PDFCell2 Mid(str_Text, j, iSep - j), x - PDFcMargin, yPos, tWidth, h
                yPos = in_yCurrent
            
                bMulti = True
                I = iSep + 1
            End If
            
            iSep = -1
            
            j = I
            l = 0
            
            nl = nl + 1
            
            If nl = 2 Then bBorder1 = bBorder2
        Else
            I = I + 1
        End If
    Wend
    
    If InStr(1, tBorder, "B", 1) <> 0 Or tBorder = 1 Then
        bBorder1 = bBorder1 & "B"
        PDFstrTempBorder = bBorder1
    End If
    
    yPos = IIf(bMulti, in_yCurrent, yPos)
    PDFCell2 Mid(str_Text, j, I - j), x - PDFcMargin, yPos, tWidth, h
    
    boPDFUnderline = False
    
    If PDFstrTempAlign = "FJ" Then
        PDFOutStream sTempStream, "0 Tw"
        iWidthStr = 0
    End If
    
    PDFOutStream sTempStream, "%FIN_CELL/%"
    
End Sub
Private Function PDFGetNumberOfCar(sText As String, sCar As String) As Integer

Dim iNbCar As Integer
Dim in_i   As Integer

    iNbCar = 0
    in_i = InStr(1, sText, sCar)
    If in_i <> 0 Then iNbCar = 1
    
    Do While in_i <> 0
        in_i = InStr(in_i + 1, sText, sCar)