formpdf.frm

text生成pdf文件

  Unload Me
End Sub

Private Sub btnOpen_Click()
  Dim filename As String
  On Local Error Resume Next
  filename = OpenDialog(Me, "Text files (*.txt)|*.txt|All files (*.*)|*.*", _
                   "Select a text file", "")
  If Len(filename) Then
    txtFilename.Text = filename
    filename = txtFilename.Text
    txtOutputFile.Text = Left(filename, Len(filename) - 3) & "pdf"
  End If
End Sub

Private Sub btnSave_Click()
  Dim filename As String
  On Local Error Resume Next
  filename = SaveDialog(Me, "Portable Document Format files (*.pdf)|*.pdf", _
                        "Save PDF As", "", "")
  If Len(filename) Then
    txtOutputFile.Text = filename
  End If
End Sub

Private Sub btnSource_Click()
  On Local Error Resume Next
End Sub

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 Sub

Public 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 Sub

Private 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

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 Sub

Private 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 Sub

Private 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 Function

Function 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 Function

Sub 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 Sub

Public Function FileExists(ByVal filename As String) As Boolean
  On Error Resume Next
  FileExists = FileLen(filename) > 0
  Err.Clear
End Function

Public 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

Function SaveDialog(Form1 As Form, Filter As String, Title As String, InitDir As String, DefaultFilename As String) As String
  Dim ofn As OPENFILENAME
  Dim A As Long
  On Local Error Resume Next
  ofn.lStructSize = Len(ofn)
  ofn.hwndOwner = Form1.hWnd
  ofn.hInstance = App.hInstance
  If Right$(Filter, 1) <> "|" Then Filter = Filter + "|"

  For A = 1 To Len(Filter)
      If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
  Next
  ofn.lpstrFilter = Filter
  ofn.lpstrFile = Space$(254)
  Mid(ofn.lpstrFile, 1, 254) = DefaultFilename
  ofn.nMaxFile = 255
  ofn.lpstrFileTitle = Space$(254)
  ofn.nMaxFileTitle = 255
  ofn.lpstrInitialDir = InitDir
  ofn.lpstrTitle = Title
  ofn.lpstrDefExt = "pdf"
  ofn.flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_CREATEPROMPT
  A = GetSaveFileName(ofn)


  If (A) Then
      SaveDialog = Trim$(ofn.lpstrFile)
  Else
      SaveDialog = ""
  End If
End Function

Function OpenDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String
  Dim ofn As OPENFILENAME
  Dim A As Long
  On Local Error Resume Next
  ofn.lStructSize = Len(ofn)
  ofn.hwndOwner = Form1.hWnd
  ofn.hInstance = App.hInstance
  If Right$(Filter, 1) <> "|" Then Filter = Filter + "|"

  For A = 1 To Len(Filter)
      If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
  Next
  ofn.lpstrFilter = Filter
  ofn.lpstrFile = Space$(254)
  ofn.nMaxFile = 255
  ofn.lpstrFileTitle = Space$(254)
  ofn.nMaxFileTitle = 255
  ofn.lpstrInitialDir = InitDir
  ofn.lpstrTitle = Title
  ofn.flags = OFN_HIDEREADONLY Or OFN_FILEMUSTEXIST
  A = GetOpenFileName(ofn)

  If (A) Then
      OpenDialog = Trim$(ofn.lpstrFile)
  Else
      OpenDialog = ""
  End If
End Function