1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
|
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Option Explicit
Dim Dossier As String
Dim DossierSauvegarde As String
Dim NbPages As Long, NomDocDepart As String
Dim sNomFichierPS As String
Dim sNomFichierPDF As String
Dim sNomFichierLOG As String
Dim NomDoc As String
Dim i As Long
Sub Delai()
' millisecondes
DoEvents
Sleep 5000
End Sub
Sub CreationPS()
NomDocDepart = ActiveDocument.Name
Dossier = ActiveDocument.Path
DossierSauvegarde = Dossier & "\" & "Charcuterie"
CreationDossier DossierSauvegarde
Application.Browser.Target = wdBrowsePage
Selection.HomeKey Unit:=wdStory
NbPages = ActiveDocument.Content.ComputeStatistics(wdStatisticPages)
NomDoc = Left$(NomDocDepart, Len(NomDocDepart) - 4) & "_"
For i = 1 To NbPages
sNomFichierPS = DossierSauvegarde & "\" & NomDoc & NumPage(i) & ".ps"
Application.PrintOut FileName:="", OutputFileName:=sNomFichierPS, Range:=wdPrintCurrentPage, Item:= _
wdPrintDocumentContent, Copies:=1, Pages:="", PageType:=wdPrintAllPages, _
ManualDuplexPrint:=False, Collate:=True, Background:=True, PrintToFile:= _
True, PrintZoomColumn:=0, PrintZoomRow:=0, PrintZoomPaperWidth:=0, _
PrintZoomPaperHeight:=0
Application.Browser.Next
Next i
Selection.HomeKey Unit:=wdStory
End Sub
Sub PS2PDF()
Dim PDFDist As Object
Set PDFDist = CreateObject("PdfDistiller.PdfDistiller")
For i = 1 To NbPages
sNomFichierPS = DossierSauvegarde & "\" & NomDoc & NumPage(i) & ".ps"
sNomFichierPDF = DossierSauvegarde & "\" & NomDoc & NumPage(i) & ".pdf"
PDFDist.FileToPDF sNomFichierPS, sNomFichierPDF, ""
Next i
Set PDFDist = Nothing
End Sub
Sub Kill_PSLOG()
For i = 1 To NbPages
sNomFichierPS = DossierSauvegarde & "\" & NomDoc & NumPage(i) & ".ps"
sNomFichierLOG = DossierSauvegarde & "\" & NomDoc & NumPage(i) & ".log"
Kill sNomFichierPS
Kill sNomFichierLOG
Next i
End Sub
Private Function NumPage(n As Long) As String
Select Case n
Case 1 To 9: NumPage = "00" & CStr(n)
Case 10 To 99: NumPage = "0" & CStr(n)
Case Else: NumPage = CStr(n)
End Select
End Function
Private Sub CreationDossier(sDossier As String)
Dim Rep As Long
Rep = SHCreateDirectoryEx(0&, sDossier, 0&)
' Pour valeur retournée dans Rep
' Voir http://msdn.microsoft.com/en-us/library/ms681381(VS.85).aspx
End Sub |
Partager