Doc2Pdf v1.0.3Table des procédures 1 - frmDoc2Pdf (frmDoc2Pdf.frm) 1.1 - Private Function bFixerImpressionArrierePlan 1.2 - Private Function bFixerOrdreInverse 1.3 - Private Function bLireImpressionArrierePlan 1.4 - Private Function bLireOrdreInverse 1.5 - Private Function bVerifierComposants 1.6 - Private Sub AfficherMsg 1.7 - Private Sub ConvertirEnPdf 1.8 - Private Sub Form_Activate 1.9 - Private Sub QuitterWord 1.10 - Private Sub Sablier 2 - Constantes (modConstantes.bas) 3 - ModMain (modMain.bas) 3.1 - Private Function GetPreviousWindow 3.2 - Private Sub DisplayWindow 3.3 - Private Sub Main 4 - SelectionFichier (modSelectionFichier.bas) 4.1 - Public Function bChoisirUnFichier 4.2 - Public Function bChoisirUnFichierAPI 5 - ShellWait (modShellWait.bas) 5.1 - Public Function bShellWait 5.2 - Public Sub Attendre 6 - Utilitaires (modUtil.bas) 6.1 - Public Function asArgLigneCmd 6.2 - Public Function bCreerObjet 6.3 - Public Function bFichierExiste 6.4 - Public Function bTableauVide 6.5 - Public Function sExtraireCheminSansExtension$ 6.6 - Public Sub AfficherMsgErreur frmDoc2Pdf (frmDoc2Pdf.frm) Option Explicit ' Doc2Pdf : Convertir un document Word en Pdf via un pilote d'imprimante PostScript ' www.vbfrance.com/code.aspx?ID=29662 ' Documentation : Doc2Pdf.html ' http://patrice.dargenton.free.fr/CodesSources/Doc2Pdf.html ' http://patrice.dargenton.free.fr/CodesSources/Doc2Pdf.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.03 du 14/08/2009 ' Version 1.02 du 26/03/2006 Private m_asCheminsDoc$() ' Tableau de chemins de fichiers Word à convertir en Pdf Private m_iNumFichierMax% ' Numéro du dernier fichier à convertir Private Sub Form_Activate() Static bEnCours As Boolean If bEnCours Then Exit Sub bEnCours = True AfficherMsg "" If False = bVerifierComposants() Then Exit Sub If bDebug And Command$ <> "" Then _ MsgBox "Arguments : " & Command, vbInformation, sTitreMsg m_iNumFichierMax = -1 Dim sFichiers$ sFichiers = Command$ AnalyserFichiers: m_asCheminsDoc() = asArgLigneCmd(sFichiers) If False = bTableauVide(m_asCheminsDoc) Then _ m_iNumFichierMax = UBound(m_asCheminsDoc()) If bDebug Then Dim i% For i = 0 To m_iNumFichierMax MsgBox "Argument traité n°" & i + 1 & " : " & m_asCheminsDoc(i), _ vbInformation, sTitreMsg Next i End If ' Aucun paramètre : choisir un fichier dans ce cas If m_iNumFichierMax = -1 Then Dim sInitDir$, sCheminDoc$ sInitDir = App.Path sCheminDoc = "" If False = bChoisirUnFichierAPI(sCheminDoc, sMsgFiltreDoc, _ sMsgTitreBoiteDlg, sInitDir, Me.hwnd, bMultiSelect:=False) Then Exit Sub ' Les fichiers ne sont pas présentés pareil, ce sera pour une autre fois... 'sFichiers = sCheminDoc 'GoTo AnalyserFichiers ReDim m_asCheminsDoc(0) m_asCheminsDoc(0) = sCheminDoc m_iNumFichierMax = 0 End If ConvertirEnPdf Unload Me End Sub Private Sub AfficherMsg(ByVal sMsg$) Me.lblInfo.Caption = sMsg DoEvents End Sub Private Sub Sablier(Optional bDesactiver As Boolean) If bDesactiver Then Me.MousePointer = vbDefault Else Me.MousePointer = vbHourglass End If End Sub Private Function bVerifierComposants() As Boolean ' Vérifier si tous les composants nécessaires à Doc2Pdf sont bien présents 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 & sCheminProgramFileGhostScript 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 Private Function bLireOrdreInverse(oWrd As Object, ByRef bOrdreInverse As Boolean) As Boolean On Error GoTo Erreur bOrdreInverse = oWrd.Application.Options.PrintReverse bLireOrdreInverse = True Erreur: Exit Function End Function Private Function bFixerOrdreInverse(oWrd As Object, _ ByVal bOrdreInverse As Boolean) As Boolean On Error GoTo Erreur oWrd.Application.Options.PrintReverse = bOrdreInverse bFixerOrdreInverse = True Erreur: Exit Function End Function Private Function bLireImpressionArrierePlan(oWrd As Object, _ ByRef bImpressionArrierePlan As Boolean) As Boolean On Error GoTo Erreur bImpressionArrierePlan = oWrd.Application.Options.PrintBackground bLireImpressionArrierePlan = True Erreur: Exit Function End Function Private Function bFixerImpressionArrierePlan(oWrd As Object, _ ByVal bImpressionArrierePlan As Boolean) As Boolean On Error GoTo Erreur oWrd.Application.Options.PrintBackground = False bFixerImpressionArrierePlan = True Erreur: Exit Function End Function Private Sub ConvertirEnPdf() ' Convertir un ou plusieurs documents Word en Pdf If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 Sablier Dim i%, sCheminDoc$, sBaseFichier$, sCheminPostScript$, sCheminPdf$ Dim bOrdreInverse As Boolean, bImpressionArrierePlan As Boolean Dim bOrdreInverseLisible As Boolean, bImpressionArrierePlanLisible As Boolean Dim oWrd As Object, sImprimanteActive$, sFichierCourant$ sImprimanteActive = "" AfficherMsg "Lancement de Word..." If False = bCreerObjet(oWrd, sClasseObjetWord) Then GoTo Fin ' D'abord mémoriser l'imprimante active sImprimanteActive = oWrd.ActivePrinter ' Ensuite fixer l'imprimante PostScript ' "Apple LaserWriter 12/640 PS" AfficherMsg "Configuration de l'imprimante..." oWrd.ActivePrinter = sPiloteImprimantePostScript ' Ensuite lire les options actives ou pas ' Mémoriser les paramètres d'impression pour pouvoir les rétablir après ' Noter l'état de l'option de l'ordre d'impression des pages ' (l'ordre inversé permet de faire du Recto-Verso sur une imprimante classique) bOrdreInverseLisible = bLireOrdreInverse(oWrd, bOrdreInverse) bImpressionArrierePlanLisible = bLireImpressionArrierePlan(oWrd, bImpressionArrierePlan) ' Ensuite voir si on peut désactiver celles qui sont activées ' Modifier les paramètres d'impression ' Ne pas inverser l'ordre des pages Dim bOrdreInverseFixable As Boolean bOrdreInverseFixable = False If bOrdreInverseLisible And bOrdreInverse Then _ bOrdreInverseFixable = bFixerOrdreInverse(oWrd, False) ' Cette ligne oblige Doc2Pdf à attendre que Word ait fini l'impression en cours ' (technique trouvée en cherchant Word isPrinting avec Google dans les forums) Dim bImpressionArrierePlanFixable As Boolean If bImpressionArrierePlanLisible And bImpressionArrierePlan Then _ bImpressionArrierePlanFixable = bFixerImpressionArrierePlan(oWrd, False) For i = 0 To m_iNumFichierMax sCheminDoc = m_asCheminsDoc(i) If False = bFichierExiste(sCheminDoc) Then GoTo FichierSuivant sBaseFichier = sExtraireCheminSansExtension(sCheminDoc) sCheminPostScript = sBaseFichier & "ps" sCheminPdf = sBaseFichier & "pdf" sFichierCourant = vbLf & i + 1 & "/" & m_iNumFichierMax + 1 & _ " : " & sCheminDoc & " ..." AfficherMsg "Ouverture du document à convertir :" & sFichierCourant 'oWrd.Documents.Open sCheminDoc oWrd.Documents.Open sCheminDoc, ReadOnly:=True ' Penser à ReadOnly pour Word 2007 AfficherMsg "Impression du fichier sur l'imprimante PostScript :" & sFichierCourant oWrd.Application.PrintOut FileName:=sCheminDoc, OutputFileName:=sCheminPostScript ' Test CutePdf : "CutePDF Writer" ' le convertisseur PostScript n'est pas appelé : ' CutePdf ne supporte pas l'automation ? 'oWrd.Application.PrintOut FileName:=sCheminDoc, OutputFileName:=sCheminPdf oWrd.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges 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 & sCheminProgramFileGhostScript If False = bFichierExiste(sCheminGhostScript, bPrompt:=True) Then GoTo Fin ' Lancer la conversion et attendre la fin du processus sCmd = sCheminGhostScript & _ " -q -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite" & _ " -sOutputFile=" & sGm & sCheminPdf & sGm & _ " -c .setpdfwrite -f " & sGm & sCheminPostScript & sGm Dim lOption&, sMsgErr$ sMsgErr = "" lOption = vbHide If bDebug Then lOption = vbNormalFocus ' vbNormalFocus pour voir la boîte DOS sFichierCourant = vbLf & i + 1 & "/" & m_iNumFichierMax + 1 & " : " & _ sCheminPdf & " ..." AfficherMsg "Conversion en Pdf en cours :" & sFichierCourant If False = bShellWait(sCmd, lOption, sMsgErr) Then MsgBox "Impossible de convertir le fichier PostScript en Pdf !" & vbLf & _ sMsgErr, vbCritical, sTitreMsg GoTo Fin End If ' Supprimer le fichier intermédiaire PostScript une fois converti en Pdf If False = bDebug Then If bFichierExiste(sCheminPostScript) Then Kill sCheminPostScript AfficherMsg "Conversion terminée : " & sCheminPdf FichierSuivant: Next i Fin: ' En cas d'erreur, rétablir quand même les options AfficherMsg "Configuration de l'imprimante..." If oWrd.ActivePrinter <> sImprimanteActive Then _ oWrd.ActivePrinter = sImprimanteActive ' Rétablir l'imprimante précédente ' Rétablir les options d'impression If bOrdreInverseFixable And bOrdreInverseLisible Then If bOrdreInverse Then bFixerOrdreInverse oWrd, bOrdreInverse End If If bImpressionArrierePlanFixable And bImpressionArrierePlanLisible Then If bImpressionArrierePlan Then bFixerImpressionArrierePlan oWrd, bImpressionArrierePlan End If AfficherMsg "Fermeture de Word..." QuitterWord oWrd, bTrapErr:=True Sablier bDesactiver:=True Exit Sub Erreur: AfficherMsg "Erreur !" 'Me.MousePointer = vbDefault If Err = 5216 Then ' Imprimante inconnue MsgBox "Le pilote d'imprimante PostScript '" & _ sPiloteImprimantePostScript & "'" & vbLf & _ "n'est pas installé !", vbCritical, sTitreMsg Else AfficherMsgErreur Err, "ConvertirEnPdf" End If Resume Fin End Sub Private Sub QuitterWord(oWrd As Object, ByVal bTrapErr As Boolean) ' Quitter Word en rétablissant les options précédentes If oWrd Is Nothing Then Exit Sub ' En cas d'erreur, empecher une nouvelle erreur If bTrapErr Then On Error Resume Next oWrd.Quit SaveChanges:=wdDoNotSaveChanges Set oWrd = Nothing If bTrapErr Then Err.Clear: On Error GoTo 0 End Sub Constantes (modConstantes.bas) Option Explicit Public Const sTitreMsg$ = "Doc2Pdf" ' 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" '"Apple LaserWriter 12/640 PS" 'Public Const sCheminProgramFileGhostScript$ = "\GhostScriptPdf\gs8.14\bin\gswin32c.exe" Public Const sCheminProgramFileGhostScript$ = "\GhostScriptPdf\gs8.70\bin\gswin32c.exe" Public Const sNomProcessConvertisseur$ = "gswin32c.exe" Public Const sMsgFiltreDoc$ = _ "Document Word (*.doc)" & vbNullChar & "*.doc" & vbNullChar & _ "Document Html (*.htm ou *.html) : web" & vbNullChar & "*.htm*" & vbNullChar & _ "Document Texte (*.txt) : bloc-notes Windows" & vbNullChar & "*.txt" & vbNullChar & _ "Autre document (*.*)" & vbNullChar & "*.*" Public Const sMsgTitreBoiteDlg$ = sTitreMsg & _ " - Veuillez choisir un document Word a convertir en Pdf" Public Const sClasseObjetWord$ = "Word.Application" Public Const wdDoNotSaveChanges& = 0 ModMain (modMain.bas) Option Explicit ' Comment n'autoriser qu'une seule instance de mon application ? ' Auteur : Romain Puyfoulhoux ' http://vb.developpez.com/faq/?page=Divers#singleton ' Certaines applications n'acceptent d'être ouverte qu'une seule fois. ' Si l'on essaie de l'ouvrir une deuxième fois, la fenêtre de la première ' instance repasse en premier plan et est restaurée si nécessaire. ' Pour tester le code ci-dessous, créez un projet et ajoutez une form. ' Son nom est Form1 par défaut. Ajoutez ensuite le code ci-dessous dans un ' module standard. Enfin, sélectionnez "Sub Main" comme objet de démarrage ' dans les propriétés du projet. Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _ (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindow Lib "user32" _ (ByVal hwnd As Long, ByVal wCmd As Long) As Long Private Declare Function ShowWindow Lib "user32" _ (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long Private Declare Function SetForegroundWindow Lib "user32" _ (ByVal hwnd As Long) As Long Private Const SW_RESTORE = 9 Private Const GW_HWNDPREV = 3 Private Sub Main() Dim lngHandle As Long 'Cherche une fenêtre qui serait déjà ouverte lngHandle = GetPreviousWindow If lngHandle > 0 Then 'fenêtre trouvée, on l'affiche DisplayWindow lngHandle Else frmDoc2Pdf.Show End If End Sub Private Function GetPreviousWindow() As Long Dim strTitre As String Dim lngHwnd As Long 'Sauvegarde le titre de l'application et le modifie 'sinon on trouverait toujours une instance de l'application : 'celle qui vient d'être lancée strTitre = App.Title App.Title = "---" & App.Title 'Récupère le handle de la fenêtre principale (invisible) ' Explication de ThunderRT6Main : ' www.oreilly.com/catalog/subhookvb/chapter/ch01.html lngHwnd = FindWindow("ThunderRT6Main", strTitre) 'Obtient le handle de la fenêtre visible If lngHwnd > 0 Then GetPreviousWindow = GetWindow(lngHwnd, GW_HWNDPREV) 'Restaure le titre original App.Title = strTitre End Function Private Sub DisplayWindow(ByVal lngHandle As Long) ShowWindow lngHandle, SW_RESTORE SetForegroundWindow lngHandle End Sub SelectionFichier (modSelectionFichier.bas) Option Explicit ' Sélection d'un fichier (à cause de la limite du MSComDlg.CommonDialog) Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _ "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Private Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type ' Liste des constantes : http://access.developpez.com/faq/?page=AstucesTabl Public Const OFN_AllowMultiSelect& = &H200 Public Const OFN_FileMustExist& = &H1000 Public Const OFN_EXPLORER& = &H80000 Public Function bChoisirUnFichierAPI(ByRef sFichier$, sFiltre$, sTitre$, _ sInitDir$, lHandelWnd&, Optional ByVal bMultiSelect As Boolean = False) As Boolean Dim OpenFile As OPENFILENAME Dim lRet& OpenFile.lStructSize = Len(OpenFile) OpenFile.hwndOwner = lHandelWnd OpenFile.lpstrFilter = sFiltre OpenFile.nFilterIndex = 1 OpenFile.lpstrFile = String$(257, 0) OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1 OpenFile.lpstrFileTitle = OpenFile.lpstrFile OpenFile.nMaxFileTitle = OpenFile.nMaxFile ' Ne pas réinitialiser le répertoire par défaut si on ne le demande pas If sInitDir <> "" Then OpenFile.lpstrInitialDir = sInitDir OpenFile.lpstrTitle = sTitre OpenFile.flags = OFN_FileMustExist If bMultiSelect Then OpenFile.flags = OpenFile.flags Or _ OFN_AllowMultiSelect Or OFN_EXPLORER lRet = GetOpenFileName(OpenFile) If lRet = 0 Then sFichier = "" Else sFichier = Trim$(OpenFile.lpstrFile) ' Enlever les caractères null à la fin If False = bMultiSelect Then Dim iPos% iPos = InStr(sFichier, vbNullChar) If iPos Then sFichier = Left$(sFichier, iPos - 1) End If bChoisirUnFichierAPI = True End If End Function Public Function bChoisirUnFichier(ByRef sFichier$) As Boolean Dim oDLG As Object ' Ce contrôle ne marche que si VB6 est installé sur le poste client ' c'est une (idiote) restriction de licence On Error GoTo Erreur 'Err.Raise 429 ' Test traitement d'err si VB6 n'est pas installé Set oDLG = CreateObject("MSComDlg.CommonDialog") With oDLG .InitDir = App.Path .DialogTitle = "Choisir une base de données Access" .Filter = "Base de données MS-Access (*.mdb)|*.mdb" .MaxFileSize = 255 .flags = .flags Or &H1000 ' FileMustExist (OFN_FILEMUSTEXIST) .ShowOpen If .FileName <> "" Then sFichier = .FileName: bChoisirUnFichier = True End With Set oDLG = Nothing Exit Function Erreur: If Err = 429 Then AfficherMsgErreur Err, "bChoisirUnFichier", _ "L'environnement Visual Basic 6 ou Visual Studio 6 est requis", _ "Il n'y a pas de licence valide pour ce contrôle" Else AfficherMsgErreur Err, "bChoisirUnFichier" End If Err.Clear 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 ' Autre solution basée sur ShellExecuteEx au lieu de OpenProcess : ' http://www.vbfrance.com/code.aspx?ID=34867 ' 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 : ' 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. ' iDelaiMaxSec = 0 : boucle infine If lSecondes <= lDelaiMaxSec Or lDelaiMaxSec = 0 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 If hProcess <> 0 Then 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 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 bCreerObjet(ByRef oObjetQcq As Object, sClasse$) As Boolean On Error Resume Next Set oObjetQcq = CreateObject(sClasse) If Err <> 0 Then AfficherMsgErreur Err, "bCreerObjet", _ "L'objet de classe [" & sClasse & "] ne peut pas être créé", vbCritical Err.Clear: Set oObjetQcq = Nothing: GoTo Fin End If bCreerObjet = True Fin: On Error GoTo 0 End Function 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 sExtraireCheminSansExtension$(sChemin$) ' Extraire le chemin d'un fichier sans extension, en conservant le . ' (sans la dernière extension s'il y en a plusieurs) sExtraireCheminSansExtension = "" If sChemin = "" Then Exit Function Dim i%, iLen% iLen = Len(sChemin) For i = iLen To 1 Step -1 If Mid$(sChemin, i, 1) = "." Then sExtraireCheminSansExtension = Left$(sChemin, i) Exit For End If Next i End Function Public Function asArgLigneCmd(sFichiers$) As String() ' Retourner les arguments de la ligne de commande ' Voir aussi : Commande du menu contextuel pour récupérer ' les chemins d'une sélection de fichiers dans l'explorateur ' www.vbfrance.com/code.aspx?ID=36426 Dim iNbArg%, asArgs$() Dim sGm$, sFichier$, sSepar$, bNomLong As Boolean sGm = Chr$(34) ' Guillemets 'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg ' Parser les noms cours : facile 'asArgs = Split(Command, " ") ' Parser les noms longs (fonctionne quelque soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : " ' une fois le nom traité, les guillemets sont enlevé ' S'il y a un non court parmi eu, il n'est pas entre guillemets Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2%, bFin As Boolean sCmd = sFichiers 'Command$ iLen = Len(sCmd) iDeb = 1 Do bNomLong = False: sSepar = " " ' Si le premier caractère est un guillement, c'est un nom long If Mid$(sCmd, iDeb, 1) = sGm Then bNomLong = True: sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong Then iDeb2 = iDeb2 + 1 ' 10/9/2005 : iDeb2+1 au lieu de +2 (cf. AccessBackup) iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True: iFin = iLen + 1 sFichier = Trim$(Mid$(sCmd, iDeb2, iFin - iDeb2)) If sFichier <> "" Then ReDim Preserve asArgs(iNbArg) asArgs(iNbArg) = sFichier iNbArg = iNbArg + 1 End If If bFin Or iFin = iLen Then Exit Do iDeb = iFin + 1 If bNomLong Then iDeb = iFin + 2 Loop asArgLigneCmd = asArgs End Function Public Function bTableauVide(aString$()) As Boolean ' Renvoyer True si le tableau est vide On Error Resume Next Dim iArgMin% iArgMin = LBound(aString()) If Err > 0 Then bTableauVide = True On Error GoTo 0 Err.Clear End Function