Snap2Pdf v1.0.2
Table des procédures 1 - frmSnap2Pdf (frmSnap2Pdf.frm) 1.1 - Private Sub AfficherMsg 1.2 - Private Sub Form_Activate 2 - Constantes (modConstantes.bas) 3 - ModMain (modMain.bas) 3.1 - Private Function bVerifierComposants 3.2 - Private Sub Main 4 - ShellWait (modShellWait.bas) 4.1 - Public Function bShellWait 4.2 - Public Sub Attendre 5 - Utilitaires (modUtil.bas) 5.1 - Public Function bFichierExiste 5.2 - Public Function bIDE 5.3 - Public Function bVerifierInstallObjet 5.4 - Public Sub AfficherMsgErreur frmSnap2Pdf (frmSnap2Pdf.frm) Option Explicit ' Snap2Pdf : Imprimer un état Access en Pdf via un instantanée Snp et PostScript ' www.vbfrance.com/code.aspx?ID=29813 ' Documentation : Snap2Pdf.html ' http://patrice.dargenton.free.fr/CodesSources/Snap2Pdf.html ' http://patrice.dargenton.free.fr/CodesSources/Snap2Pdf.vbp.html ' Par Patrice Dargenton : patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' http://www.vbfrance.com/listeauteur2.aspx?ID=1124 ' Version 1.02 du 26/03/2006 Private Sub Form_Activate() Dim sCheminSNP$, sCheminPS$, sCheminPdf$ Dim sDriverName$, sPrinterName$, sPortName$ Dim bQuitter As Boolean sCheminSNP = App.Path & "\" & sFichierSNP sCheminPS = App.Path & "\" & sFichierPS sCheminPdf = App.Path & "\" & sFichierPdf sDriverName = "" ' ??? sPrinterName = sPiloteImprimantePostScript sPortName = sCheminPS ' Il s'agit en fait du chemin du fichier d'impression If False = bFichierExiste(sCheminSNP, bPrompt:=True) Then Exit Sub If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 Me.MousePointer = vbHourglass AfficherMsg "Impression de l'état Snp en PostScript..." ' Le contrôle ActiveX doit avoir une interface, il ne fonctionne pas ' si on le crée sans interface avec CreateObject Me.SnapshotViewer.SnapshotPath = sCheminSNP Me.SnapshotViewer.PrintSnapshotDirect sDriverName, sPrinterName, sPortName If Me.SnapshotViewer.Error > 0 Then MsgBox "Erreur n°" & Me.SnapshotViewer.Error & _ " lors de l'impression de l'état Snp", vbCritical, sTitreMsg Exit Sub End If Dim sProgFile$, sCheminGhostScript$, sCmd$ Const sGm$ = """" ' Au cas où il y ait un espace dans le chemin ' Liste des variables d'environnement 'http://forums.aspfree.com/t26406/s.html sProgFile = Environ("ProgramFiles") ' Vérifier si l'interpreteur PostScript est installé (GhostScript) sCheminGhostScript = sProgFile & "\GhostScriptPdf\gs8.14\bin\gswin32c.exe" If False = bFichierExiste(sCheminGhostScript, bPrompt:=True) Then Exit Sub AfficherMsg "Conversion de l'état PostScript en Pdf..." sCmd = sCheminGhostScript & " -q -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite" & _ " -sOutputFile=" & sGm & sCheminPdf & sGm & _ " -c .setpdfwrite -f " & sGm & sCheminPS & sGm Dim lOption&, sMsgErr$ sMsgErr = "" lOption = vbHide If bDebug Then lOption = vbNormalFocus ' vbNormalFocus pour voir la boîte DOS If False = bShellWait(sCmd, lOption, sMsgErr) Then MsgBox "Impossible de convertir l'état PostScript en Pdf !" & vbLf & _ sMsgErr, vbCritical, sTitreMsg GoTo Fin End If If False = bDebug And bFichierExiste(sCheminPS) Then Kill sCheminPS bQuitter = True ' Pas d'erreur, on quitte glb_bSucces = True Fin: ' Dans tous les cas on supprime le fichier snp pour signaler une erreur ' et ne pas attendre indéfiniment du coté d'Access If False = bDebug And bFichierExiste(sCheminSNP) Then Kill sCheminSNP Me.MousePointer = vbDefault If bQuitter Then Unload Me Exit Sub Erreur: AfficherMsg "Erreur !" Me.MousePointer = vbDefault AfficherMsgErreur Err, "ConvertirEnPdf" Resume Fin End Sub Private Sub AfficherMsg(ByVal sMsg$) Me.lblInfo.Caption = sMsg DoEvents End Sub Constantes (modConstantes.bas) Option Explicit Public Const sTitreMsg$ = "Snap2Pdf" ' Pour pouvoir localiser la ligne ayant provoqué une erreur, mettre bTrapErr = False Public Const bTrapErr As Boolean = True ' Récupérer les erreurs Public Const bDebug As Boolean = False Public Const sPiloteImprimantePostScript$ = "Apple Color LaserWriter 12/600" Public Const sCheminProgramFileGhostScript$ = "\GhostScriptPdf\gs8.14\bin\gswin32c.exe" Public Const sNomProcessConvertisseur$ = "gswin32c.exe" Public Const sClasseSnapShotViewerControl$ = "snpvw.Contrôle Snapshot Viewer.1" Public Const sFichierPS$ = "tmp.ps" Public Const sFichierPdf$ = "tmp.pdf" Public Const sFichierSNP$ = "tmp.snp" ModMain (modMain.bas) Option Explicit Public glb_bSucces As Boolean ' Retourner un code de sortie pour Snap2Pdf pour le programme appelant Private Declare Sub ExitProcess Lib "kernel32" (ByVal uExitCode As Long) Private Sub Main() ' On peut démarrer l'application sur la feuille, ou bien sur la procédure ' Main() si on veut pouvoir détecter l'absence de l'ocx sans plantage ' Vérifier la présence de tous les composants glb_bSucces = False If False = bVerifierComposants() Then GoTo Fin 'frmSnap2Pdf.Show ' Afficher le formulaire principal frmSnap2Pdf.Show vbModal ' Afficher le formulaire principal et attendre Fin: ' Attention : dans l'IDE, ExitProcess quitte aussi VB6 ! If bDebug Then Exit Sub If bIDE() Then Exit Sub Dim lCodeRetour& lCodeRetour = lCodeRetourEchec If glb_bSucces Then lCodeRetour = lCodeRetourSucces ExitProcess lCodeRetour End Sub Private Function bVerifierComposants() As Boolean ' Vérifier la présence du fichier SnapShot à convertir Dim sCheminSNP$ sCheminSNP = App.Path & "\" & sFichierSNP If False = bFichierExiste(sCheminSNP, bPrompt:=True) Then Exit Function ' Vérifier l'installation du SnapshotViewer : snapview.ocx ' CLASSID = "CLSID:F0E42D60-368C-11D0-AD81-00A0C90DC8D9" ' "snpvw.Snapshot Viewer Control.1" : installation eng ' "snpvw.Contrôle Snapshot Viewer.1" : installation fr ' Chemin pour une installation par défaut avec Office 2003 ' "C:\Program Files\Fichiers communs\Microsoft Shared\Snapshot Viewer\SNAPVIEW.OCX" ' Chemin pour une installation du package autonome Snapshot Viewer ' "C:\Program Files\Snapshot Viewer\SNAPVIEW.EXE et C:\Windows\System32\SNAPVIEW.OCX" If False = bVerifierInstallObjet(sClasseSnapShotViewerControl) Then MsgBox "Le contrôle ActiveX Snapshot Viewer (SnapView.ocx) n'est pas installé !", _ vbCritical, sTitreMsg Exit Function End If Dim sProgFile$, sCheminGhostScript$ ' Liste des variables d'environnement 'http://forums.aspfree.com/t26406/s.html sProgFile = Environ("ProgramFiles") ' Vérifier si l'interpreteur PostScript est installé (GhostScript) sCheminGhostScript = sProgFile & "\GhostScriptPdf\gs8.14\bin\gswin32c.exe" If False = bFichierExiste(sCheminGhostScript, bPrompt:=True) Then Exit Function ' Vérifier si le pilote d'impression PostScript est installé Dim i% For i = 0 To VB.Printers.Count - 1 If VB.Printers(i).DeviceName = sPiloteImprimantePostScript Then bVerifierComposants = True Exit Function End If Next i MsgBox "Le pilote d'imprimante PostScript '" & _ sPiloteImprimantePostScript & "'" & vbLf & _ "n'est pas installé !", vbCritical, sTitreMsg End Function ShellWait (modShellWait.bas) Option Explicit ' LANCER UNE COMMANDE DOS ET ATTENDRE LA FIN ' www.vbfrance.com/code.aspx?id=4878 ' Modifié par Patrice Dargenton pour lire de code de retour ' Permet de faire une pause dans le code: Sleep 5000 (pause de 5 secondes) ' (pour laisser le temps à un process DOS de s'executer par exemple) Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ' API d'ouverture de Process. Private Declare Function OpenProcess Lib "kernel32" _ (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _ ByVal dwProcessId As Long) As Long ' API de fermeture de Process. Private Declare Function TerminateProcess Lib "kernel32" _ (ByVal hProcess As Long, ByVal uExitCode As Long) As Long Private Declare Function CloseHandle Lib "kernel32" _ (ByVal hObject As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32" _ (ByVal hProcess As Long, lpExitCode As Long) As Long Private Const PROCESS_QUERY_INFORMATION = &H400 Private Const STILL_ACTIVE = &H103 ' 259 ' Code standard pour fin avec succès Public Const lCodeRetourSucces& = 0 ' Codes arbitraires : je n'ai pas trouvé la liste des Exit codes ' en tout cas ils doivent être différents de STILL_ACTIVE = 259 Public Const lCodeRetourEchec& = 1 Public Const lCodeRetourDelaiDepasse& = 2 Public Function bShellWait(sShell$, _ Optional ByVal eWindowStyle As VBA.VbAppWinStyle = vbNormalFocus, _ Optional ByRef sError$, _ Optional ByRef lCodeRetour&, _ Optional ByVal lDelaiMaxSec& = 3600) As Boolean On Error GoTo Erreur lCodeRetour = lCodeRetourEchec Dim hProcess& ' On peut aussi passer par l'application associée à une extension de fichier : ' voir la version dans Snap2PdfDemo.mdb ' ShellExecute ne permet pas de retrouver le handle du processus à attendre ' mais ShellExecuteEx fonctionne bien si on ajoute 2 ou 3 bricoles en plus : ' NtQueryInformationProcess SHELLEXECUTEINFO ShellExecuteEx... ' en tout cas pour Win2k & XP, et pour Win95 et Win98, voir ici : ' http://planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=1102 hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, _ Shell(sShell, eWindowStyle)) If hProcess = 0 Then ' Impossible de lancer la ligne de commande ! sError = "Le programme n'a pu être lancé, vérifiez votre ligne de commande." Else Dim lSecondes& lSecondes = 0 Do ' Récupération du statut du process, ' on vérifie s'il est terminé (lCodeRetour <> STILL_ACTIVE). GetExitCodeProcess hProcess, lCodeRetour ' Pause en attendant la fin de notre commande sans ' géner l'execution des autres process. If lSecondes <= lDelaiMaxSec Then Attendre 1000 lSecondes = lSecondes + 1 Else ' Trop long ! Dim lRet& Call TerminateProcess(hProcess, lRet) ' 26/03/2006 : If faut aussi fermer dans les autres cas ! 'Call CloseHandle(hProcess) sError = "Trop long : Le processus a été stoppé..." lRet = lCodeRetourDelaiDepasse End If Loop While lCodeRetour = STILL_ACTIVE End If Call CloseHandle(hProcess) ' 26/03/2006 bShellWait = False If lCodeRetour = lCodeRetourSucces Then bShellWait = True Exit Function Erreur: sError = Err.Description Exit Function End Function Public Sub Attendre(Optional ByVal lMilliSec& = 200) Sleep lMilliSec DoEvents End Sub Utilitaires (modUtil.bas) Option Explicit Public Function bFichierExiste(sFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre sFiltre est trouvé If sFiltre = "" Then Exit Function On Error Resume Next bFichierExiste = (Len(Dir$(sFiltre)) > 0) If Err.Number <> 0 Then bFichierExiste = False Err.Clear On Error GoTo 0 If False = bFichierExiste And bPrompt Then _ MsgBox "Impossible de trouver le fichier :" & vbLf & sFiltre, _ vbCritical, sTitreMsg & " - Fichier introuvable" End Function Public Function bVerifierInstallObjet(sClasse$) As Boolean ' Vérifier si un composant ActiveX est installé (s'il peut être instancié sans erreur) On Error Resume Next Dim oObjetQcq As Object Set oObjetQcq = CreateObject(sClasse) If Err <> 0 Then Err.Clear: GoTo Fin End If bVerifierInstallObjet = True Fin: Set oObjetQcq = Nothing End Function Public Sub AfficherMsgErreur(Erreur As Object, Optional sTitreFct$ = "", _ Optional sInfo$ = "", Optional sDetailMsgErr$ = "") Const vbDefault% = 0 If Screen.MousePointer <> vbDefault Then Screen.MousePointer = vbDefault Dim sMsg$ If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg = sMsg & vbCrLf & sInfo If Erreur.Number Then sMsg = sMsg & vbCrLf & "Err n°" & Str$(Erreur.Number) & " :" sMsg = sMsg & vbCrLf & Erreur.Description End If If sDetailMsgErr <> "" Then sMsg = sMsg & vbCrLf & sDetailMsgErr MsgBox sMsg, vbCritical, sTitreMsg End Sub Public Function bIDE() As Boolean ' Retourner True si on est en mode debug dans l'IDE, sinon False (mode compilé .exe) ' (bIDE = IsIDE = Not IsCompiled) ' www.vbarchiv.net/forum/id2_i68236t68232.html On Error Resume Next Debug.Print 1 / 0 bIDE = (Err <> 0) On Error GoTo 0 End Function