用VB CLASS 写ＰＤＦ文件

Mephis

' ©2004/5 by Michael Reinold/Jost Schwider, http://vb-tec.de/pdf.htm
'---------'---------'---------'---------'---------'---------'---------
' clsPDF - Eine Klasse zur PDF-Generierung in purem VB
'
' 20050427 - RLE für DrawPicture (JS)
' 20050421 - Neue Methode: DrawPicture (JS)
' 20050419 - Neue Methoden: DrawShape, FillMode (JS)
' 20050416 - Neue Methode: DrawCircle (JS)
'            Neue Enum: pdfFillModes (JS)
' 20050414 - FormColor optimiert (JS)
' 20050411 - Neue Methode: DrawText, DrawLineTo, MoveTo (JS)
' 20050405 - Neue Methode: DrawBox (JS)
'          - Neue Eigenschaft: FillColor (JS)
' 20050331 - Neue Methode: DrawLine (JS)
'          - Neue Eigenschaft: DrawWidth, DrawColor (JS)
' 20050330 - Neue Ereignisse: PageStarted, PageFinished (JS)
'          - Neue Eigenschaften: PageNumber, LineNumber (JS)
' 20050324 - Neue Eigenschaften: LeftMargin, TopMargin (JS)
' 20050304 - Neue Eigenschaften: Height, Width, PaperSize, Orientation (JS)
' 20050213 - Erste Version (MR, JS)


'---------'---------'---------'---------'---------'---------'---------
'Deklarationen:


Option Explicit

Public Enum pdfFillModes
  pdfFill = -1   'Fläche ohne Umriss (früher: True)
  pdfStroke      'Linie (früher: False)
  pdfFillStroke  'Fläche mit Umriss
  pdfCloseStroke 'Linie (vorher schließen)
End Enum

Public Enum pdfOrientations
  pdfPortrait  'Hochkant
  pdfLandscape 'Querformat
End Enum

Public Enum pdfPaperSizes
  pdfUser 'Benutzerdefiniert
  pdfA0   'DIN ...
  pdfA1
  pdfA2
  pdfA3
  pdfA4
  pdfA5
  pdfA6
  pdfA7
End Enum

'Platzhalter für Eigenschaften:
Private pDrawColor As Long
Private pDrawWidth As Single
Private pDropBlankPages As Boolean
Private pFillColor As Long
Private pFillMode As pdfFillModes
Private pFontSize As Integer
Private pHeight As Integer
Private pLinesPerPage As Integer
Private pMarginLeft As Integer
Private pMarginTop As Integer
Private pNewPageString As String
Private pOrientation As pdfOrientations
Private pPaperSize As pdfPaperSizes
Private pWidth As Integer

'PDF-Struktur:
Private Page() As Long
Private PageCount As Long
Private XRef() As Long
Private XRefCount As Long

'Sonstiges:
Private Buffer As String
Private BufferPtr As Long
Private DrawBuffer As String
Private DrawBufferPtr As Long
Private FinalizedPtr As Long
Private IsFinalized As Boolean
Private LineCount As Integer
Private PageStart As Long
Private pDrawColorChanged As Boolean
Private pDrawWidthChanged As Boolean
Private pFillColorChanged As Boolean
Private pX As Integer
Private pY As Integer
Private pStroke As String

'Ereignisse:
Public Event PageFinished()
Public Event PageStarted()


'---------'---------'---------'---------'---------'---------'---------
'API-Deklarationen:


Private Type BITMAP
  bmType As Long
  bmWidth As Long
  bmHeight As Long
  bmWidthBytes As Long
  bmPlanes As Integer
  bmBitsPixel As Integer
  bmBits As Long
End Type

Private Declare Function GetObjectA Lib "gdi32" ( _
    ByVal hObject As Long, ByVal nCount As Long, _
    ByRef lpObject As Any) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" ( _
    ByVal hDC As Long) As Long
