mjwpdf.cls

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

        boPDFBold = False
        
        PDFFontName = str_TmpFontName
        PDFFontNum = FontNum
        PDFFontSize = in_FontSize

        FontNum = FontNum + 1
        
        Exit Sub
    End If
    
    Select Case str_Fontname
        Case FONT_ARIAL
           str_TmpFontNm = "Arial"
        Case FONT_COURIER
            str_TmpFontNm = "Courier"
        Case FONT_TIMES
            str_TmpFontNm = "Times"
        Case FONT_SYMBOL
            str_TmpFontNm = "Symbol"
        Case FONT_ZAPFDINGBATS
            str_TmpFontNm = "ZapfDingbats"
    End Select

    If str_TmpFontNm = "Arial" Then
        str_TmpFontName = "Helvetica"
    Else
        str_TmpFontName = str_TmpFontNm
    End If

    boPDFItalic = False
    boPDFBold = False

    str_TmpFont = str_TmpFontName
    
    If InStr(1, str_Style, FONT_ITALIC) <> 0 Then boPDFItalic = True
    If InStr(1, str_Style, FONT_BOLD) <> 0 Then boPDFBold = True
    If InStr(1, str_Style, FONT_UNDERLINE) <> 0 Then boPDFUnderline = True
    
    If boPDFItalic = True And boPDFBold = False Then
        Select Case str_TmpFontName
            Case "Times"
                str_TmpFontName = "TimesItalic"
            Case Else
                str_TmpFontName = str_TmpFontName & "-Oblique"
        End Select
    End If

    If boPDFItalic = True And boPDFBold = True Then
        Select Case str_TmpFontName
            Case "Times"
                str_TmpFontName = str_TmpFontName & "-BoldItalic"
            Case Else
                str_TmpFontName = str_TmpFontName & "-BoldOblique"
        End Select
    End If

    If boPDFItalic = False And boPDFBold = True Then
        str_TmpFontName = str_TmpFontName & "-Bold"
    End If
    
    If boPDFItalic = False And boPDFBold = False Then
        Select Case str_TmpFontName
            Case "Times"
                str_TmpFontName = str_TmpFontName & "-Roman"
            Case Else
                str_TmpFontName = str_TmpFontName
        End Select
    End If

    PDFFontName = str_TmpFontName
    PDFFontNum = FontNum
    PDFFontSize = in_FontSize

    FontNum = FontNum + 1

End Sub
Public Sub PDFDrawEllipse(x As Double, y As Double, rx As Double, Optional ry As Double = 0, Optional URLLink As String = "")
Attribute PDFDrawEllipse.VB_HelpID = 2056

Dim sTempDrawMode As String

    If ry = 0 Then ry = rx
    
    Select Case PDFDrawMode
        Case "D"
            PDFOutStream sTempStream, PDFDrawColor
            sTempDrawMode = "h f"
        Case "DB"
            PDFOutStream sTempStream, PDFDrawColor
            PDFOutStream sTempStream, PDFLineColor
            sTempDrawMode = "B"
        Case ""
            PDFOutStream sTempStream, PDFLineColor
            sTempDrawMode = "s"
    End Select

    PDFOutStream sTempStream, PDFLnStyle
        PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + ry / 2) * in_Ech) & " m"
            PDFOutStream sTempStream, PDFCurve(x * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry / 2 - ry / 2 * 11 / 20) * in_Ech, _
                (x + rx / 2 - rx / 2 * 11 / 20) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - y * in_Ech, _
                (x + rx / 2) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - y * in_Ech)
            PDFOutStream sTempStream, PDFCurve((x + rx / 2 + rx / 2 * 11 / 20) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - y * in_Ech, _
                (x + rx) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry / 2 - ry / 2 * 11 / 20) * in_Ech, _
                (x + rx) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry / 2) * in_Ech)
            PDFOutStream sTempStream, PDFCurve((x + rx) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry / 2 + ry / 2 * 11 / 20) * in_Ech, _
                (x + rx / 2 + rx / 2 * 11 / 20) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry) * in_Ech, _
                (x + rx / 2) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry) * in_Ech)
            PDFOutStream sTempStream, PDFCurve((x + rx / 2 - rx / 2 * 11 / 20) * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry) * in_Ech, _
                x * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry / 2 + ry / 2 * 11 / 20) * in_Ech, _
                x * in_Ech, _
                PDFCanvasHeight(in_Canvas) - (y + ry / 2) * in_Ech)
    PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w " & sTempDrawMode

    PDFSetTextColor = vbWhite
    strTLink = "LINK"
    strTyLink = "ELLIPSE"
    PDFSetLink URLLink, "ELLIPSE", Int((x - rx / 2)), Int((y + ry / 2 - ry / 2 * 11 / 20))
    strTyLink = ""
    
    in_xCurrent = x
    in_yCurrent = y + ry / 2

