Doc2Pdf v2.0.1.*
Table des procédures 1 - AssemblyInfo.vb 2 - frmDoc2Pdf.vb 2.1 - Private Function bInitialisation 2.2 - Private Function bVerifierComposants 2.3 - Private Sub AfficherMsg 2.4 - Private Sub AfficherNouveauMessage 2.5 - Private Sub cmdAjouterMenuCtx_Click 2.6 - Private Sub cmdEnleverMenuCtx_Click 2.7 - Private Sub frmDoc2Pdf_Shown 2.8 - Private Sub VerifierMenuCtx 3 - modConstantes.vb 4 - modMain.vb 4.1 - Public Sub Main 5 - modWord_LT.vb 5.1 - <System.Diagnostics.DebuggerStepThrough()> Private Function bFixerImprimanteActive 5.2 - <System.Diagnostics.DebuggerStepThrough()> Private Function bLireImpressionArrierePlan 5.3 - <System.Diagnostics.DebuggerStepThrough()> Private Function bLireOrdreInverse 5.4 - Private Function bFixerImpressionArrierePlan 5.5 - Private Function bFixerOrdreInverse 5.6 - Private Function bLireImprimanteActive 5.7 - Private Sub QuitterWord 5.8 - Public Sub ConvertirEnPdf 6 - clsAfficherMsg.vb 6.1 - Public Delegate Sub GestEvAfficherAvancement 6.2 - Public Delegate Sub GestEvAfficherFEC 6.3 - Public Delegate Sub GestEvAfficherMessage 6.4 - Public Delegate Sub GestEvSablier 6.5 - Public Delegate Sub GestEvTick 6.6 - Public ReadOnly Property bDesactiver 6.7 - Public ReadOnly Property iNumFichierEnCours% 6.8 - Public ReadOnly Property lAvancement 6.9 - Public ReadOnly Property sMessage$ 6.10 - Public ReadOnly Property sMessage$ 6.11 - Public Sub AfficherAvancement 6.12 - Public Sub AfficherFichierEnCours 6.13 - Public Sub AfficherMsg 6.14 - Public Sub New 6.15 - Public Sub New 6.16 - Public Sub New 6.17 - Public Sub New 6.18 - Public Sub New 6.19 - Public Sub New 6.20 - Public Sub New 6.21 - Public Sub New 6.22 - Public Sub Sablier 6.23 - Public Sub Tick 7 - modShellWait.vb 7.1 - Public Function bShellWait 7.2 - Public Sub Attendre 8 - modUtil.vb 8.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible 8.2 - Public Function asArgLigneCmd 8.3 - Public Function bAppliDejaOuverte 8.4 - Public Function bChoisirFichier 8.5 - Public Function bCreerObjet 8.6 - Public Function bFichierExiste 8.7 - Public Function sExtraireCheminSansExtension$ 8.8 - Public Sub AfficherMsgErreur2 8.9 - Public Sub CopierPressePapier 8.10 - Public Sub Sablier 8.11 - Public Sub TraiterMsgSysteme_DoEvents 9 - modUtilReg.vb 9.1 - Public Function asListeSousClesCU 9.2 - Public Function bAjouterMenuContextuel 9.3 - Public Function bAjouterTypeFichier 9.4 - Public Function bCleRegistreCRExiste 9.5 - Public Function bCleRegistreCUExiste 9.6 - Public Function bCleRegistreLMExiste AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle( _ "Doc2Pdf : Convertir un document Word en Pdf via un pilote d'imprimante PostScript")> <Assembly: AssemblyDescription( _ "Doc2Pdf : Convertir un document Word en Pdf via un pilote d'imprimante PostScript par Patrice Dargenton")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("Doc2Pdf")> <Assembly: AssemblyCopyright("Copyright © 2009 ORS Production")> <Assembly: AssemblyTrademark("Doc2Pdf")> <Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("2.0.1.*")> frmDoc2Pdf.vb ' 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 2.01 du 14/08/2009 ' Version 1.02 du 26/03/2006 ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' d pour Date ' u pour Unsigned (non signé : entier positif) ' a pour Array (tableau) : () ' o pour Object : objet instancié localement ' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ ' Fichier frmDoc2Pdf.vb : ' --------------------- 'Imports Microsoft.VisualBasic.PowerPacks.Printing.Compatibility.VB6 ' Pour PrinterCollection Friend Class frmDoc2Pdf : Inherits Form Private m_asCheminsDoc$() ' Tableau de chemins de fichiers Word à convertir en Pdf Private m_iNumFichierMax% ' Numéro du dernier fichier à convertir Private m_sCheminGhostScript$ = "" Private WithEvents m_msgDelegue As clsMsgDelegue = New clsMsgDelegue #Region "Initialisations" Private Sub frmDoc2Pdf_Shown(ByVal sender As Object, ByVal e As EventArgs) _ Handles Me.Shown If Not bInitialisation() Then Exit Sub ConvertirEnPdf(m_asCheminsDoc, m_sCheminGhostScript, m_msgDelegue) Me.Close() End Sub Private Sub AfficherMsg(ByVal sMsg$) Me.lblInfo.Text = sMsg Windows.Forms.Application.DoEvents() End Sub Private Sub AfficherNouveauMessage(ByVal sender As Object, _ ByVal e As clsMsgEventArgs) Handles m_msgDelegue.EvAfficherMessage Me.AfficherMsg(e.sMessage) End Sub Private Function bInitialisation() As Boolean AfficherMsg("") If Not bVerifierComposants(m_sCheminGhostScript) Then Exit Function ' Ne fonctionne pas avec des chemins contenant des espaces, même entre guillemets 'Dim asArgs$() = Environment.GetCommandLineArgs() Dim sArg$ = Microsoft.VisualBasic.Interaction.Command() 'If bDebug And sArg.Length > 0 Then _ ' MsgBox("Arguments : " & sArg, MsgBoxStyle.Information, sTitreMsg) m_iNumFichierMax = -1 'AnalyserFichiers: If sArg.Length > 0 Then m_asCheminsDoc = asArgLigneCmd(sArg) If Not IsNothing(m_asCheminsDoc) Then _ m_iNumFichierMax = m_asCheminsDoc.GetUpperBound(0) 'If bDebug Then ' For i As Integer = 0 To m_iNumFichierMax ' MsgBox("Argument traité n°" & i + 1 & " : " & m_asCheminsDoc(i), _ ' MsgBoxStyle.Information, sTitreMsg) ' Next i 'End If ' Aucun paramètre : choisir un fichier dans ce cas If m_iNumFichierMax = -1 Then ' Ces deux instructions donne le même résultat 'Dim sInitDir$ = My.Application.Info.DirectoryPath Dim sInitDir$ = Application.StartupPath Dim sCheminDoc$ = "" ' Si on annule alors afficher les boutons pour les menus contextuels If Not bChoisirFichier(sCheminDoc, sMsgFiltreDoc, ".doc", _ sMsgTitreBoiteDlg, sInitDir) Then GoTo MenuContext ' Multifichiers : Les fichiers ne sont pas présentés pareil, ' ce sera pour une autre fois... 'sArg = sCheminDoc 'GoTo AnalyserFichiers ReDim m_asCheminsDoc(0) m_asCheminsDoc(0) = sCheminDoc m_iNumFichierMax = 0 End If bInitialisation = True Exit Function MenuContext: Me.lblInfo.Visible = False Me.chkHtml.Visible = True Me.cmdAjouterMenuCtx.Visible = True Me.cmdEnleverMenuCtx.Visible = True VerifierMenuCtx() End Function Private Function bVerifierComposants(ByRef sCheminGhostScript$) As Boolean ' Vérifier si tous les composants nécessaires à Doc2Pdf sont bien présents ' Liste des variables d'environnement 'http://forums.aspfree.com/t26406/s.html Dim sProgFile$ = Environ("ProgramFiles") ' Vérifier si l'interpreteur PostScript est installé (GhostScript) sCheminGhostScript = sProgFile & sCheminProgramFileGhostScript If Not bFichierExiste(sCheminGhostScript, bPrompt:=True) Then MsgBox("L'interpréteur PostScript (GhostScript : gs814w32.exe)" & _ " n'est pas installé dans \Program File\GhostScriptPdf", _ MsgBoxStyle.Critical, sTitreMsg) Exit Function End If bVerifierComposants = True : Exit Function ' Vérifier si le pilote d'impression PostScript est installé ' Printers requiert une référence à la dll : ' C:\Program Files\Fichiers communs\Microsoft Shared\Visual Basic Power Packs\1.1\Microsoft.VisualBasic.PowerPacks.VS.dll ' et Microsoft.VisualBasic.PowerPacks.Vs.resources.dll ' Imports Microsoft.VisualBasic.PowerPacks.Printing.Compatibility.VB6 ' Pour PrinterCollection ' Sinon il suffit de traiter l'erreur dans bFixerImprimanteActive : ' c'est plus simple, car cela évite d'avoir à distribuer les dll 'For i As Integer = 0 To Printers.Count - 1 ' If 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é !", MsgBoxStyle.Critical, sTitreMsg) End Function #End Region #Region "Gestion des menus contextuels" ' Voir aussi : http://www.codeproject.com/KB/dotnet/System_File_Association.aspx Private Sub cmdAjouterMenuCtx_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdAjouterMenuCtx.Click Dim sCheminExe$ = Application.ExecutablePath Const bPrompt As Boolean = False Const sChemin$ = """%1""" bAjouterMenuContextuel(sMenuCtx_TypeFichierWord, sMenuCtx_CleCmdConvertirEnPdf, _ bPrompt, , sMenuCtx_CleCmdConvertirEnPdfDescription, sCheminExe, _ sChemin) If Me.chkHtml.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierHtml, sMenuCtx_CleCmdConvertirEnPdf, _ bPrompt, , sMenuCtx_CleCmdConvertirEnPdfDescription, sCheminExe, sChemin) VerifierMenuCtx() End Sub Private Sub cmdEnleverMenuCtx_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdEnleverMenuCtx.Click bAjouterMenuContextuel(sMenuCtx_TypeFichierWord, sMenuCtx_CleCmdConvertirEnPdf, _ bEnlever:=True, bPrompt:=False) If Me.chkHtml.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierHtml, sMenuCtx_CleCmdConvertirEnPdf, _ bEnlever:=True, bPrompt:=False) VerifierMenuCtx() End Sub Private Sub VerifierMenuCtx() Dim sCleDescriptionCmd$ = sMenuCtx_TypeFichierWord & "\shell\" & _ sMenuCtx_CleCmdConvertirEnPdf Me.cmdAjouterMenuCtx.Enabled = False Me.cmdEnleverMenuCtx.Enabled = True If Not bCleRegistreCRExiste(sCleDescriptionCmd) Then Me.cmdAjouterMenuCtx.Enabled = True Me.cmdEnleverMenuCtx.Enabled = False Me.chkHtml.Enabled = True ' Autoriser à cocher Else ' Si la clé existe pour .doc, voir s'il faut enlever aussi celle pour .html Dim sCleDescriptionCmdHtml$ = sMenuCtx_TypeFichierHtml & "\shell\" & _ sMenuCtx_CleCmdConvertirEnPdf Me.chkHtml.Checked = bCleRegistreCRExiste(sCleDescriptionCmdHtml) Me.chkHtml.Enabled = False ' Interdire de décocher End If End Sub #End Region End Class modConstantes.vb ' Fichier Constantes.vb ' --------------------- Module Constantes Public Const sTitreMsg$ = "Doc2Pdf" #If DEBUG Then Public Const bDebug As Boolean = True Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bRelease As Boolean = True #End If 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" ' Format avec bChoisirUnFichierAPI : '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 & "*.*" ' Format avec bChoisirFichier : Public Const sMsgFiltreDoc$ = _ "Document Word (*.doc)|*.doc|" & _ "Document Html (*.htm ou *.html) : web|*.htm*|" & _ "Document Texte (*.txt) : bloc-notes Windows|*.txt|" & _ "Autre document (*.*)|*.*" '"Tous les fichiers (*.*)|*.*" Public Const sMsgTitreBoiteDlg$ = sTitreMsg & _ " - Veuillez choisir un document Word a convertir en Pdf" ' Menus contextuels Public Const sMenuCtx_TypeFichierWord$ = "Word.Document.8" Public Const sMenuCtx_TypeFichierHtml$ = "htmlfile" Public Const sMenuCtx_CleCmdConvertirEnPdf$ = "ConvertirEnPdf" Public Const sMenuCtx_CleCmdConvertirEnPdfDescription$ = "Convertir en Pdf" End Module modMain.vb ' Fichier modMain.vb ' ------------------ Module modMain Public Sub Main() ' Si l'application est déjà ouverte (depuis n'importe où : bMemeExe:=False) ' alors quitter ' Non : si on utilise le menu Envoyer vers, alors on peut envoyer ' plusieurs documents à imprimer et on reçoit bien la liste ' dans la même instance de Doc2Pdf (fiable ?) 'If bAppliDejaOuverte(bMemeExe:=False) Then Exit Sub frmDoc2Pdf.ShowDialog() End Sub End Module modWord_LT.vb ' Fichier modWord_LT.vb : Module de gestion de Word en Liaison Tardive ' --------------------- Option Strict Off ' Pour compiler en Liaison Tardive Module modWord_LT Private Const sClasseObjetWord$ = "Word.Application" Private Const wdDoNotSaveChanges% = 0 #Region "Lecture et écriture des propriétés de Word" Private Function bLireImprimanteActive(ByVal oWrd As Object, _ ByRef sImprimanteActive$) As Boolean Try sImprimanteActive = oWrd.ActivePrinter bLireImprimanteActive = True Catch End Try End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Private Function bFixerImprimanteActive(ByVal oWrd As Object, _ ByVal sImprimanteActive$) As Boolean Try ' Si on fixe l'imprimante active, c'est qu'on a déjà pu la lire ' on considère que la lire est fiable, reste à écrire If oWrd.ActivePrinter <> sImprimanteActive Then _ oWrd.ActivePrinter = sImprimanteActive bFixerImprimanteActive = True Catch ex As Exception 'Debug.WriteLine(ex.ToString) AfficherMsgErreur2(ex, "bFixerImprimanteActive", _ "Impossible de changer l'imprimante active !", _ "Cause possible : l'imprimante [" & sImprimanteActive & "]" & vbLf & _ "n'est pas installée, ou bien changement interdit.") 'MsgBox("Le pilote d'imprimante PostScript '" & _ ' sPiloteImprimantePostScript & "'" & vbLf & _ ' "n'est pas installé !", MsgBoxStyle.Critical, sTitreMsg) End Try End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Private Function bLireOrdreInverse(ByVal oWrd As Object, _ ByRef bOrdreInverse As Boolean) As Boolean Try bOrdreInverse = oWrd.Application.Options.PrintReverse bLireOrdreInverse = True Catch End Try End Function Private Function bFixerOrdreInverse(ByVal oWrd As Object, _ ByVal bOrdreInverse As Boolean) As Boolean Try oWrd.Application.Options.PrintReverse = bOrdreInverse bFixerOrdreInverse = True Catch End Try End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Private Function bLireImpressionArrierePlan(ByVal oWrd As Object, _ ByRef bImpressionArrierePlan As Boolean) As Boolean Try bImpressionArrierePlan = oWrd.Application.Options.PrintBackground bLireImpressionArrierePlan = True Catch ex As Exception Debug.WriteLine(ex) End Try End Function Private Function bFixerImpressionArrierePlan(ByVal oWrd As Object, _ ByVal bImpressionArrierePlan As Boolean) As Boolean Try oWrd.Application.Options.PrintBackground = False bFixerImpressionArrierePlan = True Catch End Try End Function #End Region Public Sub ConvertirEnPdf(ByVal asCheminsDoc$(), ByVal sCheminGhostScript$, _ ByVal msgDelegue As clsMsgDelegue) ' Convertir un ou plusieurs documents Word en Pdf Sablier() msgDelegue.AfficherMsg("Lancement de Word...") Dim oWrd As Object = Nothing If Not bCreerObjet(oWrd, sClasseObjetWord) Then GoTo Quitter ' D'abord mémoriser l'imprimante active msgDelegue.AfficherMsg("Vérification de l'imprimante en cours...") Dim sImprimanteActive$ = "" If Not bLireImprimanteActive(oWrd, sImprimanteActive) Then GoTo QuitterWord ' Ensuite fixer l'imprimante PostScript ' "Apple LaserWriter 12/640 PS" msgDelegue.AfficherMsg("Configuration de l'imprimante...") If Not bFixerImprimanteActive(oWrd, sPiloteImprimantePostScript) Then GoTo QuitterWord ' 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) Dim bOrdreInverse, bImpressionArrierePlan As Boolean Dim bOrdreInverseLisible As Boolean = bLireOrdreInverse(oWrd, bOrdreInverse) Dim bImpressionArrierePlanLisible As Boolean = _ 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) Dim bAttendreFinImp As Boolean = False ' Si on ne sait pas si l'option est activée, alors attendre If Not bImpressionArrierePlanLisible Then bAttendreFinImp = True ' Si l'option est activée et qu'on ne peut pas la désactiver, alors attendre If bImpressionArrierePlan And Not bImpressionArrierePlanFixable Then _ bAttendreFinImp = True Dim sOperationEnCours$ = "" Try Dim iNumFichierMax% = asCheminsDoc.GetUpperBound(0) For i As Integer = 0 To iNumFichierMax Dim sCheminDoc$ = asCheminsDoc(i) If Not bFichierExiste(sCheminDoc) Then GoTo FichierSuivant Dim sBaseFichier$ = sExtraireCheminSansExtension(sCheminDoc) Dim sCheminPostScript$ = sBaseFichier & "ps" Dim sCheminPdf$ = sBaseFichier & "pdf" Dim sFichierCourant$ = vbLf & i + 1 & "/" & _ iNumFichierMax + 1 & " : " & sCheminDoc & " ..." sOperationEnCours = "Ouverture du document à convertir :" & sFichierCourant msgDelegue.AfficherMsg(sOperationEnCours & "...") oWrd.Documents.Open(sCheminDoc, ReadOnly:=True) ' Penser à ReadOnly pour Word 2007 sOperationEnCours = _ "Impression du fichier sur l'imprimante PostScript :" & sFichierCourant msgDelegue.AfficherMsg(sOperationEnCours & "...") 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 If bAttendreFinImp Then ' Si le fichier .ps n'est pas accessible, c'est que l'impression est en cours Const iDelaiMaxSec% = 120 Dim i0% = 0 Do While True i0 += 1 If i0 > iDelaiMaxSec Then Exit Do msgDelegue.AfficherMsg(Now & " : Attente impression en cours...") If bFichierAccessible(sCheminPostScript) Then Exit Do Threading.Thread.Sleep(1000) Loop End If sOperationEnCours = "Fermeture document" msgDelegue.AfficherMsg(sOperationEnCours & "...") oWrd.ActiveDocument.Close(SaveChanges:=wdDoNotSaveChanges) ' Lancer la conversion et attendre la fin du processus Const sGm$ = """" Dim sCmd$ = sCheminGhostScript & _ " -q -dSAFER -dNOPAUSE -dBATCH -sDEVICE=pdfwrite" & _ " -sOutputFile=" & sGm & sCheminPdf & sGm & _ " -c .setpdfwrite -f " & sGm & sCheminPostScript & sGm Dim sMsgErr$ = "" ' Au cas où il y ait un espace dans le chemin Dim iOption% = AppWinStyle.Hide If bDebug Then iOption = AppWinStyle.NormalFocus ' vbNormalFocus pour voir la boîte DOS sFichierCourant = vbLf & i + 1 & "/" & _ iNumFichierMax + 1 & " : " & sCheminPdf & " ..." sOperationEnCours = "Conversion en Pdf en cours :" & sFichierCourant msgDelegue.AfficherMsg(sOperationEnCours & "...") If Not bShellWait(sCmd, iOption, sMsgErr) Then MsgBox("Impossible de convertir le fichier PostScript en Pdf !" & vbLf & _ sMsgErr, MsgBoxStyle.Critical, sTitreMsg) GoTo Fin End If ' Supprimer le fichier intermédiaire PostScript une fois converti en Pdf If Not bDebug Then If bFichierExiste(sCheminPostScript) Then Kill(sCheminPostScript) End If End If msgDelegue.AfficherMsg("Conversion terminée : " & sCheminPdf) FichierSuivant: Next i Catch ex As Exception AfficherMsgErreur2(ex, "ConvertirEnPdf", "Etape : " & sOperationEnCours) Finally msgDelegue.AfficherMsg("Configuration de l'imprimante...") ' 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 ' Rétablir l'imprimante précédente bFixerImprimanteActive(oWrd, sImprimanteActive) End Try Fin: QuitterWord: msgDelegue.AfficherMsg("Fermeture de Word...") QuitterWord(oWrd) Quitter: Sablier(bDesactiver:=True) End Sub Private Sub QuitterWord(ByRef oWrd As Object) ' Quitter Word en rétablissant les options précédentes If IsNothing(oWrd) Then Exit Sub ' En DotNet il faut utiliser une classe pour gérer les pb. d'applications ' office qui peuvent rester en RAM après avoir quitter ' (à cause du ramasse-miette non déterministe de DotNet) ' voir ici : http://www.vbfrance.com/code.aspx?id=27541 ' mais comme on quitte l'application à la fin, le pb ne se pose pas ici Try oWrd.Quit(SaveChanges:=wdDoNotSaveChanges) oWrd = Nothing Catch 'ex As Exception End Try End Sub End Module clsAfficherMsg.vb ' Fichier clsAfficherMsg.vb : Classes de gestion des messages via des délégués ' ------------------------- Public Class clsTickEventArgs : Inherits EventArgs ' Classe pour l'événement Tick : avancement d'une unité de temps : TIC-TAC ' utile pour mettre à jour l'heure en cours, ou pour scruter une annulation Public Sub New() End Sub End Class Public Class clsMsgEventArgs : Inherits EventArgs ' Classe pour l'événement Message Private m_sMsg$ = "" 'Nothing Public Sub New(ByVal sMsg$) 'If sMsg Is Nothing Then Throw New NullReferenceException If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property End Class Public Class clsFECEventArgs : Inherits EventArgs ' Classe pour l'événement Fichier En Cours (FEC) Private m_iNumFichierEnCours% = 0 Public Sub New(ByVal iNumFichierEnCours%) Me.m_iNumFichierEnCours = iNumFichierEnCours End Sub Public ReadOnly Property iNumFichierEnCours%() Get Return Me.m_iNumFichierEnCours End Get End Property End Class Public Class clsAvancementEventArgs : Inherits EventArgs ' Classe pour l'événement Avancement Private m_sMsg$ = "" Private m_lAvancement& = 0 Public Sub New(ByVal sMsg$) If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public Sub New(ByVal lAvancement&) Me.m_lAvancement = lAvancement End Sub Public Sub New(ByVal lAvancement&, ByVal sMsg$) Me.m_lAvancement = lAvancement If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property Public ReadOnly Property lAvancement&() Get Return Me.m_lAvancement End Get End Property End Class Public Class clsSablierEventArgs : Inherits EventArgs ' Classe pour l'événement Sablier Private m_bDesactiver As Boolean = False Public Sub New(ByVal bDesactiver As Boolean) Me.m_bDesactiver = bDesactiver End Sub Public ReadOnly Property bDesactiver() As Boolean Get Return Me.m_bDesactiver End Get End Property End Class Public Class clsMsgDelegue ' Classe de gestion des messages via des délégués Public Delegate Sub GestEvTick(ByVal sender As Object, _ ByVal e As clsTickEventArgs) Public Event EvTick As GestEvTick Public Delegate Sub GestEvAfficherMessage(ByVal sender As Object, _ ByVal e As clsMsgEventArgs) Public Event EvAfficherMessage As GestEvAfficherMessage Public Delegate Sub GestEvAfficherFEC(ByVal sender As Object, _ ByVal e As clsFECEventArgs) Public Event EvAfficherNumFichierEnCours As GestEvAfficherFEC Public Delegate Sub GestEvAfficherAvancement(ByVal sender As Object, _ ByVal e As clsAvancementEventArgs) Public Event EvAfficherAvancement As GestEvAfficherAvancement Public Delegate Sub GestEvSablier(ByVal sender As Object, _ ByVal e As clsSablierEventArgs) Public Event EvSablier As GestEvSablier Public m_bAnnuler As Boolean Public Sub New() End Sub Public Sub AfficherMsg(ByVal sMsg$) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvAfficherMessage(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFichierEnCours(ByVal iNumFichierEnCours%) Dim e As New clsFECEventArgs(iNumFichierEnCours) RaiseEvent EvAfficherNumFichierEnCours(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherAvancement(ByVal lAvancement&, ByVal sMsg$) Dim e As New clsAvancementEventArgs(lAvancement, sMsg) RaiseEvent EvAfficherAvancement(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub Tick() Dim e As New clsTickEventArgs() RaiseEvent EvTick(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub Sablier(Optional ByVal bDesactiver As Boolean = False) Dim e As New clsSablierEventArgs(bDesactiver) RaiseEvent EvSablier(Me, e) TraiterMsgSysteme_DoEvents() End Sub End Class modShellWait.vb ' Fichier ShellWait.vb ' -------------------- Module ShellWait ' LANCER UNE COMMANDE DOS ET ATTENDRE LA FIN ' http://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%) ' API d'ouverture de Process. Private Declare Function OpenProcess% Lib "kernel32" ( _ ByVal dwDesiredAccess%, ByVal bInheritHandle%, ByVal dwProcessId%) ' API de fermeture de Process. Private Declare Function TerminateProcess% Lib "kernel32" ( _ ByVal hProcess%, ByVal uExitCode%) Private Declare Function CloseHandle% Lib "kernel32" (ByVal hObject%) Private Declare Function GetExitCodeProcess% Lib "kernel32" ( _ ByVal hProcess%, ByRef lpExitCode%) Private Const PROCESS_QUERY_INFORMATION% = &H400 Private Const STILL_ACTIVE% = &H103 ' 259 ' Code standard pour fin avec succès Public Const iCodeRetourSucces% = 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 iCodeRetourEchec% = 1 Public Const iCodeRetourDelaiDepasse% = 2 Public Function bShellWait(ByVal sShell$, _ Optional ByVal eWindowStyle As AppWinStyle = AppWinStyle.NormalFocus, _ Optional ByRef sError$ = "", _ Optional ByRef iCodeRetour% = 0, _ Optional ByVal iDelaiMaxSec% = 3600) As Boolean Dim hProcess% = 0 Try iCodeRetour = iCodeRetourEchec ' 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, CInt(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 iRet% = 0 Dim iSecondes% = 0 Do ' Récupération du statut du process, ' on vérifie s'il est terminé (iCodeRetour <> STILL_ACTIVE) GetExitCodeProcess(hProcess, iCodeRetour) ' Pause en attendant la fin de notre commande sans ' géner l'exécution des autres process ' iDelaiMaxSec = 0 : boucle infine If iSecondes <= iDelaiMaxSec Or iDelaiMaxSec = 0 Then Attendre(1000) iSecondes += 1 Else ' Trop long ! ' http://msdn.microsoft.com/en-us/library/ms686714(VS.85).aspx TerminateProcess(hProcess, iRet) sError = "Trop long : Le processus a été stoppé..." iRet = iCodeRetourDelaiDepasse End If Loop While iCodeRetour = STILL_ACTIVE End If bShellWait = False If iCodeRetour = iCodeRetourSucces Then bShellWait = True Catch ex As Exception sError = ex.Message Finally If hProcess <> 0 Then Try CloseHandle(hProcess) Catch 'ex As Exception End Try End If End Try End Function Public Sub Attendre(Optional ByVal iMilliSec% = 200) ' Voir aussi : Threading.Thread.Sleep(iMilliSec) Sleep(iMilliSec) System.Windows.Forms.Application.DoEvents() End Sub End Module modUtil.vb ' Fichier Utilitaires.vb ' ---------------------- Module Utilitaires Public Sub Sablier(Optional ByVal bDesactiver As Boolean = False) If bDesactiver Then Cursor.Current = Cursors.Default Else Cursor.Current = Cursors.WaitCursor End If End Sub Public Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub Public Function bCreerObjet(ByRef oObjetQcq As Object, ByVal sClasse$) As Boolean ' Instancier un contrôle ActiveX en liaison tardive (à l'exécution) Try oObjetQcq = CreateObject(sClasse) bCreerObjet = True Catch Err As Exception AfficherMsgErreur2(Err, "bCreerObjet", _ "L'objet de classe [" & sClasse & "] ne peut pas être créé") oObjetQcq = Nothing End Try End Function Public Function bFichierExiste(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt bFichierExiste = IO.File.Exists(sCheminFichier) If Not bFichierExiste And bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _ MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable") End Function Public Function sExtraireCheminSansExtension$(ByVal sChemin$) ' Extraire le chemin d'un fichier sans extension, en conservant le . ' (sans la dernière extension s'il y en a plusieurs) ' Ex. C:\Tmp\MonDoc.doc -> C:\Tmp\MonDoc. sExtraireCheminSansExtension = "" If sChemin.Length = 0 Then Exit Function Dim iPos% = sChemin.LastIndexOf(".") If iPos = -1 Then sExtraireCheminSansExtension = sChemin & "." : Exit Function sExtraireCheminSansExtension = sChemin.Substring(0, iPos + 1) End Function Public Function asArgLigneCmd(ByVal sFichiers$) As String() ' Retourner les arguments de la ligne de commande Dim asArgs$() = Nothing 'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg ' Parser les noms cours : facile 'asArgs = Split(Command, " ") ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : "" ' une fois le nom traité, les guillemets sont enlevés ' S'il y a un non court parmi eux, il n'est pas entre guillemets Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim iNbArg%, sFichier$, sSepar$ Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong 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 += 1 ' Bug corrigé : iDeb2 + 1 et non iDeb2 + 2 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 += 1 End If If bFin Or iFin = iLen Then Exit Do iDeb = iFin + 1 If bNomLong Then iDeb = iFin + 2 Loop Const iCodeGuillemets% = 34 Dim iNumArg% For iNumArg = 0 To UBound(asArgs) asArgs(iNumArg) = Trim$(asArgs(iNumArg)) Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide If Len(sArg) = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" End If Next iNumArg asArgLigneCmd = asArgs End Function Public Const sCauseErrPoss$ = _ "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Public Function bFichierAccessible(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False, _ Optional ByVal bPromptFermer As Boolean = False, _ Optional ByVal bInexistOk As Boolean = False, _ Optional ByVal bPromptRetenter As Boolean = False, _ Optional ByVal bLectureSeule As Boolean = False) As Boolean ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple) If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas If Not bFichierExiste(sCheminFichier) Then ' Et ne pas alerter non plus bFichierAccessible = True Exit Function End If Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Exit Function End If End If Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Try ' Si Excel a verrouillé le fichier, même une simple ouverture n'est pas permise Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open) fs.Close() End Using bFichierAccessible = True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", _ "Impossible d'accéder au fichier :" & vbLf & _ sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ If bLectureSeule Then ' Le verrouillage Excel peut ralentir une lecture ODBC, ' mais sinon la lecture directe n'est pas possible, même avec ' IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read ' (sauf si le fichier a l'attribut lecture seule) reponse = MsgBox( _ "Veuillez fermer S.V.P. le fichier :" & vbLf & _ sCheminFichier & sQuestion, msgbs, sTitreMsg) Else reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & _ sCheminFichier & vbLf & _ "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & _ "ses attributs de protection, ou alors les droits d'accès." & _ sQuestion, msgbs, sTitreMsg) End If End If End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _ Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(ByVal sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub Public Function bAppliDejaOuverte(ByVal bMemeExe As Boolean) As Boolean ' Détecter si l'application est déja lancée : ' - depuis n'importe quelle copie de l'exécutable, ou bien seulement ' - depuis le même emplacement du fichier exécutable sur le disque dur Dim sExeProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.ModuleName Dim sNomProcessAct$ = IO.Path.GetFileNameWithoutExtension(sExeProcessAct) If Not bMemeExe Then ' Détecter si l'application est déja lancée depuis n'importe quel exe If Process.GetProcessesByName(sNomProcessAct).Length > 1 Then _ bAppliDejaOuverte = True Exit Function End If ' Détecter si l'application est déja lancée depuis le même exe Dim sCheminProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.FileName Dim aProcessAct As Diagnostics.Process() = Process.GetProcessesByName(sNomProcessAct) Dim processAct As Diagnostics.Process Dim iNbApplis% = 0 For Each processAct In aProcessAct Dim sCheminExe$ = processAct.MainModule.FileName If sCheminExe = sCheminProcessAct Then iNbApplis += 1 Next If iNbApplis > 1 Then bAppliDejaOuverte = True End Function Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _ ByVal sTitre$, Optional ByVal sInitDir$ = "") As Boolean ' Afficher une boite de dialogue pour choisir un fichier Static bInit As Boolean = False Dim ofd As New OpenFileDialog With ofd If Not bInit Then bInit = True If sInitDir = "" Then .InitialDirectory = Application.StartupPath Else .InitialDirectory = sInitDir End If End If .CheckFileExists = True .DefaultExt = sExtDef .Filter = sFiltre .Multiselect = False .Title = sTitre .ShowDialog() If .FileName <> "" Then bChoisirFichier = True : sCheminFichier = .FileName End With End Function End Module modUtilReg.vb ' Fichier modUtilReg.vb : Module de gestion de la base de registre ' --------------------- Imports Microsoft.Win32 Module modUtilReg ' Microsoft Win32 to Microsoft .NET Framework API Map : Registry Functions ' http://msdn.microsoft.com/en-us/library/aa302340.aspx#win32map_registryfunctions Public Function bAjouterTypeFichier(ByVal sExtension$, ByVal sTypeFichier$, _ Optional ByVal sDescriptionExtension$ = "", _ Optional ByVal bEnlever As Boolean = False) As Boolean ' Ajouter(/Enlever) dans la base de registre un type de fichier ClassesRoot ' pour associer une extension de ficier à une application par défaut ' (via le double-clic ou bien le menu contextuel Ouvrir) ' Exemple : associer .dat à mon application.exe Try If bEnlever Then If bCleRegistreCRExiste(sExtension) Then Registry.ClassesRoot.DeleteSubKeyTree(sExtension) End If Else If Not bCleRegistreCRExiste(sExtension) Then Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sExtension) rk.SetValue("", sTypeFichier) If sDescriptionExtension.Length > 0 Then rk.SetValue("Content Type", sDescriptionExtension) End If End Using 'rk.Close() End If End If bAjouterTypeFichier = True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterTypeFichier") End Try End Function Public Function bAjouterMenuContextuel(ByVal sTypeFichier$, ByVal sCmd$, _ Optional ByVal bPrompt As Boolean = True, _ Optional ByVal bEnlever As Boolean = False, _ Optional ByVal sDescriptionCmd$ = "", _ Optional ByVal sCheminExe$ = "", _ Optional ByVal sCmdDef$ = """%1""", _ Optional ByVal sDescriptionTypeFichier$ = "") As Boolean ' Ajouter un menu contextuel dans la base de registre ' de type ClassesRoot : fichier associé à une application standard ' Exemple : ajouter le menu contextuel "Convertir en Html" sur les fichiers projet VB6 ' sTypeFichier = "VisualBasic.Project" ' sCmd = "ConvertirEnHtml" ' sDescriptionCmd = "Convertir en Html" ' sCheminExe = "C:\Program Files\VB2Html\VB2Html.exe" Try ' D'abord vérifier si la clé principale existe If Not bCleRegistreCRExiste(sTypeFichier) Then If bEnlever Then bAjouterMenuContextuel = True : Exit Function Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sTypeFichier) If sDescriptionTypeFichier.Length > 0 Then rk.SetValue("", sDescriptionTypeFichier) End If End Using End If Dim sCleDescriptionCmd$ = sTypeFichier & "\shell\" & sCmd If bEnlever Then If bCleRegistreCRExiste(sCleDescriptionCmd) Then Registry.ClassesRoot.DeleteSubKeyTree(sCleDescriptionCmd) If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été enlevé avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, sTitreMsg) Else If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "est introuvable dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", _ MsgBoxStyle.Information, sTitreMsg) End If bAjouterMenuContextuel = True Exit Function End If Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd) rk.SetValue("", sDescriptionCmd) End Using 'rk.Close() Dim sCleCmd$ = sTypeFichier & "\shell\" & sCmd & "\command" Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleCmd) ' Ajouter automatiquement des guillemets " si le chemin contient au moins un espace If sCheminExe.IndexOf(" ") > -1 Then _ sCheminExe = """" & sCheminExe & """" rk.SetValue("", sCheminExe & " " & sCmdDef) End Using 'rk.Close() If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été ajouté avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", MsgBoxStyle.Information, sTitreMsg) bAjouterMenuContextuel = True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterMenuContextuel") End Try End Function Public Function bCleRegistreCRExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "") As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey( _ sCle & "\\" & sSousCle) If IsNothing(rkCRCle) Then Exit Function End Using ' rkCRCle.Close() est automatiquement appelé bCleRegistreCRExiste = True Catch End Try End Function Public Function bCleRegistreLMExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "", _ Optional ByRef sValSousCle$ = "", _ Optional ByVal sNouvValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé LocalMachine existe dans la base de registre sValSousCle = "" Try Dim bEcriture As Boolean = False If sNouvValSousCle.Length > 0 Then bEcriture = True ' Si la clé n'existe pas, on passe dans le Catch Using rkLMCle As RegistryKey = Registry.LocalMachine.OpenSubKey(sCle, _ writable:=bEcriture) Dim oVal As Object = rkLMCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Exit Function Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Exit Function sValSousCle = sValSousCle0 If bEcriture Then oVal = CInt(sNouvValSousCle) rkLMCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord) End If End Using ' rkLMCle.Close() est automatiquement appelé bCleRegistreLMExiste = True ' On peut lire cette clé, donc elle existe Catch End Try End Function Public Function bCleRegistreCUExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "", _ Optional ByRef sValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé CurrentUser existe dans la base de registre ' et si oui renvoyer la valeur de la sous-clé sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) Dim oVal As Object = rkCUCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Exit Function Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Exit Function sValSousCle = sValSousCle0 End Using ' rkCUCle.Close() est automatiquement appelé bCleRegistreCUExiste = True ' On peut lire cette clé, donc elle existe Catch End Try End Function Public Function asListeSousClesCU(ByVal sCle$) As String() ' Renvoyer la liste des sous-clés de type CurrentUser asListeSousClesCU = Nothing Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) If IsNothing(rkCUCle) Then Exit Function asListeSousClesCU = rkCUCle.GetSubKeyNames End Using ' rkCUCle.Close() est automatiquement appelé Catch End Try End Function End Module