Keskustelu: Ohjelmointikysymykset: VBA: PDF-tiedosto automaattisesti

Sub UlostaPDF()

Dim Ulostin As Printer
Dim OletusUlostin As String
Dim OletusPolku As String

OletusUlostin = Printer.DeviceName
OletusPolku = Environ("HOMEPATH")

For Each Ulostin In Printers
  Select Case Ulostin.DeviceName
    Case "AcrobatDistiller", "Foxit PDF Printer", "jne."
    Set Printer = Ulostin: Exit For
  End Select
Next


'ChDir(polku)

'tähän tulostusrutiini
'...

'ChDir(OletusPolku)

For Each Ulostin In Printers
  Select Case Ulostin.DeviceName
    Case OletusUlostin
    Set Printer = Ulostin: Exit For
  End Select
Next

End Sub

Sub EsiUlostus()

  ChDir (Environ("userprofile") & "\Työpöytä")
  UlostaPDF ActiveWorkbook.Name & "_" & _
  ActiveSheet.Name & "_PDF" '(Excel)
  ChDir (Environ("HOMEPATH"))

End Sub

Sub UlostaPDF(ByVal PDFDocumentti As String)

  Dim OletusUlostin As String
  Dim Ulostin As String
  Dim Nimi As String, i As Integer
  Nimi = "Foxit PDF Printer" 'esim.
  OletusUlostin = Application.ActivePrinter
  Set WshNetwork = CreateObject("WScript.Network")
  Set Ulostimet = WshNetwork.EnumPrinterConnections

  For i = 0 To Ulostimet.Count - 2 Step 1
    Ulostin = Ulostimet.Item(i + 1) & " porttiin Ne00:"
    If InStr(Ulostin, Nimi) > 0 Then Exit For
  Next

  i = 0

ret:
  On Error Resume Next
  Application.ActivePrinter = Ulostin
  If Err > 0 And i < 9 Then
    Err.Clear: On Error GoTo 0
    Dim splitti() As String
    splitti = Split(Ulostin, "Ne0")
    i = i + 1: Ulostin = splitti(0) & "Ne0" & CStr(i) & ":"
    Erase splitti: GoTo ret
  ElseIf Err > 0 And i = 9 Then
    MsgBox "Systeemissä on mätää!!!"
    GoTo ExitProc
  End If

  On Error Resume Next
  SendKeys PDFDocumentti
  SendKeys "{TAB}"
  SendKeys "{TAB}"
  SendKeys "{ENTER}"
  '----------------------
  'Excel
  ActiveSheet.PrintOut
  '======================
  'Access
  'DoCmd.PrintOut
  '----------------------

ExitProc:
  If Err <> 0 Then
    Err.Clear: On Error GoTo 0
  End If

  Application.ActivePrinter = OletusUlostin
  Set Ulostimet = Nothing
  Set WshNetwork = Nothing

End Sub

Sub UlostaPDF()

Dim errCount As Integer, PDFDocument As String
Dim perusPolku As String, rpt As Report, exists As Boolean
Dim rptNimi As String, rptPolku As String

perusPolku = Environ("userprofile") & "\Omat tiedostot"

For Each rpt In Apllication.Reports
  If InStr(rpt.Name, "lasku") > 0 Then
   rptNimi = rpt.Name
   rptPolku = perusPolku & "\laskut"
   exists = true: Exit For
  End IF
Next

If Not exists Then
  MsgBox "Raporttia ei ole!": Exit Sub
End If

On Error Resume Next
MkDir(rptPolku)
If Err > 0 Then GoTo ErrorHandler

On Error Resume Next
DoCmd.OpenReport rptNimi, acPreview
If Err > 0 Then GoTo ErrorHandler

PDFDocument = rptPolku & "\" & rptNimi
SendKeys PDFDocument
SendKeys "{TAB}"
SendKeys "{TAB}"
SendKeys "{ENTER}"
DoCmd.PrintOut
DoCmd.Close acReport, rptNimi, acSaveYes

Exit Sub

ErrorHandler:
  Err.Clear: On Error GoTo 0
  If errCount = 0 Then
    errCount = errCount + 1: Resume Next
  Else
    MsgBox "Systeemissä on mätää!"
  End If
End If

End Sub

DoCmd.OpenReport rptNimi, acPreview
If Err > 0 Then GoTo ErrorHandler

'eli laita tähän väliin seuraavat 5 rivä '*
Do while InStr(Screen.ActiveReport.Name, rptNimi) = 0: Loop
Dim OletusPolku As String
OletusPolku = Application.DefaultFilePath
Application.DefaultFilePath = rptPolku
On Error Resume Next

'ja muuta tämä rivi
PDFDocument = rptPolku & "\" & rptNimi '*
'tähän
PDFDocument = rptNimi

'lisää tämä rivi
SendKeys "{DELETE}"

SendKeys PDFDocument
SendKeys "{TAB}" 'näillä siirrytään tallenna dialogin kontrolleissa
SendKeys "{TAB}" 'joten tsekkaa mihin fokus jää jos tökkii...
SendKeys "{ENTER}" 'tällä klikataan tallenna-nappia
DoCmd.PrintOut

'lisää nämä kaksi riviä
If Err > 0 Then GoTo ErrorHandler
Do While Dir(rptPolku & "\" & rptNimi) = "": Loop

DoCmd.Close acReport, rptNimi, acSaveYes

'lisää tämä rivi
Application.DefaultFilePath = OletusPolku

Exit Sub

'sit muuta vähän virheenkäsittelijää

ErrorHandler:
  Err.Clear: On Error GoTo 0
  If errCount = < 2 Then
    errCount = errCount + 1: Resume Next
  Else
    If Application.DefaultFilePath <> OletusPolku Then _
    Application.DefaultFilePath = OletusPolku
  End If

Sub TulostaPDF()

Dim errCount As Integer, rpt As Report
Dim rptNimi As String, rptPolku As String
Dim exists As Boolean, OletusPolku As String
Dim OletusTulostin As Printer

For Each rpt In Apllication.Reports
  If InStr(rpt.Name, "lasku") > 0 Then
   rptNimi = rpt.Name
   exists = true: Exit For
  End IF
Next


If Not exists Then
  MsgBox "Raporttia ei ole!": Exit Sub
End If

OletusTulostin = Printer
Printer = Application.Printers("Adobe PDF") 'tai muu PDF-tulostin

DoCmd.OpenReport rptNimi, acPreview
Reports(rptNimi).Printer = Printer
Do while Screen.ActiveReport.Name <> rptNimi: DoEvents: Loop
rptPolku = CurrentProject.path & "\laskut"

On Error Resume Next
MkDir(rptPolku)
If Err > 0 Then GoTo ErrorHandler

OletusPolku = Application.DefaultFilePath
Application.DefaultFilePath = rptPolku

On Error Resume Next

SendKeys "{DELETE}"
SendKeys rptNimi
SendKeys "{TAB}"
SendKeys "{TAB}"
SendKeys "{ENTER}"
DoCmd.PrintOut

If Err > 0 Then GoTo ErrorHandler

Do While Dir(rptPolku & "\" & rptNimi & ".pdf") = "": DoEvents: Loop

DoCmd.Close acReport, rptNimi, acSaveYes


ExitProc:

Application.DefaultFilePath = OletusPolku
Printer = OletusTulostin

Exit Sub

ErrorHandler:
  Err.Clear: On Error GoTo 0
  If errCount = < 2 Then
    errCount = errCount + 1: Resume Next
  Else
    MsgBox("Systeemissä on mätää!"): GoTo ExitProc
  End If

End Sub