用VB CLASS 写ＰＤＦ文件
' ©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
'---------'---------'---------'---------'---------'---------'---------
'Ö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ß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ß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ä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ß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 "%âãÏÓ" 'Binary-Übertragung erzwingen (via ASC>127)
StreamObjHeader
StreamLine "/CreationDate (D:" & Format$(Now, "yyyymmddhhnnss") & ")"
StreamLine "/Producer (clsPDF )"
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 "
Else
StreamLine "/MediaBox "
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ä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":
' ©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
' ©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
' ©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
' ©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
' ©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
' ©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 Ü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ä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öß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öß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
' ©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ä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ä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
' ©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
页:
[1]