lo tomàs avança

Aquesta rutina d’VBA serveix per aplicar un format concret i transformar a PDF tots els fitxers .xls que pengin de les subcarpetes d’un directori.

Option Explicit

Sub ArreglarMargeITransformarAPDF()

Dim fs, f, f1, sf
Dim folderspec
Dim MiNombre As String

folderspec = “C:\Directori\”

Set fs = CreateObject(”Scripting.FileSystemObject”)
Set f = fs.GetFolder(folderspec)
Set sf = f.SubFolders
For Each f1 In sf
Debug.Print f1.Name
MiNombre = Dir(folderspec & f1.Name & “\”)
Do While MiNombre <> “”
If MiNombre Like “*.xls” Then
Workbooks.Open folderspec & f1.Name & “\” & MiNombre
Call arreglarFormat
Call imprimirPDF(folderspec & f1.Name & “\”, Replace(MiNombre, “.xls”, “.pdf”))
ActiveWorkbook.Close savechanges:=True
End If
MiNombre = Dir
Loop
Debug.Print “Imprimit ” & f1.Name
Next

End Sub

Public Sub arreglarFormat()

With ActiveSheet.PageSetup
.LeftMargin = Application.InchesToPoints(0.15)
.RightMargin = Application.InchesToPoints(0.15)
.TopMargin = Application.InchesToPoints(0.15)
.BottomMargin = Application.InchesToPoints(0.15)
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 1
.PrintErrors = 0
.PaperSize = xlPaperA3
End With

End Sub

Private Sub imprimirPDF(Directori, Fitxer)

Dim PSFileName As String
Dim PDFFileName As String
PSFileName = “c:\tempPOA.ps”
PDFFileName = Directori & Fitxer

‘ Imprimir la fulla
Dim MySheet As Worksheet
Set MySheet = ActiveSheet

‘ Convertir a PDF
Dim pdfjob As PDFCreator.clsPDFCreator
Set pdfjob = New PDFCreator.clsPDFCreator

With pdfjob
If .cStart(”/NoProcessingAtStartup”) = False Then
MsgBox “Can’t initialize PDFCreator.”, vbCritical + _
vbOKOnly, “PrtPDFCreator”
Exit Sub
End If

‘Set details on where to save file to, and flag it automatic
.cOption(”UseAutosave”) = 1
.cOption(”UseAutosaveDirectory”) = 1
.cOption(”AutosaveDirectory”) = Directori
.cOption(”AutosaveFilename”) = Fitxer
.cOption(”AutosaveFormat”) = 0 ‘ 0 = PDF

‘Get ready for the print job
.cClearCache
End With

MySheet.PrintOut copies:=1, ActivePrinter:=”PDFCreator”

‘Wait until the print job has entered the print queue
Do Until pdfjob.cCountOfPrintjobs = 1
DoEvents
Loop
pdfjob.cPrinterStop = False

‘Wait until the PDF file shows up then release the objects
Do Until Dir(Directori & Fitxer) <> “”
DoEvents
Loop

pdfjob.cClose
Set pdfjob = Nothing
End Sub