End Sub
Private Function PDFCurve(x1, y1, x2, y2, x3, y3 As Double) As String
Attribute PDFCurve.VB_HelpID = 2057

  PDFCurve = PDFFormatDouble(x1) & " " & _
             PDFFormatDouble(y1) & " " & _
             PDFFormatDouble(x2) & " " & _
             PDFFormatDouble(y2) & " " & _
             PDFFormatDouble(x3) & " " & _
             PDFFormatDouble(y3) & " c"

End Function
Public Sub PDFDrawPolygon(ParamArray pParam() As Variant)

Dim sTempDrawMode As String
Dim nbP           As Double
Dim in_i          As Integer

    nbP = (UBound(pParam(0), 1) + 1) / 2
        
    Select Case PDFDrawMode
        Case "D"
            PDFOutStream sTempStream, PDFDrawColor
            sTempDrawMode = "h f"
        Case "DB"
            PDFOutStream sTempStream, PDFDrawColor
            PDFOutStream sTempStream, PDFLineColor
            sTempDrawMode = "B"
        Case ""
            PDFOutStream sTempStream, PDFLineColor
            sTempDrawMode = "s"
    End Select

    PDFOutStream sTempStream, "%DEBUT_POLY/%"
    PDFOutStream sTempStream, PDFLnStyle
    PDFPoint CDbl(pParam(0)(0)), CDbl(pParam(0)(1))
    For in_i = 2 To nbP * 2 - 1
        If in_i Mod 2 = 0 Then
            PDFLine CDbl(pParam(0)(in_i)), CDbl(pParam(0)(in_i + 1))
        End If
    Next in_i
    
    PDFLine CDbl(pParam(0)(0)), CDbl(pParam(0)(1))
    PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w " & sTempDrawMode
    PDFOutStream sTempStream, "%FIN_POLY/%"
    
End Sub
Private Function PDFPoint(x As Double, y As Double)

    PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & _
                              PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m"

End Function
Private Function PDFLine(x As Double, y As Double)

    PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & _
                              PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " l"
End Function
Public Sub PDFDrawLineHor(x As Double, y As Double, w As Double)
Attribute PDFDrawLineHor.VB_HelpID = 2059

    If Right(PDFLineColor, 2) = "RG" Then
        PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 2) & "rg"
    Else
        PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 1) & "g"
    End If

    PDFOutStream sTempStream, "%DEBUT_LNH/%"
    PDFOutStream sTempStream, PDFLnStyle
    PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m"
    PDFOutStream sTempStream, PDFFormatDouble((x + w) * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " l"
    PDFOutStream sTempStream, PDFLineColor
    PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S"
    PDFOutStream sTempStream, "%FIN_LNH/%"
    
    in_xCurrent = x + w
    in_yCurrent = y

End Sub
Public Sub PDFDrawLineVer(x As Double, y As Double, h As Double)
Attribute PDFDrawLineVer.VB_HelpID = 2060

    If Right(PDFLineColor, 2) = "RG" Then
        PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 2) & "rg"
    Else
        PDFDrawColor = Left(PDFLineColor, Len(PDFLineColor) - 1) & "g"
    End If
    
    PDFOutStream sTempStream, "%DEBUT_LNV/%"
    PDFOutStream sTempStream, PDFLnStyle
    PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " m"
    PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - (y + h) * in_Ech) & " l"
    PDFOutStream sTempStream, PDFLineColor
    PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S"
    PDFOutStream sTempStream, "%FIN_LNV/%"
    
    in_xCurrent = x
    in_yCurrent = y + h

End Sub
Public Sub PDFDrawLine(x1 As Double, y1 As Double, x2 As Double, y2 As Double)
Attribute PDFDrawLine.VB_HelpID = 2061

    PDFOutStream sTempStream, "%DEBUT_LN/%"
    PDFOutStream sTempStream, PDFLnStyle
    PDFOutStream sTempStream, PDFFormatDouble(x1 * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y1 * in_Ech) & " m"
    PDFOutStream sTempStream, PDFFormatDouble(x2 * in_Ech) & " " & PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y2 * in_Ech) & " l"
    PDFOutStream sTempStream, PDFLineColor
    PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S"
    PDFOutStream sTempStream, "%FIN_LN/%"
    
    If x1 > x2 Then
        in_xCurrent = x1
    Else
        in_xCurrent = x2
    End If

    If y1 > y2 Then
        in_yCurrent = y1
    Else
        in_yCurrent = y2
    End If


End Sub
Public Sub PDFDrawRectangle(x As Double, y As Double, w As Double, h As Double, Optional URLLink As String = "")

