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

解决方案 »

  1.   

    Private Sub writepdf(stre As String, Optional flush As Boolean)
      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
      

  2.   

    先装acrobat reader,然后在delphi中引入activex控件就ok了(pdf.ocx)
      

  3.   

    这是一个VB的例子!你可以到这里下载源代码:http://www.applevb.com/sourcecode/Text-PDF.zip转换为delphi得很容易!