Private Declare Function SelectObject Lib "gdi32" ( _
    ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetPixel Lib "gdi32" ( _
    ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" ( _
    ByVal hDC As Long) As Long


'---------'---------'---------'---------'---------'---------'---------
'Klasse:


Private Sub Class_Initialize()

  'Default-Eigenschaften setzen:
  DropBlankPages = True
  FontSize = 10 'Points
  NewPageString = vbFormFeed
  PaperSize = pdfA4
  LinesPerPage = 72
  LeftMargin = 80
  TopMargin = 60
  FillMode = pdfStroke
  
  'PDF-Struktur vorbereiten:
  ReDim Page(1 To 16)
  ReDim XRef(1 To 64)
  
  'Stream' öffnen:
  Clear

End Sub


'---------'---------'---------'---------'---------'---------'---------
'Eigenschaften:


Property Get DrawColor() As Long
  DrawColor = pDrawColor
End Property

Property Let DrawColor(ByVal Value As Long)

  If pDrawColor <> Value Then
    pDrawColor = Value
    DrawStroke
    pDrawColorChanged = True
  End If

End Property


Property Get DrawWidth() As Single
  DrawWidth = pDrawWidth
End Property

Property Let DrawWidth(ByVal Value As Single)

  If pDrawWidth <> Value Then
    pDrawWidth = Value
    DrawStroke
    pDrawWidthChanged = True
  End If

End Property


Property Get DropBlankPages() As Boolean
  DropBlankPages = pDropBlankPages
End Property

Property Let DropBlankPages(ByVal Value As Boolean)
  pDropBlankPages = Value
End Property


Property Get FillColor() As Long
  FillColor = pFillColor
End Property

Property Let FillColor(ByVal Value As Long)

  If pFillColor <> Value Then
    pFillColor = Value
    DrawStroke
    pFillColorChanged = True
  End If

End Property


Property Get FillMode() As pdfFillModes
  FillMode = pFillMode
End Property

Property Let FillMode(ByVal Value As pdfFillModes)
  pFillMode = Value
  DrawStroke
  SetFillStroke pFillMode
End Property


Property Get FontSize() As Integer
  FontSize = pFontSize
End Property

Property Let FontSize(ByVal Value As Integer)
  pFontSize = Value
End Property


Property Get Height() As Integer
  If pOrientation = pdfPortrait Then
    Height = pHeight
  Else
    Height = pWidth
  End If
End Property

Property Let Height(ByVal Value As Integer)
  pHeight = Value
  pPaperSize = pdfUser
End Property


Property Get LeftMargin() As Integer
  LeftMargin = pMarginLeft
End Property

Property Let LeftMargin(ByVal Value As Integer)
  pMarginLeft = Value
End Property


Property Get LineNumber() As Long
  LineNumber = LineCount
End Property


Property Get LinesPerPage() As Integer
  LinesPerPage = pLinesPerPage
End Property

Property Let LinesPerPage(ByVal Value As Integer)
  pLinesPerPage = Value
End Property


Property Get NewPageString() As String
  NewPageString = pNewPageString
End Property

Property Let NewPageString(ByVal Value As String)
  pNewPageString = Value
End Property


Property Get PageNumber() As Long
  PageNumber = PageCount
End Property


Property Get Orientation() As pdfOrientations
  Orientation = pOrientation
End Property

Property Let Orientation(ByVal Value As pdfOrientations)
  pOrientation = Value
End Property


Property Get PaperSize() As pdfPaperSizes
  PaperSize = pPaperSize
End Property

Property Let PaperSize(ByVal Value As pdfPaperSizes)

  Const A0Width As Integer = 2384 'Points
  Const A0Height As Integer = 3371 'Points

  pPaperSize = Value
  Select Case pPaperSize
  Case pdfA0: pWidth = A0Width:       pHeight = A0Height
  Case pdfA1: pWidth = A0Height \ 2:  pHeight = A0Width
  Case pdfA2: pWidth = A0Width \ 2:   pHeight = A0Height \ 2
  Case pdfA3: pWidth = A0Height \ 4:  pHeight = A0Width \ 2
  Case pdfA4: pWidth = A0Width \ 4:   pHeight = A0Height \ 4
  Case pdfA5: pWidth = A0Height \ 8:  pHeight = A0Width \ 4
  Case pdfA6: pWidth = A0Width \ 8:   pHeight = A0Height \ 8
  Case pdfA7: pWidth = A0Height \ 16: pHeight = A0Width \ 8
  End Select

End Property


Property Get TopMargin() As Integer
  TopMargin = pMarginTop
End Property

Property Let TopMargin(ByVal Value As Integer)
  pMarginTop = Value
End Property


Property Get Width() As Integer
  If pOrientation = pdfPortrait Then
    Width = pWidth
  Else
    Width = pHeight
  End If
End Property

Property Let Width(ByVal Value As Integer)
  pWidth = Value
  pPaperSize = pdfUser
End Property



'---------'---------'---------'---------'---------'---------'---------
'&Ouml;ffentliche Methoden:


Public Sub Clear( _
    Optional ByVal FontSize As Integer, _
    Optional ByVal LinesPerPage As Integer)

  'Ggf. Page-Parameter übernehmen:
  If FontSize Then pFontSize = FontSize
  If LinesPerPage Then pLinesPerPage = LinesPerPage
  
  'PDF-Struktur leeren:
  PageCount = 0
  LineCount = 0
  XRefCount = 0
  
  'Stream' initialisieren:
  BufferPtr = 0
  DrawBufferPtr = 0
  StreamPDFHeader
  SetStroke ""

End Sub


Public Sub DrawBox( _
    ByVal x As Integer, ByVal y As Integer, _
    ByVal Width As Integer, ByVal Height As Integer, _
    Optional ByVal FillMode As pdfFillModes = pdfStroke)

  SetFillStroke FillMode
  If pOrientation = pdfPortrait Then
    y = pHeight - Height - y
  Else
    y = pWidth - Height - y
  End If
  StreamDrawing x & " " & y & " " & Width & " " & Height & " re"

End Sub


Public Sub DrawCircle( _
    ByVal x As Integer, ByVal y As Integer, ByVal r As Integer, _
    Optional ByVal FillMode As pdfFillModes = pdfStroke)

  'Mathematisch: cCircleBezierRatio = (Sqr(2) - 1) * 4 / 3
  Const cCircleBezierRatio As Single = 0.5522847
  Dim r2 As Integer

  r2 = cCircleBezierRatio * r
  DrawStroke
  
  'Kreis aus vier Bezierkurven zusammensetzen:
  MoveTo x, y + r
  DrawCurveTo x + r2, y + r, x + r, y + r2, x + r, y
  DrawCurveTo x + r, y - r2, x + r2, y - r, x, y - r
  DrawCurveTo x - r2, y - r, x - r, y - r2, x - r, y
  DrawCurveTo x - r, y + r2, x - r2, y + r, x, y + r
  DrawShape FillMode

End Sub


Public Sub DrawCurveTo( _
    ByVal x1 As Integer, ByVal y1 As Integer, _
    ByVal x2 As Integer, ByVal y2 As Integer, _
    ByVal x3 As Integer, ByVal y3 As Integer)

  If pOrientation = pdfPortrait Then
    y1 = pHeight - y1
    y2 = pHeight - y2
    y3 = pHeight - y3
  Else
    y1 = pWidth - y1
    y2 = pWidth - y2
    y3 = pWidth - y3
  End If
  
  StreamDrawing x1 & " " & y1 & " " & _
                x2 & " " & y2 & " " & _
                x3 & " " & y3 & " c"

End Sub


Public Sub DrawLine( _
    ByVal x1 As Integer, ByVal y1 As Integer, _
    ByVal x2 As Integer, ByVal y2 As Integer)

  pX = x2
  If pOrientation = pdfPortrait Then
    y1 = pHeight - y1
    pY = pHeight - y2
  Else
    y1 = pWidth - y1
    pY = pWidth - y2
  End If
  
  SetStroke "S"
  StreamDrawing x1 & " " & y1 & " m " & pX & " " & pY & " l"

End Sub


Public Sub DrawLineTo(ByVal x As Integer, ByVal y As Integer)

  pX = x
  If pOrientation = pdfPortrait Then
    pY = pHeight - y
  Else
    pY = pWidth - y
  End If
  
  StreamDrawing pX & " " & pY & " l"

End Sub


Public Sub DrawPicture( _
    ByVal x As Integer, ByVal y As Integer, _
    ByVal Width As Integer, ByVal Height As Integer, _
    ByRef Pic As Variant, _
    Optional ByVal ForceGrey As Boolean = False)

  Dim hPic As Long
  Dim hDC As Long
  Dim hTmp As Long
  Dim bmp As BITMAP
  Dim col As Long
  Dim r As Long, g As Long, b As Long
  Dim Bytes() As Byte
  Dim RLE As Variant
  Dim i As Long

  'Ggf. Koordinaten korrigieren:
  If Width < 0 Then x = x - Width
  If Height < 0 Then y = y - Height
  If pOrientation = pdfPortrait Then
    y = pHeight - y - Height
  Else
    y = pWidth - y - Height
  End If
  
  'Bildinfos holen:
  If VarType(Pic) = vbLong Then
    hPic = Pic
  ElseIf VarType(Pic) = vbString Then
    Set Pic = LoadPicture(Pic)
    hPic = Pic.handle
  Else
    hPic = Pic.handle
  End If
  GetObjectA hPic, Len(bmp), bmp
  
  'Header für PDF-Image schreiben:
  DrawStroke
  StreamDrawing "q"
  StreamDrawing Width & " 0 0 " & Height & " " & x & " " & y & " cm"
  StreamDrawing "BI"
  StreamDrawing "/W " & bmp.bmWidth
  StreamDrawing "/H " & bmp.bmHeight
  StreamDrawing "/BPC 8"
  If ForceGrey Then
    StreamDrawing "/CS /G"
    ReDim Bytes(1 To bmp.bmHeight * bmp.bmWidth)
  Else
    StreamDrawing "/CS /RGB"
    ReDim Bytes(1 To bmp.bmHeight * bmp.bmWidth * 3)
  End If
  
  'Bilddaten einsammeln:
  hDC = CreateCompatibleDC(0)
  hTmp = SelectObject(hDC, hPic)
  For y = 0 To bmp.bmHeight - 1
    For x = 0 To bmp.bmWidth - 1
   
      col = GetPixel(hDC, x, y)
      r = col And &HFF&
      g = (col And &HFF00&) \ &H100&
      b = (col And &HFF0000) \ &H10000
      
      If ForceGrey Then
        i = i + 1
        Bytes(i) = (77 * r + 151 * g + 28 * b + 127) \ 256
      Else
        Bytes(i + 1) = r
        Bytes(i + 2) = g
        Bytes(i + 3) = b
        i = i + 3
      End If
   
    Next x
  Next y
  SelectObject hDC, hTmp
  DeleteDC hDC
  
  'Daten für PDF-Image schreiben:
  RLE = RLEEncodeBytes(Bytes)
  If UBound(RLE) + 7 < UBound(Bytes) Then
    StreamDrawing "/F /RL"
    StreamDrawing "ID " & StrConv(RLE, vbUnicode) & Chr$(128)
  Else
    StreamDrawing "ID " & StrConv(Bytes, vbUnicode) & ">"
  End If
  StreamDrawing "EI"
  StreamDrawing "Q"

End Sub


Public Sub DrawShape( _
    Optional ByVal FillMode As pdfFillModes = pdfStroke)

  SetFillStroke FillMode
  DrawStroke

End Sub


Public Sub DrawText( _
    ByVal x As Integer, ByVal y As Integer, _
    ByVal Text As String, _
    Optional ByVal Angle As Single = 0)

  Dim c As String
  Dim s As String
  Dim t As String

  If pOrientation = pdfPortrait Then
    y = pHeight - y
  Else
    y = pWidth - y
  End If
  Text2PDF Text
  
  DrawStroke
  StreamDrawing "BT"
  StreamDrawing "/F1 " & pFontSize & " Tf"
  If Angle <> 0 Then
  
    'Transformationsmatrix berechnen:
    c = FormSingle(Cos(Angle))
    s = FormSingle(Sin(Angle))
    If Left$(s, 1) = "-" Then t = Mid$(s, 2) Else t = "-" & s
    StreamDrawing c & " " & s & " " & t & " " & c & " " & x & " " & y & " Tm"
  
  Else
    StreamDrawing x & " " & y & " Td"
  End If
  StreamDrawing "(" & Text & ")'"
  StreamDrawing "ET"

End Sub


Public Sub MoveTo(ByVal x As Integer, ByVal y As Integer)

  If pOrientation = pdfPortrait Then
    y = pHeight - y
  Else
    y = pWidth - y
  End If
  
  If x <> pX Or y <> pY Then
    pX = x
    pY = y
    DrawStroke
    StreamDrawing x & " " & y & " m"
  End If

End Sub


Public Sub NewPage( _
    Optional ByVal FontSize As Integer, _
    Optional ByVal LinesPerPage As Integer)

  'Ggf. Page-Parameter übernehmen:
  If FontSize Then pFontSize = FontSize
  If LinesPerPage Then pLinesPerPage = LinesPerPage
  
  If LineCount Then
  
    'Bereits beschriebene Seite abschlie&szlig;en:
    StreamPageTrailer
  
  ElseIf Not pDropBlankPages Then
  
    'Leerseite einfügen:
    StreamPageHeader
    StreamPageTrailer
  
  End If

End Sub


Public Sub PrintLine(ByVal Zeile As String)

  'Ggf. Seite abschlie&szlig;en:
  If LineCount = pLinesPerPage Then StreamPageTrailer
  
  'Ggf. Seite initialisieren:
  If LineCount = 0 Then StreamPageHeader
  
  Text2PDF Zeile
  StreamLine "(" & Zeile & ")'"
  LineCount = LineCount + 1
  
  IsFinalized = False

End Sub


Public Sub PrintText(ByRef Text As String)

  Dim NewLine As String
  Dim PosStart As Long
  Dim PosEnd As Long
  Dim Zeile As String

  NewLine = NewlineString(Text)
  PosStart = 1
  Do
  
    'N&auml;chste Zeile rausschneiden:
    PosEnd = InStr(PosStart, Text, NewLine)
    If PosEnd Then
      Zeile = Mid$(Text, PosStart, PosEnd - PosStart)
      PosStart = PosEnd + Len(NewLine)
    Else
      Zeile = Mid$(Text, PosStart)
    End If
   
    'Auf Seitenvorschub prüfen:
    If Zeile = pNewPageString Then
      NewPage
    Else
      PrintLine Zeile
    End If
  
  Loop While PosEnd

End Sub


Public Sub PrintFile(ByRef PathTXT As String)
  PrintText ReadFile(PathTXT)
End Sub


Public Function Value() As String

  Dim SaveBufferPtr As Long
  Dim SaveLineCount As Long
  Dim SavePageCount As Long
  Dim SaveXRefCount As Long

  If Not IsFinalized Then
  
    'Status für eventuelle Erweiterung merken:
    SaveBufferPtr = BufferPtr
    SaveLineCount = LineCount
    SavePageCount = PageCount
    SaveXRefCount = XRefCount
   
    'PDF-Dokument abschlie&szlig;en:
    If LineCount Then StreamPageTrailer
    StreamPDFTrailer
    FinalizedPtr = BufferPtr
   
    'Status restaurieren:
    BufferPtr = SaveBufferPtr
    LineCount = SaveLineCount
    PageCount = SavePageCount
    XRefCount = SaveXRefCount
  
  End If
  Value = Left$(Buffer, FinalizedPtr)

End Function


Public Sub SavePDF(ByRef PathPDF As String)
  WriteFile PathPDF, Value
End Sub


'---------'---------'---------'---------'---------'---------'---------
'Private Methoden:


Private Sub StreamPDFHeader()

  IsFinalized = False
  StreamLine "%PDF-1.1"
  StreamLine "%&acirc;&atilde;&Iuml;&Oacute;" 'Binary-&Uuml;bertragung erzwingen (via ASC>127)
  
  StreamObjHeader
  StreamLine "/CreationDate (D:" & Format$(Now, "yyyymmddhhnnss") & ")"
  StreamLine "/Producer (clsPDF [VB-Tec])"
  StreamObjTrailer
  
  StreamObjHeader
  StreamLine "/Type /Catalog"
  StreamLine "/Pages 3 0 R"
  StreamObjTrailer
  
  StreamRefSkip
  
  StreamObjHeader
  StreamLine "/Type /Font"
  StreamLine "/Subtype /Type1"
  StreamLine "/Name /F1"
  StreamLine "/BaseFont /Courier"
  StreamLine "/Encoding /WinAnsiEncoding"
  StreamObjTrailer
  
  StreamObjHeader
  StreamLine "/Font << /F1 4 0 R >>"
  StreamLine "/ProcSet [ /PDF /Text ]"
  StreamObjTrailer

End Sub


Private Sub StreamPDFTrailer()

  Dim XRefPtr As Long
  Dim i As Long

  StreamRefSkipped 3
  StreamLine "<<"
  StreamLine "/Type /Pages"
  StreamLine "/Count " & PageCount
  If pOrientation = pdfPortrait Then
    StreamLine "/MediaBox [0 0 " & pWidth & " " & pHeight & "]"
  Else
    StreamLine "/MediaBox [0 0 " & pHeight & " " & pWidth & "]"
  End If
  Stream "/Kids [ "
  For i = 1 To PageCount
    Stream Page(i) & " 0 R "
  Next i
  StreamLine "]"
  StreamObjTrailer
  
  XRefPtr = BufferPtr
  StreamLine "xref"
  StreamLine "0 " & (XRefCount + 1)
  
  StreamLine "0000000000 65535 f"
  For i = 1 To XRefCount
    StreamLine Right$("000000000" & XRef(i), 10) & " 00000 n"
  Next i
  
  StreamLine "trailer"
  StreamLine "<<"
  StreamLine "/Size " & (XRefCount + 1)
  StreamLine "/Root 2 0 R"
  StreamLine "/Info 1 0 R"
  StreamLine ">>"
  
  StreamLine "startxref"
  StreamLine CStr(XRefPtr)
  StreamLine "%%EOF"
  IsFinalized = True

End Sub


Private Sub StreamPageHeader()

  'Ggf. Platz schaffen:
  PageCount = PageCount + 1
  If PageCount > UBound(Page) Then ReDim Preserve Page(1 To 2 * PageCount)
  
  StreamObjHeader
  StreamLine "/Type /Page"
  StreamLine "/Parent 3 0 R"
  StreamLine "/Resources 5 0 R"
  StreamLine "/Contents " & (XRefCount + 1) & " 0 R"
  StreamObjTrailer
  Page(PageCount) = XRefCount
  
  StreamObjHeader
  StreamLine "/Length " & (XRefCount + 1) & " 0 R"
  StreamLine ">>"
  StreamLine "stream"
  PageStart = BufferPtr
  
  If pDrawWidth <> 0 Then pDrawWidthChanged = True
  If pDrawColor <> 0 Then pDrawColorChanged = True
  If pFillColor <> 0 Then pFillColorChanged = True
  
  SetStroke ""
  pX = 0
  pY = pHeight
  RaiseEvent PageStarted
  DrawStroke
  Stream Left$(DrawBuffer, DrawBufferPtr)
  DrawBufferPtr = 0
  
  'Ggf. auf schwarze Schrift zurückschalten:
  If pFillColor <> 0 Then StreamLine "0 g"
  
  'Textblock beginnen:
  StreamLine "BT"
  StreamLine "/F1 " & pFontSize & " Tf"
  If pOrientation = pdfPortrait Then
    StreamLine pMarginLeft & " " & pHeight - pMarginTop & " Td"
  Else
    StreamLine pMarginLeft & " " & pWidth - pMarginTop & " Td"
  End If
  StreamLine pFontSize & " TL"

End Sub


Private Sub StreamPageTrailer()

  Dim PageLength As Long

  StreamLine "ET"
  RaiseEvent PageFinished
  DrawStroke
  Stream Left$(DrawBuffer, DrawBufferPtr)
  DrawBufferPtr = 0
  
  PageLength = BufferPtr - PageStart
  StreamLine "endstream"
  StreamLine "endobj"
  
  StreamRef
  StreamLine CStr(PageLength)
  StreamLine "endobj"
  
  LineCount = 0
  IsFinalized = False

End Sub


Private Sub StreamObjHeader()
  StreamRef
  StreamLine "<<"
End Sub


Private Sub StreamObjTrailer()
  StreamLine ">>"
  StreamLine "endobj"
End Sub


Private Sub StreamRef()

  'Ggf. Platz schaffen:
  XRefCount = XRefCount + 1
  If XRefCount > UBound(XRef) Then ReDim Preserve XRef(1 To 2 * XRefCount)
  
  'XRef speichern:
  XRef(XRefCount) = BufferPtr
  StreamLine XRefCount & " 0 obj"

End Sub


Private Sub StreamRefSkip()
  XRefCount = XRefCount + 1
End Sub


Private Sub StreamRefSkipped(ByVal ObjNr As Long)
  XRef(ObjNr) = BufferPtr
  StreamLine ObjNr & " 0 obj"
End Sub


Private Sub StreamLine(ByRef s As String)
  Stream s & vbCr
End Sub


Private Sub Stream(ByRef s As String)

  Dim PtrNew As Long

  'Ggf. Platz schaffen:
  PtrNew = BufferPtr + Len(s)
  If PtrNew > Len(Buffer) Then Buffer = Buffer & Space$(PtrNew)
  
  'String passend kopieren:
  Mid$(Buffer, BufferPtr + 1) = s
  BufferPtr = PtrNew

End Sub


Private Sub StreamDrawing(ByRef s As String)

  If pDrawColorChanged Then
    StreamDrawingX UCase$(FormColor(pDrawColor)) & vbCr
    pDrawColorChanged = False
  End If
  If pFillColorChanged Then
    StreamDrawingX LCase$(FormColor(pFillColor)) & vbCr
    pFillColorChanged = False
  End If
  If pDrawWidthChanged Then
    StreamDrawingX FormSingle(pDrawWidth) & " w" & vbCr
    pDrawWidthChanged = False
  End If
  StreamDrawingX s & vbCr

End Sub


Private Sub StreamDrawingX(ByRef s As String)

  Dim PtrNew As Long

  'Ggf. Platz schaffen:
  PtrNew = DrawBufferPtr + Len(s)
  If PtrNew > Len(DrawBuffer) Then DrawBuffer = DrawBuffer & Space$(PtrNew)
  
  'String passend kopieren:
  Mid$(DrawBuffer, DrawBufferPtr + 1) = s
  DrawBufferPtr = PtrNew

End Sub


Private Sub Text2PDF(ByRef Text As String)

  'PDF-Specials' entsch&auml;rfen:
  ReplaceDo Text, "\", "\\"
  ReplaceDo Text, "(", "\("
  ReplaceDo Text, ")", "\)"

End Sub


Private Function FormColor(ByVal RGB As Long) As String

  Dim r As Byte
  Dim g As Byte
  Dim b As Byte

  r = RGB And &HFF&
  g = (RGB And &HFF00&) \ &H100&
  b = (RGB And &HFF0000) \ &H10000
  
  If r = g And r = b Then
    'Grauwert:
    FormColor = FormSingle(r / 255) & " G"
  Else
    'Farbwert:
    FormColor = FormSingle(r / 255) & " " & FormSingle(g / 255) & " " & FormSingle(b / 255) & " RG"
  End If

End Function


Private Function FormSingle(ByVal v As Single) As String

  Dim i As Long

  FormSingle = CStr(Int(v * 1000 + 0.5) / 1000)
  i = InStr(FormSingle, ",")
  If i Then Mid$(FormSingle, i, 1) = "."

End Function


Private Sub SetFillStroke(ByVal FillMode As pdfFillModes)
  Select Case FillMode
  Case pdfStroke:      SetStroke "S"
  Case pdfFill:        SetStroke "f"
  Case pdfFillStroke:  SetStroke "b"
  Case pdfCloseStroke: SetStroke "s"
  End Select
End Sub

Private Sub SetStroke(ByVal Stroke As String)
  If Stroke <> pStroke Then
    DrawStroke
    pStroke = Stroke
  End If
End Sub

Private Sub DrawStroke()
  If Len(pStroke) Then
    StreamDrawingX pStroke & vbCr
    pStroke = ""
  End If
End Sub


'---------'---------'---------'---------'---------'---------'---------
'Bekannte und wiederverwendete Routinen aus "VB-Tec":


' &copy;2004 by Jost Schwider, http://vb-tec.de/readfile.htm
Private Function ReadFile(ByRef Path As String) As String
  
  Dim FileNr As Long

  'Falls nicht vorhanden, nichts zurückgeben:
  On Error Resume Next
  If FileLen(Path) = 0 Then Exit Function
  On Error GoTo 0
  
  'Datei einlesen:
  FileNr = FreeFile
  Open Path For Binary As #FileNr
    ReadFile = Space$(LOF(FileNr))
    Get #FileNr, , ReadFile
  Close #FileNr

End Function


' &copy;2004 by Jost Schwider, http://vb-tec.de/speicher.htm
Private Sub WriteFile(ByRef Path As String, ByRef Text As String)

  Dim FileNr As Long

  FileNr = FreeFile
  Open Path For Output As #FileNr
    Print #FileNr, Text;
  Close #FileNr

End Sub


' &copy;2004 by Jost Schwider, http://vb-tec.de/newline.htm
Private Function NewlineString( _
    ByRef Text As String, _
    Optional ByRef Default As String = vbNewLine _
  ) As String

  Dim NL As Variant

  For Each NL In Array(vbCrLf, vbLf & vbCr, vbCr & vbCr, vbLf, vbCr)
  
    If InStr(Text, NL) Then
      NewlineString = NL
      Exit Function
    End If
  
  Next NL
  NewlineString = Default

End Function


' &copy;2004 by Jost Schwider, http://vb-tec.de/replace.htm
Private Function Replace(ByRef Text As String, _
    ByRef sOld As String, ByRef sNew As String, _
    Optional ByVal Start As Long = 1, _
    Optional ByVal Count As Long = 2147483647, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
  ) As String

  If LenB(sOld) = 0 Then 'Suchstring ist leer:
    Replace = Text
  ElseIf Compare = vbBinaryCompare Then
    ReplaceBin Replace, Text, Text, sOld, sNew, Start, Count
  Else
    ReplaceBin Replace, Text, LCase$(Text), LCase$(sOld), sNew, Start, Count
  End If

End Function

' &copy;2004 by Jost Schwider, http://vb-tec.de/replace.htm
Private Sub ReplaceDo(ByRef Text As String, _
    ByRef sOld As String, ByRef sNew As String, _
    Optional ByVal Start As Long = 1, _
    Optional ByVal Count As Long = 2147483647, _
    Optional ByVal Compare As VbCompareMethod = vbBinaryCompare _
  )
  
  If LenB(sOld) Then
  
    If Compare = vbBinaryCompare Then
      ReplaceBin Text, Text, Text, _
          sOld, sNew, Start, Count
    Else
      ReplaceBin Text, Text, LCase$(Text), _
          LCase$(sOld), sNew, Start, Count
    End If
  
  End If
End Sub

' &copy;2004 by Jost Schwider, http://vb-tec.de/replace.htm
Private Static Sub ReplaceBin(ByRef Result As String, _
    ByRef Text As String, ByRef Search As String, _
    ByRef sOld As String, ByRef sNew As String, _
    ByVal Start As Long, ByVal Count As Long _
  )
  Dim TextLen As Long
  Dim OldLen As Long
  Dim NewLen As Long
  Dim ReadPos As Long
  Dim WritePos As Long
  Dim CopyLen As Long
  Dim Buffer As String
  Dim BufferLen As Long
  Dim BufferPosNew As Long
  Dim BufferPosNext As Long
  
  'Ersten Treffer bestimmen:
  If Start < 2 Then
    Start = InStrB(Search, sOld)
  Else
    Start = InStrB(Start + Start - 1, Search, sOld)
  End If
  If Start Then
  
    OldLen = LenB(sOld)
    NewLen = LenB(sNew)
    Select Case NewLen
    Case OldLen 'einfaches &Uuml;berschreiben:
   
      Result = Text
      For Count = 1 To Count
        MidB$(Result, Start) = sNew
        Start = InStrB(Start + OldLen, Search, sOld)
        If Start = 0 Then Exit Sub
      Next Count
      Exit Sub
   
    Case Is < OldLen 'Ergebnis wird kürzer:
   
      'Buffer initialisieren:
      TextLen = LenB(Text)
      If TextLen > BufferLen Then
        Buffer = Text
        BufferLen = TextLen
      End If
      
      'Ersetzen:
      ReadPos = 1
      WritePos = 1
      If NewLen Then
      
        'Einzufügenden Text beachten:
        For Count = 1 To Count
          CopyLen = Start - ReadPos
          If CopyLen Then
            BufferPosNew = WritePos + CopyLen
            MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
            MidB$(Buffer, BufferPosNew) = sNew
            WritePos = BufferPosNew + NewLen
          Else
            MidB$(Buffer, WritePos) = sNew
            WritePos = WritePos + NewLen
          End If
          ReadPos = Start + OldLen
          Start = InStrB(ReadPos, Search, sOld)
          If Start = 0 Then Exit For
        Next Count
      
      Else
      
        'Einzufügenden Text ignorieren (weil leer):
        For Count = 1 To Count
          CopyLen = Start - ReadPos
          If CopyLen Then
            MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
            WritePos = WritePos + CopyLen
          End If
          ReadPos = Start + OldLen
          Start = InStrB(ReadPos, Search, sOld)
          If Start = 0 Then Exit For
        Next Count
      
      End If
      
      'Ergebnis zusammenbauen:
      If ReadPos > TextLen Then
        Result = LeftB$(Buffer, WritePos - 1)
      Else
        MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
        Result = LeftB$(Buffer, WritePos + LenB(Text) - ReadPos)
      End If
      Exit Sub
   
    Case Else 'Ergebnis wird l&auml;nger:
   
      'Buffer initialisieren:
      TextLen = LenB(Text)
      BufferPosNew = TextLen + NewLen
      If BufferPosNew > BufferLen Then
        Buffer = Space$(BufferPosNew)
        BufferLen = LenB(Buffer)
      End If
      
      'Ersetzung:
      ReadPos = 1
      WritePos = 1
      For Count = 1 To Count
        CopyLen = Start - ReadPos
        If CopyLen Then
          'Positionen berechnen:
          BufferPosNew = WritePos + CopyLen
          BufferPosNext = BufferPosNew + NewLen
         
          'Ggf. Buffer vergr&ouml;&szlig;ern:
          If BufferPosNext > BufferLen Then
            Buffer = Buffer & Space$(BufferPosNext)
            BufferLen = LenB(Buffer)
          End If
         
          'String "patchen":
          MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
          MidB$(Buffer, BufferPosNew) = sNew
        Else
          'Position bestimmen:
          BufferPosNext = WritePos + NewLen
         
          'Ggf. Buffer vergr&ouml;&szlig;ern:
          If BufferPosNext > BufferLen Then
            Buffer = Buffer & Space$(BufferPosNext)
            BufferLen = LenB(Buffer)
          End If
         
          'String "patchen":
          MidB$(Buffer, WritePos) = sNew
        End If
        WritePos = BufferPosNext
        ReadPos = Start + OldLen
        Start = InStrB(ReadPos, Search, sOld)
        If Start = 0 Then Exit For
      Next Count
      
      'Ergebnis zusammenbauen:
      If ReadPos > TextLen Then
        Result = LeftB$(Buffer, WritePos - 1)
      Else
        BufferPosNext = WritePos + TextLen - ReadPos
        If BufferPosNext < BufferLen Then
          MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
          Result = LeftB$(Buffer, BufferPosNext)
        Else
          Result = LeftB$(Buffer, WritePos - 1) & MidB$(Text, ReadPos)
        End If
      End If
      Exit Sub
   
    End Select
  
  Else 'Kein Treffer:
    Result = Text
  End If
End Sub


' &copy;2005 by Jost Schwider, http://vb-tec.de/rle-lauf.htm
Private Function RLEEncodeBytes(Bytes() As Byte) As Variant 'Bytes()

  Dim i As Long
  Dim UB As Long
  Dim RLE() As Byte
  Dim Cmd As Byte
  Dim b As Byte
  Dim n As Integer
  Dim j As Long
  Dim CmdPos As Long

  i = LBound(Bytes)
  UB = UBound(Bytes)
  ReDim RLE(0 To (UB - i + 1) * 128 \ 127 + 1)
  
  Cmd = 128
  Do Until i > UB
  
    b = Bytes(i)
    n = RLECountEqual(Bytes, b, i + 1, UB) + 1
    If n = 2 And Cmd < 126 Then
   
      'Kopierlauf verl&auml;ngern (um 2 Bytes):
      Cmd = Cmd + 2
      RLE(j) = b
      RLE(j + 1) = b
      j = j + 2
      i = i + 2
   
    ElseIf n > 1 Then
   
      'Komprimierlauf:
      If Cmd < 128 Then RLE(CmdPos) = Cmd
      Cmd = 257 - n
      RLE(j) = Cmd
      RLE(j + 1) = b
      j = j + 2
      i = i + n
   
    ElseIf Cmd < 127 Then
   
      'Kopierlauf verl&auml;ngern:
      Cmd = Cmd + 1
      RLE(j) = b
      j = j + 1
      i = i + 1
   
    Else
   
      'Kopierlauf beginnen:
      If Cmd < 128 Then RLE(CmdPos) = Cmd
      CmdPos = j
      Cmd = 0
      RLE(j + 1) = b
      j = j + 2
      i = i + 1
   
    End If
  
  Loop
  If Cmd < 128 Then RLE(CmdPos) = Cmd
  
  'Ergebnis formatieren:
  ReDim Preserve RLE(0 To j - 1)
  RLEEncodeBytes = RLE

End Function

' &copy;2005 by Jost Schwider, http://vb-tec.de/rle-lauf.htm
Private Function RLECountEqual( _
    Bytes() As Byte, ByVal b As Byte, _
    ByVal Start As Long, ByVal Stopp As Long _
  ) As Integer

  Dim i As Long

  'Maximal 127 Bytes untersuchen:
  If Stopp > Start + 126 Then Stopp = Start + 126
  
  'Los gehts:
  For i = Start To Stopp
    If Bytes(i) <> b Then Exit For
  Next i
  RLECountEqual = i - Start

End Function