Private Sub btnConvert_Click()
If txtFilename.Text <> "" And txtOutputFile.Text <> "" Then
ConvertToPDF txtFilename.Text, txtOutputFile.Text, _
txtAuthor.Text, txtCreator.Text, txtKeywords.Text, _
txtSubject.Text, txtTitle.Text, _
cmbFont.Text, Val(cmbFontSize.Text), Val(cmbRotation.Text), _
Val(cmbPageSize.Text), Val(Right(cmbPageSize.Text, 3))
If FileExists(cmdline) Then
Unload Me
ElseIf MsgBox("PDF file is done." & vbCr & vbCr & "Do you want to open the generated PDF file?", vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then
ShellExecute 0, vbNullString, txtOutputFile.Text, vbNullString, vbNullString, 1
End If
Else
MsgBox "Please specify file names."
End If
End SubPublic Sub ConvertToPDF(filename As String, outputfile As String, _
Optional TextAuthor As String, Optional TextCreator As String, Optional TextKeywords As String, _
Optional TextSubject As String, Optional TextTitle As String, _
Optional FontName As String = "Courier", Optional FontSize As Integer = 10, Optional Rotation As Integer, _
Optional pwidth As Single = 8.5, Optional pheight As Single = 11)
On Error GoTo er
If Not FileExists(filename) Then
MsgBox "File '" & filename & "' does not exist."
Exit Sub
ElseIf FileExists(outputfile) Then
Kill outputfile
End If initialize FontName, FontSize, Rotation, pwidth, pheight
author = TextAuthor
creator = TextCreator
keywords = TextKeywords
subject = TextSubject
Title = TextTitle
filetxt = filename
filepdf = outputfile
Call WriteStart
Call WriteHead
Call WritePages
Call endpdf
Exit Sub
er:
MsgBox Err.Description
End SubPrivate Sub initialize(FontName As String, FontSize As Integer, Rotation As Integer, pwidth As Single, pheight As Single)
pageHeight = 72 * pheight
pageWidth = 72 * pwidth BaseFont = FontName ' Courier, Times-Roman, Arial
pointSize = FontSize ' Font Size; Don't change it
vertSpace = FontSize * 1.2 ' Vertical spacing
rotate = Rotation ' degrees to rotate; try setting 90,180,etc
lines = (pageHeight - 72) / vertSpace ' no of lines on one page
Select Case LCase(FontName)
Case "courier": linelen = 1.5 * pageWidth / pointSize
Case "arial": linelen = 2 * pageWidth / pointSize
'Case "Times-Roman": linelen = 2.2 * pageWidth / pointSize
Case Else: linelen = 2.2 * pageWidth / pointSize
End Select obj = 0
npagex = pageWidth / 2
npagey = 25
pageNo = 0
Position = 0
cache = ""
End Sub
If txtFilename.Text <> "" And txtOutputFile.Text <> "" Then
ConvertToPDF txtFilename.Text, txtOutputFile.Text, _
txtAuthor.Text, txtCreator.Text, txtKeywords.Text, _
txtSubject.Text, txtTitle.Text, _
cmbFont.Text, Val(cmbFontSize.Text), Val(cmbRotation.Text), _
Val(cmbPageSize.Text), Val(Right(cmbPageSize.Text, 3))
If FileExists(cmdline) Then
Unload Me
ElseIf MsgBox("PDF file is done." & vbCr & vbCr & "Do you want to open the generated PDF file?", vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then
ShellExecute 0, vbNullString, txtOutputFile.Text, vbNullString, vbNullString, 1
End If
Else
MsgBox "Please specify file names."
End If
End SubPublic Sub ConvertToPDF(filename As String, outputfile As String, _
Optional TextAuthor As String, Optional TextCreator As String, Optional TextKeywords As String, _
Optional TextSubject As String, Optional TextTitle As String, _
Optional FontName As String = "Courier", Optional FontSize As Integer = 10, Optional Rotation As Integer, _
Optional pwidth As Single = 8.5, Optional pheight As Single = 11)
On Error GoTo er
If Not FileExists(filename) Then
MsgBox "File '" & filename & "' does not exist."
Exit Sub
ElseIf FileExists(outputfile) Then
Kill outputfile
End If initialize FontName, FontSize, Rotation, pwidth, pheight
author = TextAuthor
creator = TextCreator
keywords = TextKeywords
subject = TextSubject
Title = TextTitle
filetxt = filename
filepdf = outputfile
Call WriteStart
Call WriteHead
Call WritePages
Call endpdf
Exit Sub
er:
MsgBox Err.Description
End SubPrivate Sub initialize(FontName As String, FontSize As Integer, Rotation As Integer, pwidth As Single, pheight As Single)
pageHeight = 72 * pheight
pageWidth = 72 * pwidth BaseFont = FontName ' Courier, Times-Roman, Arial
pointSize = FontSize ' Font Size; Don't change it
vertSpace = FontSize * 1.2 ' Vertical spacing
rotate = Rotation ' degrees to rotate; try setting 90,180,etc
lines = (pageHeight - 72) / vertSpace ' no of lines on one page
Select Case LCase(FontName)
Case "courier": linelen = 1.5 * pageWidth / pointSize
Case "arial": linelen = 2 * pageWidth / pointSize
'Case "Times-Roman": linelen = 2.2 * pageWidth / pointSize
Case Else: linelen = 2.2 * pageWidth / pointSize
End Select obj = 0
npagex = pageWidth / 2
npagey = 25
pageNo = 0
Position = 0
cache = ""
End Sub
解决方案 »
- 我用adoquery读数据, 由于数据多,读的时间长,所以想用TThread来做,请问如何实现?
- 最后一点分了,关于Object Passcal语法的两个疑问,请高手进来帮忙.真心谢过了.
- 图形处理高手请显身,超菜的问题
- 在DBGird里上移或下移一条记录时可以发生一个事件吗?是什么事件?(急。。)
- 一个TreeView问题,请高手们帮个忙,急急急急急急急急急急,必有重谢。
- 求把这个C++函数翻译成delphi
- 怎么把列表框中的项移到另一个列表框中?
- 请指教!分不够可以再给……
- cs结构中,客户端如何使用线程查询?
- 将鼠标移到label控件上时,字体显示红色,移开时显示黑色。不要用onmousemove来控件。
- 请教:在RICHEDIT中,怎么样定位光标到任意一行?
- report 打印出现半个汉字的问题
On Local Error Resume Next
Position = Position + Len(stre)
cache = cache & stre & vbCr
If Len(cache) > 32000 Or flush Then
Open filepdf For Append As #1
Print #1, cache;
Close #1
cache = ""
End If
End Sub
Private Sub WriteStart()
writepdf ("%PDF-1.2")
writepdf ("%忏嫌")
End SubPrivate Sub WriteHead()
Dim CreationDate As String
On Error GoTo er
CreationDate = "D:" & Format(Now, "YYYYMMDDHHNNSS")
obj = obj + 1
location(obj) = Position
info = obj
writepdf (obj & " 0 obj")
writepdf ("<<")
writepdf ("/Author (" & author & ")")
writepdf ("/CreationDate (" & CreationDate & ")")
writepdf ("/Creator (" & creator & ")")
writepdf ("/Producer (" & AppName & ")")
writepdf ("/Title (" & Title & ")")
writepdf ("/Subject (" & subject & ")")
writepdf ("/Keywords (" & keywords & ")")
writepdf (">>")
writepdf ("endobj")
obj = obj + 1
root = obj
obj = obj + 1
Tpages = obj
encoding = obj + 2
resources = obj + 3
obj = obj + 1
location(obj) = Position
writepdf (obj & " 0 obj")
writepdf ("<<")
writepdf ("/Type /Font")
writepdf ("/Subtype /Type1")
writepdf ("/Name /F1")
writepdf ("/Encoding " & encoding & " 0 R")
writepdf ("/BaseFont /" & BaseFont)
writepdf (">>")
writepdf ("endobj")
obj = obj + 1
location(obj) = Position
writepdf (obj & " 0 obj")
writepdf ("<<")
writepdf ("/Type /Encoding")
writepdf ("/BaseEncoding /WinAnsiEncoding")
writepdf (">>")
writepdf ("endobj")
obj = obj + 1
location(obj) = Position
writepdf (obj & " 0 obj")
writepdf ("<<")
writepdf (" /Font << /F1 " & obj - 2 & " 0 R >>")
writepdf (" /ProcSet [ /PDF /Text ]")
writepdf (">>")
writepdf ("endobj")
Exit Sub
er:
MsgBox Err.Description
End Sub
Private Sub WritePages()
Dim i As Integer
Dim line As String, tmpline As String, beginstream As String
On Error GoTo er
Open filetxt For Input As #2
beginstream = StartPage
lineNo = -1
Do Until EOF(2)
Line Input #2, line
lineNo = lineNo + 1
'page break
If lineNo >= lines Or InStr(line, Chr(12)) > 0 Then
writepdf ("1 0 0 1 " & npagex & " " & npagey & " Tm")
writepdf ("(" & pageNo & ") Tj")
writepdf ("/F1 " & pointSize & " Tf")
endpage (beginstream)
beginstream = StartPage
End If
line = ReplaceText(ReplaceText(line, "(", "\("), ")", "\)")
line = Trim(line)
If Len(line) > linelen Then
'word wrap
Do While Len(line) > linelen
tmpline = Left(line, linelen)
For i = Len(tmpline) To Len(tmpline) \ 2 Step -1
If InStr("*&^%$#,. ;<=>[])}!""", Mid(tmpline, i, 1)) Then
tmpline = Left(tmpline, i)
Exit For
End If
Next
line = Mid$(line, Len(tmpline) + 1)
writepdf ("T* (" & tmpline & vbCrLf & ") Tj")
lineNo = lineNo + 1
'page break
If lineNo >= lines Or InStr(line, Chr(12)) > 0 Then
writepdf ("1 0 0 1 " & npagex & " " & npagey & " Tm")
writepdf ("(" & pageNo & ") Tj")
writepdf ("/F1 " & pointSize & " Tf")
endpage (beginstream)
beginstream = StartPage
End If
Loop
lineNo = lineNo + 1
writepdf ("T* (" & line & vbCrLf & ") Tj")
Else
writepdf ("T* (" & line & vbCrLf & ") Tj")
End If
Loop
Close #2
writepdf ("1 0 0 1 " & npagex & " " & npagey & " Tm")
writepdf ("(" & pageNo & ") Tj")
writepdf ("/F1 " & pointSize & " Tf")
endpage (beginstream)
Exit Sub
er:
MsgBox Err.Description
Close
End SubPrivate Function StartPage() As String
Dim strmpos As Long
On Error GoTo er
obj = obj + 1
location(obj) = Position
pageNo = pageNo + 1
pageObj(pageNo) = obj
writepdf (obj & " 0 obj")
writepdf ("<<")
writepdf ("/Type /Page")
writepdf ("/Parent " & Tpages & " 0 R")
writepdf ("/Resources " & resources & " 0 R")
obj = obj + 1
writepdf ("/Contents " & obj & " 0 R")
writepdf ("/Rotate " & rotate)
writepdf (">>")
writepdf ("endobj")
location(obj) = Position
writepdf (obj & " 0 obj")
writepdf ("<<")
writepdf ("/Length " & obj + 1 & " 0 R")
writepdf (">>")
writepdf ("stream")
strmpos = Position
writepdf ("BT")
writepdf ("/F1 " & pointSize & " Tf")
writepdf ("1 0 0 1 50 " & pageHeight - 40 & " Tm")
writepdf (vertSpace & " TL")
StartPage = strmpos
Exit Function
er:
MsgBox Err.Description
End FunctionFunction endpage(streamstart As Long) As String
Dim streamEnd As Long
On Error GoTo er
writepdf ("ET")
streamEnd = Position
writepdf ("endstream")
writepdf ("endobj")
obj = obj + 1
location(obj) = Position
writepdf (obj & " 0 obj")
writepdf (streamEnd - streamstart)
writepdf "endobj"
lineNo = 0
Exit Function
er:
MsgBox Err.Description
End FunctionSub endpdf()
Dim ty As String, i As Integer, xreF As Long
On Error GoTo er
location(root) = Position
writepdf (root & " 0 obj")
writepdf ("<<")
writepdf ("/Type /Catalog")
writepdf ("/Pages " & Tpages & " 0 R")
writepdf (">>")
writepdf ("endobj")
location(Tpages) = Position
writepdf (Tpages & " 0 obj")
writepdf ("<<")
writepdf ("/Type /Pages")
writepdf ("/Count " & pageNo)
writepdf ("/MediaBox [ 0 0 " & pageWidth & " " & pageHeight & " ]")
ty = ("/Kids [ ")
For i = 1 To pageNo
ty = ty & pageObj(i) & " 0 R "
Next i
ty = ty & "]"
writepdf (ty)
writepdf (">>")
writepdf ("endobj")
xreF = Position
writepdf ("0 " & obj + 1)
writepdf ("0000000000 65535 f ")
For i = 1 To obj
writepdf (Format(location(i), "0000000000") & " 00000 n ")
Next i
writepdf ("trailer")
writepdf ("<<")
writepdf ("/Size " & obj + 1)
writepdf ("/Root " & root & " 0 R")
writepdf ("/Info " & info & " 0 R")
writepdf (">>")
writepdf ("startxref")
writepdf (xreF)
writepdf "%%EOF", True
Exit Sub
er:
MsgBox Err.Description
End SubPublic Function FileExists(ByVal filename As String) As Boolean
On Error Resume Next
FileExists = FileLen(filename) > 0
Err.Clear
End FunctionPublic Function ReplaceText(Text As String, TextToReplace As String, NewText As String) As String
Dim mtext As String, SpacePos As Long
mtext = Text
SpacePos = InStr(mtext, TextToReplace)
Do While SpacePos
mtext = Left(mtext, SpacePos - 1) & NewText & Mid(mtext, SpacePos + Len(TextToReplace))
SpacePos = InStr(SpacePos + Len(NewText), mtext, TextToReplace)
Loop
ReplaceText = mtext
End Function
这是一个VB的例子!你可以到这里下载源代码:http://www.applevb.com/sourcecode/Text-PDF.zip