Dim sTempDrawMode As String
        
    PDFOutStream sTempStream, "%DEBUT_RECT/%"
    Select Case PDFDrawMode
        Case "D"
            PDFOutStream sTempStream, PDFDrawColor
            sTempDrawMode = "f"
        Case "DB"
            PDFOutStream sTempStream, PDFDrawColor
            PDFOutStream sTempStream, PDFLineColor
            sTempDrawMode = "B"
        Case ""
            PDFOutStream sTempStream, PDFLineColor
            sTempDrawMode = "s"
    End Select
    
    PDFOutStream sTempStream, PDFLnStyle
    PDFOutStream sTempStream, PDFFormatDouble(x * in_Ech) & " " & _
                              PDFFormatDouble(PDFCanvasHeight(in_Canvas) - y * in_Ech) & " " & _
                              PDFFormatDouble(w * in_Ech) & " " & _
                              PDFFormatDouble(-1 * h * in_Ech) & " re " & sTempDrawMode
    PDFOutStream sTempStream, PDFFormatDouble(PDFLnWidth * in_Ech) & " w S"

    PDFSetTextColor = vbWhite
    
    strTLink = "LINK"
    strTyLink = "RECTANGLE"
    wRect = w
    PDFSetLink URLLink, "RECTANGLE", Int(x + 5), Int(y + h / 2)
    PDFOutStream sTempStream, "%FIN_RECT/%"

    strTyLink = ""
    
    in_xCurrent = x
    in_yCurrent = y + h
    
End Sub
Private Function PDFHtml2RgbColor(sColor As String) As PDFRGB

Dim sTmpColor As String

    sTmpColor = Right("000000" & sColor, 6)
    PDFHtml2RgbColor.in_r = CByte("&h" & Mid(sTmpColor, 1, 2))
    PDFHtml2RgbColor.in_g = CByte("&h" & Mid(sTmpColor, 3, 2))
    PDFHtml2RgbColor.in_b = CByte("&h" & Mid(sTmpColor, 5, 2))

End Function
Property Let PDFSetTextColor(gColor As Variant)
Attribute PDFSetTextColor.VB_HelpID = 2063

Dim TxtCl     As PDFRGB
Dim sColor    As String

    Select Case TypeName(gColor)
        Case "Variant()"
            TxtCl.in_r = gColor(0)
            TxtCl.in_g = gColor(1)
            TxtCl.in_b = gColor(2)
        Case "String"
           If Left(gColor, 1) <> "#" Then
                MsgBox "Invalid HTMl color set" & gColor & "." & _
                       vbNewLine & _
                       "Set color to  black.", vbCritical, "Text Color " & mjwPDFVersion
                TxtCl = PDFGetRGB(vbBlack)
            Else
                TxtCl = PDFHtml2RgbColor(CStr(gColor))
            End If
        Case Else
            TxtCl = PDFGetRGB(Int(gColor))
    End Select

    PDFTextColor = PDFStreamColor(TxtCl, "TEXT")

End Property
Property Get PDFGetTextColor() As String
Attribute PDFGetTextColor.VB_HelpID = 2064

    PDFGetTextColor = PDFstrTextColor

End Property
Property Let PDFSetLineColor(gColor As Variant)
Attribute PDFSetLineColor.VB_HelpID = 2065

Dim TxtCl     As PDFRGB
Dim sColor    As String

    Select Case TypeName(gColor)
        Case "Variant()"
            TxtCl.in_r = gColor(0)
            TxtCl.in_g = gColor(1)
            TxtCl.in_b = gColor(2)
        Case "String"
           If Left(gColor, 1) <> "#" Then
                MsgBox "Invalid line color set " & gColor & "." & _
                       vbNewLine & _
                       "Setting line color to black.", vbCritical, "Line Color - " & mjwPDFVersion
                TxtCl = PDFGetRGB(vbBlack)
            Else
                TxtCl = PDFHtml2RgbColor(CStr(gColor))
            End If
        Case Else
            TxtCl = PDFGetRGB(Int(gColor))
    End Select

    PDFLineColor = PDFStreamColor(TxtCl, "LINE")

End Property
Property Get PDFGetLineColor() As String
Attribute PDFGetLineColor.VB_HelpID = 2066

    PDFGetLineColor = PDFstrLineColor

End Property
Property Let PDFSetDrawColor(gColor As Variant)
Attribute PDFSetDrawColor.VB_HelpID = 2067

Dim TxtCl     As PDFRGB
Dim sColor    As String

    Select Case TypeName(gColor)
        Case "Variant()"
            TxtCl.in_r = gColor(0)
            TxtCl.in_g = gColor(1)
            TxtCl.in_b = gColor(2)
        Case "String"
           If Left(gColor, 1) <> "#" Then
                MsgBox "Invalid Draw Color set " & gColor & "." & _
                       vbNewLine & _
                       "Using black.", vbCritical, "Draw Color - " & mjwPDFVersion
                TxtCl = PDFGetRGB(vbBlack)
            Else
                TxtCl = PDFHtml2RgbColor(CStr(gColor))
            End If
        Case Else
            TxtCl = PDFGetRGB(Int(gColor))
    End Select
    
    PDFDrawColor = PDFStreamColor(TxtCl, "BORDER")

End Property
Property Get PDFGetDrawColor() As String
Attribute PDFGetDrawColor.VB_HelpID = 2068