VBSpamCheck v1.0.1.*
Table des procédures 1 - AssemblyInfo.vb 2 - frmVBSpamCheck.vb 2.1 - Private Function bEcrireDomaines 2.2 - Private Function bEcrireExped 2.3 - Private Sub AfficherMsg 2.4 - Private Sub AfficherNouveauMessage 2.5 - Private Sub chkDbxRef_CheckedChanged 2.6 - Private Sub ChoisirDbx 2.7 - Private Sub cmdAjouterMenuCtx_Click 2.8 - Private Sub cmdAnnuler_Click 2.9 - Private Sub cmdEnleverMenuCtx_Click 2.10 - Private Sub cmdLancer_Click 2.11 - Private Sub cmdParcourir_Click 2.12 - Private Sub Depart 2.13 - Private Sub EvAnalyserChamp 2.14 - Private Sub EvChampDepart 2.15 - Private Sub EvCourriel 2.16 - Private Sub frmDbx2Txt_Load 2.17 - Private Sub frmDbx2Txt_Shown 2.18 - Private Sub GestionDepart 2.19 - Private Sub GestionDomaines 2.20 - Private Sub GestionExped 2.21 - Private Sub IndexerDomaine 2.22 - Private Sub IndexerExped 2.23 - Private Sub InitHashTable 2.24 - Private Sub lbMenu_DoubleClick 2.25 - Private Sub lbMenu_SelectedIndexChanged 2.26 - Private Sub tbDbx_DoubleClick 2.27 - Private Sub tbDbx_TextChanged 2.28 - Private Sub VerifierMenuCtx 2.29 - Public Sub LireDomainesRef 2.30 - Public Sub LireExpedRef 3 - clsDbx.vb 3.1 - Private Function bLireCourriel 3.2 - Private Function bLireEnteteCourriel 3.3 - Private Function bLireEnteteListe 3.4 - Private Function bVerifierIndex 3.5 - Private Function iCompterElementsListe% 3.6 - Private Function iValListe% 3.7 - Private Function sDecoderIso$ 3.8 - Private Function sExtraireDomaine$ 3.9 - Private Function sRemplacerIso$ 3.10 - Private Function sRemplacerTexteIso$ 3.11 - Private Function sTraiterCloudMark$ 3.12 - Private Function sTraiterVirguleFin$ 3.13 - Private Sub AfficherMsg 3.14 - Private Sub AnalyserChamps 3.15 - Private Sub ExtraireCourriel 3.16 - Private Sub InitChamps 3.17 - Private Sub TraiterListeChps 3.18 - Public Sub Initialisation 3.19 - Public Sub LireFichierDBX 4 - modDepart.vb 4.1 - Private Sub Depart 4.2 - Public Sub Main 5 - clsAfficherMsg.vb 5.1 - Public Delegate Sub GestEvAfficherMessage 5.2 - Public ReadOnly Property sMessage$ 5.3 - Public Sub AfficherMsg 5.4 - Public Sub New 5.5 - Public Sub New 6 - modUtilFichier.vb 6.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible 6.2 - Public Function asArgLigneCmd 6.3 - Public Function bAjouterFichier 6.4 - Public Function bAjouterFichier 6.5 - Public Function bChoisirFichier 6.6 - Public Function bCopierArbo 6.7 - Public Function bCopierFichier 6.8 - Public Function bDeplacerDossier 6.9 - Public Function bDeplacerFichiers2 6.10 - Public Function bDeplacerFichiers3 6.11 - Public Function bDossierExiste 6.12 - Public Function bEcrireFichier 6.13 - Public Function bEcrireFichier 6.14 - Public Function bFichierExiste 6.15 - Public Function bFichierExisteFiltre 6.16 - Public Function bReencoder 6.17 - Public Function bRenommerDossier 6.18 - Public Function bRenommerFichier 6.19 - Public Function bSupprimerDossier 6.20 - Public Function bSupprimerFichier 6.21 - Public Function bSupprimerFichiersFiltres 6.22 - Public Function bVerifierCreerDossier 6.23 - Public Function iNbFichiersFiltres% 6.24 - Public Function sbLireFichier 6.25 - Public Function sCheminRelatif$ 6.26 - Public Function sConvNomDos$ 6.27 - Public Function sDossierParent$ 6.28 - Public Function sEnleverSlashFinal$ 6.29 - Public Function sEnleverSlashInitial$ 6.30 - Public Function sExtraireChemin$ 6.31 - Public Function sFormaterNumerique$ 6.32 - Public Function sFormaterNumerique2$ 6.33 - Public Function sFormaterTailleOctets$ 6.34 - Public Function sLecteurDossier$ 6.35 - Public Function sLireFichier$ 6.36 - Public Function sNomDossierFinal$ 6.37 - Public Function sNomDossierParent$ 6.38 - Public Sub OuvrirAppliAssociee 6.39 - Public Sub ProposerOuvrirFichier 7 - modUtilitaire.vb 7.1 - Public Function bAppliDejaOuverte 7.2 - Public Function dVerifierDate 7.3 - Public Function iConv% 7.4 - Public Function iConvHexa% 7.5 - Public Function iConvUInt% 7.6 - Public Function lDecalage 7.7 - Public Function rConv! 7.8 - Public Function rConvStrEnReel! 7.9 - Public Function sValeurPtDecimal$ 7.10 - Public Function sValeurPtDecimal$ 7.11 - Public Sub AfficherMsgErreur2 7.12 - Public Sub CopierPressePapier 7.13 - Public Sub TraiterMsgSysteme_DoEvents 8 - modUtilReg.vb 8.1 - Public Function asListeSousClesCU 8.2 - Public Function bAjouterMenuContextuel 8.3 - Public Function bCleRegistreCRExiste 8.4 - Public Function bCleRegistreCUExiste 8.5 - Public Function bCleRegistreLMExiste AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("VBSpamCheck")> <Assembly: AssemblyDescription( _ "VBSpamCheck : Récupérer les courriels légitimes dans une base de spam Dbx (Outlook Express)")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("VBSpamCheck")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2008")> <Assembly: AssemblyTrademark("VBSpamCheck")> <Assembly: AssemblyVersion("1.0.1.*")> frmVBSpamCheck.vb ' Fichier frmVBSpamCheck : ' ---------------------- ' http://www.vbfrance.com/code.aspx?ID=??? ' Documentation : VBSpamCheck.html : ' http://patrice.dargenton.free.fr/CodesSources/VBSpamCheck.html ' http://patrice.dargenton.free.fr/CodesSources/VBSpamCheck.vbproj.html ' Version 1.01 du 26/01/2008 ' Par Patrice Dargenton : mailto: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 ' 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 ' ... ' ------------------------------------ Imports System.IO Imports System.Text ' Pour StringBuilder Public Class frmVBSpamCheck #Region "Interface" Private Const sCheminDBX_Def$ = "" Private Const iCodeMenuDef% = 0 ' ExtraireDomaines 'Private Const iCodeMenuDef% = 1 ' CompleterDomaines 'Private Const iCodeMenuDef% = 2 ' VerifierDomaines 'Private Const iCodeMenuDef% = 3 ' AfficherDomaines 'Private Const iCodeMenuDef% = 4 ' ExtraireCourriel Public m_sCheminDBX$, m_sCodeMenu$ #End Region #Region "Déclarations" Private m_sCheminCourant$ = "" Private m_bInit, m_bAuto, m_bQuitter, m_bBaseRef As Boolean Private WithEvents msgDelegue As clsMsgDelegue = New clsMsgDelegue Private WithEvents m_oDbx As New clsDbx Private m_sbFP As StringBuilder Private Const sDossierExport$ = "\Export" ' Domaines et Expéditeur Private m_bExtraireDomainesEtExped, m_bVerifierDomainesEtExped As Boolean Private Const sSeparChp$ = vbTab ' ";" ' Domaine avec le courriel de l'expéditeur : clé pour les faux positifs ' m_htDCL : sCle = ic.sMsgID_Domaine & ":" & ic.sExpediteurCourriel ' Courriel d'expéditeur : Simplement pour trier les domaines par fréquence ' d'un expéditeur via son courriel, tout domaine cumulé ' m_htCourrielsExp : sCle = ic.sExpediteurCourriel ' Expéditeur complet : autre clé pour les faux positifs ' m_htExped : sCle = ic.sExpediteurComplet Private m_htCourrielsExp, m_htDCL, m_htExped As Hashtable Private m_bFauxPositifs As Boolean Private Const sFichierFP$ = "FauxPositifs.txt" Private Const sFichierDomaineRef$ = "Domaines.txt" ' Domaines légitimes Private Const sFichierExpedRef$ = "Expediteurs.txt" ' Expéditeurs légitimes Private Const sCodeMenu_ExtraireDomaines$ = "ED" '0 Private Const sCodeMenu_CompleterDomaines$ = "CD" '1 Private Const sCodeMenu_VerifierDomaines$ = "VD" '2 Private Const sCodeMenu_AfficherDomaines$ = "AD" '3 Private Const sCodeMenu_ExtraireCourriel$ = "EM" '4 Private Const sMenu_ExtraireDomaines$ = "Extraire les domaines" ' ED Private Const sMenu_CompleterDomaines$ = "Compléter les domaines" ' CD Private Const sMenu_VerifierDomaines$ = "Vérifier les domaines" ' VD Private Const sMenu_AfficherDomaines$ = "Afficher les domaines" ' AD Private Const sMenu_ExtraireCourriel$ = "Extraire un courriel" ' EM Private Const sFormatDateHeure$ = "dd/MM/yyyy HH:mm" ' Menus contextuels Private Const sMenuCtx_TypeFichierDbx$ = ".dbx" Private Const sMenuCtx_TypeFichierDbxDescription$ = _ "Base de courriels Outlook Express (fichier .dbx)" Private Const sMenuCtx_CleCmdOuvrir$ = "Open" Private Const sMenuCtx_CleCmdOuvrirDescription$ = "Ouvrir avec VBSpamCheck" Private Const sMenuCtx_CleCmdExtraireDomaines$ = "ExtraireDomaines" Private Const sMenuCtx_CleCmdExtraireDomainesDescription$ = "Extraire les domaines" Private Const sMenuCtx_CleCmdVerifierDomaines$ = "VerifierDomaines" Private Const sMenuCtx_CleCmdVerifierDomainesDescription$ = "Verifier les domaines" Private Const sMenuCtx_CleCmdCompleterDomaines$ = "CompleterDomaines" Private Const sMenuCtx_CleCmdCompleterDomainesDescription$ = "Completer les domaines" Private Class clsCourrielExped ' Classe pour comptabiliser les domaines par adresse de courriel (expéditeur) Public sExpediteurCourriel$, iNbOccurrences% Public htDomaines As New Hashtable ' Hastable d'objets de type clsDomaine End Class Private Class clsDomaine ' Classe pour indexer les domaines (MsgID-Domaine des expéditeurs de courriel) Public sMsgIdDomaine$, sSujet$, sDate$ Public sExpediteurCourriel$, sExpediteurNom$ Public iNbOccurrences% End Class Private Class clsExpediteur ' Classe pour comptabiliser les expéditeurs (nom complet avec courriel) ' Ex.: "Patrice Dargenton <patrice.dargenton@free.fr>" Public sExpediteurComplet$, sMsgIdDomaine$, sSujet$, sDate$ Public iNbOccurrences% End Class #End Region #Region "Initialisations" Private Sub frmDbx2Txt_Load(ByVal sender As Object, ByVal e As EventArgs) _ Handles Me.Load ' Par défaut le chemin courant est celui de l'application en mode Debug ' mais le chemin courant est celui du dbx en mode Release ' (cf. tbDbx.TextChanged) Me.m_sCheminCourant = Application.StartupPath Dim sCheminDbx0$ = Me.m_sCheminDBX If m_sCheminDBX.IndexOf("\") = -1 Then ' Simple nom de fichier, ajouter le chemin courant sCheminDbx0 = Me.m_sCheminCourant & "\" & m_sCheminDBX If bDebug AndAlso Not bFichierExiste(sCheminDbx0) Then _ sCheminDbx0 = sCheminDBX_Def End If Me.tbDbx.Text = sCheminDbx0 Me.lbMenu.Items.Add(sMenu_ExtraireDomaines) '0 Me.lbMenu.Items.Add(sMenu_CompleterDomaines) '1 Me.lbMenu.Items.Add(sMenu_VerifierDomaines) '2 Me.lbMenu.Items.Add(sMenu_AfficherDomaines) '3 Me.lbMenu.Items.Add(sMenu_ExtraireCourriel) '4 Me.lbMenu.SelectedIndex = 0 ' Sélectionner la cmd n°1 Me.m_bQuitter = False Select Case Me.m_sCodeMenu Case sCodeMenu_ExtraireDomaines Me.lbMenu.SelectedIndex = 0 'Me.m_bQuitter = True Case sCodeMenu_CompleterDomaines Me.lbMenu.SelectedIndex = 1 Me.m_bAuto = True Me.WindowState = FormWindowState.Minimized Me.m_bQuitter = True Case sCodeMenu_VerifierDomaines Me.lbMenu.SelectedIndex = 2 Me.m_bAuto = True ' Utiliser frm.Shown car Activated ne marche pas si minimisé Me.WindowState = FormWindowState.Minimized Me.m_bQuitter = True Case sCodeMenu_AfficherDomaines : Me.lbMenu.SelectedIndex = 3 Case sCodeMenu_ExtraireCourriel : Me.lbMenu.SelectedIndex = 4 End Select If bDebug Then Me.lbMenu.SelectedIndex = iCodeMenuDef 'If bDebug Then Me.tbInfo.Text = "" ' n° du courriel a extraire VerifierMenuCtx() End Sub Private Sub frmDbx2Txt_Shown(ByVal sender As Object, ByVal e As EventArgs) _ Handles Me.Shown ' Si un menu est précisé au démarrage, alors le lancer If Me.m_sCodeMenu.Length > 0 And Not Me.m_bInit Then Me.m_bInit = True ' Shown n'est lancé qu'une fois : inutile ' Prompt désactivé pour les menus Vérifier et Compléter les domaines If Me.m_sCodeMenu = sMenu_VerifierDomaines Or _ Me.m_sCodeMenu = sCodeMenu_CompleterDomaines Then _ Me.m_bAuto = True GestionDepart() If Me.m_bQuitter Then Me.Close() End If End Sub Private Sub lbMenu_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As EventArgs) Handles lbMenu.SelectedIndexChanged Select Case Me.lbMenu.Items(Me.lbMenu.SelectedIndex).ToString Case sMenu_ExtraireDomaines : AfficherMsg( _ "Extraire les domaines/courriels de la base dbx sélectionnée", bRAM:=False) Case sMenu_CompleterDomaines : AfficherMsg( _ "Completer les domaines/courriels à partir de la base dbx sélectionnée", bRAM:=False) Case sMenu_VerifierDomaines : AfficherMsg( _ "Vérifier les domaines/courriels de la base dbx sélectionnée", bRAM:=False) Case sMenu_AfficherDomaines : AfficherMsg( _ "Afficher les domaines/courriels de la base dbx sélectionnée", bRAM:=False) Case sMenu_ExtraireCourriel : AfficherMsg( _ "Extraire un courriel par son numéro", bRAM:=False) End Select End Sub Private Sub GestionDepart() Me.m_bFauxPositifs = False Me.m_bExtraireDomainesEtExped = False Me.m_bVerifierDomainesEtExped = False Me.m_oDbx.Initialisation() Me.m_oDbx.m_sDossierExport = sDossierExport Dim sMenu$ = Me.lbMenu.Items(Me.lbMenu.SelectedIndex).ToString Select Case sMenu Case sMenu_ExtraireDomaines Me.m_bExtraireDomainesEtExped = True Me.m_bBaseRef = True Me.m_oDbx.m_bExtraireChamps = True InitHashTable() Depart() Case sMenu_CompleterDomaines If MsgBoxResult.Cancel = MsgBox( _ "Veuillez confirmer la mise à jour des domaines :" & vbLf & _ "assurez-vous qu'il n'y a pas de spam non lus dans votre boîte de réception", _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, _ sTitreMsg & " - Compléter les domaines") Then Exit Sub Me.m_bExtraireDomainesEtExped = True Me.m_bBaseRef = True Me.m_oDbx.m_bExtraireChamps = True InitHashTable() LireExpedRef(bCompleter:=True) LireDomainesRef(bCompleter:=True) Depart() Case sMenu_VerifierDomaines Me.m_bVerifierDomainesEtExped = True Me.m_bBaseRef = False Me.m_oDbx.m_bExtraireChamps = True InitHashTable() LireExpedRef() LireDomainesRef() Depart() Dim sCheminDossierExport$ = Me.m_sCheminCourant & Me.m_oDbx.m_sDossierExport Dim sCheminTxt_FP$ = sCheminDossierExport & "\" & sFichierFP If Me.m_bFauxPositifs Then If bEcrireFichier(sCheminTxt_FP, Me.m_sbFP) Then _ OuvrirAppliAssociee(sCheminTxt_FP) Else bSupprimerFichier(sCheminTxt_FP) End If Case sMenu_AfficherDomaines Dim sCheminDL$ = Me.m_sCheminCourant & "\" & sFichierDomaineRef Dim sCheminExped$ = Me.m_sCheminCourant & "\" & sFichierExpedRef OuvrirAppliAssociee(sCheminDL) OuvrirAppliAssociee(sCheminExped) Case sMenu_ExtraireCourriel Me.m_oDbx.m_iNumCourrielAExtraire = iConv(Me.tbInfo.Text) If Me.m_oDbx.m_iNumCourrielAExtraire = 0 Then MsgBox("Veuillez saisir un numéro de courriel !", _ MsgBoxStyle.Exclamation, sTitreMsg) Me.tbInfo.Select() Exit Sub End If Depart() End Select Select Case sMenu Case sMenu_ExtraireDomaines, sMenu_CompleterDomaines Dim sCheminTxt_Exped$ = Me.m_sCheminCourant & "\" & sFichierExpedRef 'MsgBox("CheminCourant : " & Me.m_sCheminCourant) If Not bEcrireExped(sCheminTxt_Exped) Then Exit Sub Dim sCheminTxt_DCL$ = Me.m_sCheminCourant & "\" & sFichierDomaineRef If Not bEcrireDomaines(sCheminTxt_DCL) Then Exit Sub If Me.m_bAuto Then Exit Sub ' Completer les domaines : auto ProposerOuvrirFichier(sCheminTxt_DCL) ProposerOuvrirFichier(sCheminTxt_Exped) End Select End Sub Private Sub lbMenu_DoubleClick(ByVal sender As Object, ByVal e As EventArgs) _ Handles lbMenu.DoubleClick GestionDepart() End Sub Private Sub tbDbx_TextChanged(ByVal sender As Object, ByVal e As EventArgs) _ Handles tbDbx.TextChanged If Me.tbDbx.Text.Length = 0 Then Exit Sub Dim sFichierDbx$ = IO.Path.GetFileNameWithoutExtension(Me.tbDbx.Text) If sFichierDbx.IndexOf("spam", _ StringComparison.InvariantCultureIgnoreCase) >= 0 Then Me.chkDbxRef.Checked = False Else Me.chkDbxRef.Checked = True End If If bRelease Then Me.m_sCheminCourant = IO.Path.GetDirectoryName(Me.tbDbx.Text) 'MsgBox("CheminCourant : " & Me.m_sCheminCourant) End If End Sub Private Sub tbDbx_DoubleClick(ByVal sender As Object, ByVal e As EventArgs) _ Handles tbDbx.DoubleClick ChoisirDbx() End Sub Private Sub cmdParcourir_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdParcourir.Click ChoisirDbx() End Sub Private Sub ChoisirDbx() Const sTitre$ = "Veuillez choisir une base de courriels Outlook Express (*.dbx)" Const sFiltre$ = "Base Outlook Express (*.dbx)|*.dbx|Tous les fichiers (*.*)|*.*" Dim sCheminFichier$ = "" If Not bChoisirFichier(sCheminFichier, sFiltre, ".dbx", sTitre) Then Exit Sub Me.tbDbx.Text = sCheminFichier End Sub Private Sub chkDbxRef_CheckedChanged(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkDbxRef.CheckedChanged Me.m_bBaseRef = Me.chkDbxRef.Checked End Sub Private Sub cmdLancer_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdLancer.Click GestionDepart() End Sub Private Sub cmdAnnuler_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdAnnuler.Click Me.m_oDbx.m_bAnnuler = True End Sub Private Sub InitHashTable() Me.m_htDCL = New Hashtable Me.m_htCourrielsExp = New Hashtable Me.m_htExped = New Hashtable Me.m_sbFP = New StringBuilder End Sub Private Sub Depart() Dim sCheminDbx0$ = Me.tbDbx.Text If Not bFichierExiste(sCheminDbx0, bPrompt:=True) Then Exit Sub Me.m_oDbx.m_bAnnuler = False Me.cmdAnnuler.Enabled = True Me.cmdLancer.Enabled = False Me.m_oDbx.LireFichierDBX(sCheminDbx0, msgDelegue) Me.cmdLancer.Enabled = True Me.cmdAnnuler.Enabled = False End Sub Private Sub AfficherNouveauMessage(ByVal sender As Object, _ ByVal e As clsMsgEventArgs) Handles msgDelegue.EvAfficherMessage Me.AfficherMsg(e.sMessage) msgDelegue.m_bAnnuler = Me.m_oDbx.m_bAnnuler End Sub Private Sub AfficherMsg(ByVal sInfo$, Optional ByVal bRAM As Boolean = True) If bRAM Then Dim rPCRAM! = CSng(My.Computer.Info.AvailablePhysicalMemory / _ My.Computer.Info.TotalPhysicalMemory) Dim sRam$ = "RAM libre : " & _ sFormaterTailleOctets( _ CLng(My.Computer.Info.AvailablePhysicalMemory)) & " (" & _ rPCRAM.ToString("0.0%") & ")" sInfo &= " - " & sRam & " " & Now End If Me.sbBarreEtat.Text = sInfo Application.DoEvents() End Sub #End Region #Region "Gestion des menus contextuels" Private Sub cmdAjouterMenuCtx_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdAjouterMenuCtx.Click Dim sCheminExe$ = Application.ExecutablePath Const bPrompt As Boolean = False bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdOuvrir, _ bPrompt, , sMenuCtx_CleCmdOuvrirDescription, sCheminExe, _ , sMenuCtx_TypeFichierDbxDescription) bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdExtraireDomaines, _ bPrompt, , sMenuCtx_CleCmdExtraireDomainesDescription, sCheminExe, _ "CodeMenu ED CheminDbx ""%1""") bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdVerifierDomaines, _ bPrompt, , sMenuCtx_CleCmdVerifierDomainesDescription, sCheminExe, _ "CodeMenu VD CheminDbx ""%1""") bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdCompleterDomaines, _ bPrompt, , sMenuCtx_CleCmdCompleterDomainesDescription, sCheminExe, _ "CodeMenu CD CheminDbx ""%1""") VerifierMenuCtx() End Sub Private Sub cmdEnleverMenuCtx_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdEnleverMenuCtx.Click bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdOuvrir, _ bEnlever:=True, bPrompt:=False) bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdExtraireDomaines, _ bEnlever:=True, bPrompt:=False) bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdVerifierDomaines, _ bEnlever:=True, bPrompt:=False) bAjouterMenuContextuel(sMenuCtx_TypeFichierDbx, sMenuCtx_CleCmdCompleterDomaines, _ bEnlever:=True, bPrompt:=False) VerifierMenuCtx() End Sub Private Sub VerifierMenuCtx() Dim sCleDescriptionCmd$ = sMenuCtx_TypeFichierDbx & "\shell\" & _ sMenuCtx_CleCmdExtraireDomaines Me.cmdAjouterMenuCtx.Enabled = False Me.cmdEnleverMenuCtx.Enabled = True If Not bCleRegistreCRExiste(sCleDescriptionCmd) Then Me.cmdAjouterMenuCtx.Enabled = True Me.cmdEnleverMenuCtx.Enabled = False End If End Sub #End Region #Region "Analyse des courriels" Private Sub EvChampDepart() Handles m_oDbx.EvChampDepart ' Evénement activé : c'est ici qu'on peut initialiser une analyse des champs 'Me.m_htChp = New Hashtable End Sub Private Sub EvAnalyserChamp(ByVal sChamp$, ByVal sValChamp$) _ Handles m_oDbx.EvChamp ' Evénement non activé 'Debug.WriteLine(sChamp & " : " & sValChamp) End Sub Private Sub EvCourriel(ByVal ic As clsDbx.TInfoCourriel) _ Handles m_oDbx.EvCourriel ' Evénement fin d'extraction des champs d'un courriel Dim bFP As Boolean = False ' Faux positif GestionDomaines(ic, bFP) GestionExped(ic, bFP) End Sub Private Sub GestionDomaines(ByVal ic As clsDbx.TInfoCourriel, ByRef bFP As Boolean) ' Si le domaine est absent, inutile d'indexer ou vérifier : pas fiable If ic.sMsgID_Domaine = clsDbx.sChpAbsent Then Exit Sub If ic.sMsgID_Domaine.Length = 0 Then Exit Sub If IsNothing(Me.m_htDCL) Then Exit Sub If Me.m_bBaseRef Then If Not Me.m_bExtraireDomainesEtExped Then Exit Sub If ic.bCourrielNonLu Then ' Ne pas tenir compte des messages non lu : cela peut encore être du spam Exit Sub End If ' Si c'est la base légitime alors indexer les domaines IndexerDomaine(ic) Exit Sub End If If Not Me.m_bVerifierDomainesEtExped Then Exit Sub ' Vérifier si le courriel de la base de spam est indexé dans les domaines légitimes Dim sCle$ = ic.sMsgID_Domaine & ":" & ic.sExpediteurCourriel If Not Me.m_htDCL.ContainsKey(sCle) Then Exit Sub ' Si oui alors c'est un faux positif bFP = True Me.m_bFauxPositifs = True ' Au moins un faux positif Me.m_sbFP.Append( _ sCle & " : " & ic.sExpediteurNom & " : " & _ "Courriel n°" & ic.lNumCourriel & " : " & _ ic.dDate.ToString(sFormatDateHeure) & " : " & ic.sSujet & vbCrLf) End Sub Private Sub GestionExped(ByVal ic As clsDbx.TInfoCourriel, ByRef bFP As Boolean) ' Gestion des expéditeurs If ic.sExpediteurComplet.Length = 0 Then Exit Sub If ic.sExpediteurComplet = clsDbx.sChpAbsent Then Exit Sub If ic.sExpediteurComplet = clsDbx.sChpVide Then Exit Sub If IsNothing(Me.m_htExped) Then Exit Sub If Me.m_bBaseRef Then If Not Me.m_bExtraireDomainesEtExped Then Exit Sub If ic.bCourrielNonLu Then ' Ne pas tenir compte des messages non lu : cela peut encore être du spam Exit Sub End If ' Si c'est la base légitime alors indexer les expéditeurs IndexerExped(ic) Exit Sub End If If Not Me.m_bVerifierDomainesEtExped Then Exit Sub ' Si un Faux Positif a déjà été détecté, alors inutile de le signaler à nouveau If bFP Then Exit Sub ' Vérifier si le courriel de la base de spam est indexé dans les expéditeurs légitimes Dim sCle$ = ic.sExpediteurComplet If Not Me.m_htExped.ContainsKey(sCle) Then Exit Sub ' Si oui alors c'est un faux positif bFP = True Me.m_bFauxPositifs = True ' Au moins un faux positif Me.m_sbFP.Append( _ ic.sExpediteurComplet & " : " & _ "Courriel n°" & ic.lNumCourriel & " : " & _ ic.dDate.ToString(sFormatDateHeure) & " : " & ic.sSujet & vbCrLf) End Sub #End Region #Region "Gestion des expéditeurs" Private Sub IndexerExped(ByVal ic As clsDbx.TInfoCourriel) ' Indexer le nom complet de l'expéditeur du courriel Dim sCle$ = ic.sExpediteurComplet Dim exped As clsExpediteur If Me.m_htExped.ContainsKey(sCle) Then exped = CType(Me.m_htExped(sCle), clsExpediteur) ' Via une hashtable de classe on peut incrémenter directement exped.iNbOccurrences += 1 Else exped = New clsExpediteur exped.iNbOccurrences = 1 Me.m_htExped.Add(sCle, exped) End If exped.sExpediteurComplet = ic.sExpediteurComplet exped.sDate = ic.dDate.ToString(sFormatDateHeure) exped.sSujet = ic.sSujet exped.sMsgIdDomaine = ic.sMsgID_Domaine End Sub Public Sub LireExpedRef(Optional ByVal bCompleter As Boolean = False) ' Lire les expéditeurs de référence (légitimes) Me.m_htExped = Nothing Dim sCheminExped$ = Me.m_sCheminCourant & "\" & sFichierExpedRef If Not bFichierExiste(sCheminExped, bPrompt:=True) Then Exit Sub Dim sbExped As New StringBuilder sbExped = sbLireFichier(sCheminExped) Dim asExped$() = Split(sbExped.ToString, CChar(vbLf)) Me.m_htExped = New Hashtable For i As Integer = 0 To asExped.Length - 1 If asExped(i) <> "" Then Dim sLigne$ = asExped(i).Trim Dim sExpedComplet$ = "" Dim iNbOcc% = 0 Dim rPC! = 0 Dim sDate$ = "" Dim sMsgIDDomaine$ = "" Dim sSujet$ = "" Dim asChps$() = sLigne.Split(CChar(sSeparChp)) Dim iNbChps% = asChps.GetUpperBound(0) If iNbChps >= 0 Then sExpedComplet = asChps(0) ' Lorsque l'on relit les expéditeurs, on perd le comptage à l'origine : pas grave If iNbChps >= 1 Then iNbOcc = iConv(asChps(1)) 'If iNbChps >= 2 Then rPC = rConv(asChps(2)) If iNbChps >= 3 Then sMsgIDDomaine = asChps(3) If iNbChps >= 4 Then sDate = asChps(4) If iNbChps >= 5 Then sSujet = asChps(5) Dim ic As clsDbx.TInfoCourriel = Nothing ic.sExpediteurComplet = sExpedComplet If bCompleter Then ' Noter les infos à faire figurer dans le fichier de référence ic.sMsgID_Domaine = sMsgIDDomaine ic.sSujet = sSujet ic.dDate = dVerifierDate(sDate) End If IndexerExped(ic) End If Next End Sub Private Function bEcrireExped(ByVal sChemin$) As Boolean If IsNothing(Me.m_htExped) Then Exit Function If Me.m_htExped.Count = 0 Then Exit Function ' En mode auto, ne pas poser de question If Not Me.m_bAuto AndAlso bFichierExiste(sChemin) Then Dim sTypeAction$ = "remplacer" If Me.lbMenu.Items(Me.lbMenu.SelectedIndex).ToString = _ sMenu_CompleterDomaines Then sTypeAction = "completer" If MsgBoxResult.Cancel = MsgBox( _ "Etes-vous sûr de vouloir " & sTypeAction & _ " la liste des expéditeurs ?" & vbLf & sChemin, _ MsgBoxStyle.Question Or MsgBoxStyle.OkCancel, sTitreMsg) Then _ Exit Function End If Dim iNbValChps% = Me.m_htExped.Count Dim lNbCourriels& = Me.m_oDbx.m_infoDbx.lNbCourriels Dim de As IDictionaryEnumerator de = Me.m_htExped.GetEnumerator() AfficherMsg("Tri des champs par nbre d'occurrences...") Dim aChps(iNbValChps) As clsExpediteur Dim aiDist%(iNbValChps) Dim iNumChp% = 0 While de.MoveNext() Dim exped As clsExpediteur = CType(Me.m_htExped(de.Key), clsExpediteur) aChps(iNumChp) = exped aiDist(iNumChp) = exped.iNbOccurrences iNumChp += 1 End While If aiDist.Length <> aChps.Length Then Stop Array.Sort(aiDist, aChps) Array.Reverse(aChps) Dim sb As New StringBuilder For Each exped As clsExpediteur In aChps If IsNothing(exped) Then Continue For Dim rPC! = CSng(exped.iNbOccurrences / lNbCourriels) sb.Append( _ exped.sExpediteurComplet & sSeparChp & _ exped.iNbOccurrences & sSeparChp & _ rPC.ToString("0.00%") & sSeparChp & _ exped.sMsgIdDomaine & sSeparChp & _ exped.sDate & sSeparChp & _ exped.sSujet).Append(vbCrLf) Next ' exped ' En mode auto (completer domaine), inutile de faire un .bak If Not Me.m_bAuto AndAlso bFichierExiste(sChemin) Then Dim sFichierBak$ = IO.Path.GetDirectoryName(sChemin) & "\" & _ IO.Path.GetFileNameWithoutExtension(sChemin) & ".bak" 'MsgBox("CheminBak : " & sFichierBak) If Not bCopierFichier(sChemin, sFichierBak) Then Exit Function End If If Not bEcrireFichier(sChemin, sb) Then Exit Function AfficherMsg(sMsgOperationTerminee) bEcrireExped = True End Function #End Region #Region "Gestion des domaines" Public Sub LireDomainesRef(Optional ByVal bCompleter As Boolean = False) ' Lire les domaines de référence (légitimes) Me.m_htDCL = Nothing Dim sCheminDCL$ = Me.m_sCheminCourant & "\" & sFichierDomaineRef If Not bFichierExiste(sCheminDCL, bPrompt:=True) Then Exit Sub Dim sbDCL As New StringBuilder sbDCL = sbLireFichier(sCheminDCL) Dim asDCL$() = Split(sbDCL.ToString, CChar(vbLf)) Me.m_htDCL = New Hashtable For i As Integer = 0 To asDCL.Length - 1 If asDCL(i) <> "" Then Dim sLigne$ = asDCL(i).Trim Dim sCourriel$ = "" Dim sDomaine$ = "" Dim sNomExped$ = "" Dim sDate$ = "" Dim sSujet$ = "" Dim asChps$() = sLigne.Split(CChar(sSeparChp)) Dim iNbChps% = asChps.GetUpperBound(0) If iNbChps >= 0 Then sCourriel = asChps(0) ' ic.sExpediteurCourriel If iNbChps >= 1 Then sDomaine = asChps(1) ' ic.sMsgID_Domaine If iNbChps >= 6 Then sNomExped = asChps(6) If iNbChps >= 7 Then sDate = asChps(7) If iNbChps >= 8 Then sSujet = asChps(8) Dim sCle$ = sDomaine & ":" & sCourriel ' Hashtable DCL : Domaine avec le Courriel Légitime de l'expéditeur : ' clé pour les faux positifs If Not Me.m_htDCL.ContainsKey(sCle) Then Me.m_htDCL.Add(sCle, sCle) If bCompleter Then Dim ic As clsDbx.TInfoCourriel = Nothing ic.sExpediteurCourriel = sCourriel ic.sMsgID_Domaine = sDomaine ic.sExpediteurNom = sNomExped ic.dDate = dVerifierDate(sDate) ic.sSujet = sSujet ' Hashtable Courriel d'expéditeur : Simplement pour trier les domaines par ' fréquence d'un expéditeur légitime via son courriel, tout domaine cumulé ' Me.m_htCourrielsExp IndexerDomaine(ic) End If End If Next End Sub Private Function bEcrireDomaines(ByVal sChemin$) As Boolean If IsNothing(Me.m_htCourrielsExp) Then Exit Function If Me.m_htCourrielsExp.Count = 0 Then Exit Function ' En mode auto, ne pas poser de question If Not Me.m_bAuto AndAlso bFichierExiste(sChemin) Then Dim sTypeAction$ = "remplacer" If Me.lbMenu.Items(Me.lbMenu.SelectedIndex).ToString = _ sMenu_CompleterDomaines Then sTypeAction = "completer" If MsgBoxResult.Cancel = MsgBox( _ "Etes-vous sûr de vouloir " & sTypeAction & _ " la liste des domaines ?" & vbLf & sChemin, _ MsgBoxStyle.Question Or MsgBoxStyle.OkCancel, sTitreMsg) Then _ Exit Function End If Dim iNbValChps% = Me.m_htCourrielsExp.Count Dim lNbCourriels& = Me.m_oDbx.m_infoDbx.lNbCourriels Dim de As IDictionaryEnumerator de = Me.m_htCourrielsExp.GetEnumerator() AfficherMsg("Tri des champs par nbre d'occurrences...") Dim aCourExp(iNbValChps) As clsCourrielExped Dim aiDist%(iNbValChps) Dim iNumChp% = 0 While de.MoveNext() Dim courExp As clsCourrielExped = CType( _ Me.m_htCourrielsExp(de.Key), clsCourrielExped) aCourExp(iNumChp) = courExp aiDist(iNumChp) = courExp.iNbOccurrences iNumChp += 1 End While If aiDist.Length <> aCourExp.Length Then Stop Array.Sort(aiDist, aCourExp) Array.Reverse(aCourExp) Dim sb As New StringBuilder For Each courExp As clsCourrielExped In aCourExp If IsNothing(courExp) Then Continue For Dim rPC! = CSng(courExp.iNbOccurrences / lNbCourriels) Dim iNbValChps2% = courExp.htDomaines.Count Dim aDom(iNbValChps2) As clsDomaine Dim aiDist2%(iNbValChps2) Dim iNumChp2% = 0 de = courExp.htDomaines.GetEnumerator() While de.MoveNext() Dim dom As clsDomaine = CType(courExp.htDomaines(de.Key), clsDomaine) aDom(iNumChp2) = dom aiDist2(iNumChp2) = dom.iNbOccurrences iNumChp2 += 1 End While If aiDist2.Length <> aDom.Length Then Stop Array.Sort(aiDist2, aDom) Array.Reverse(aDom) Dim bPremiereLigne As Boolean = False For Each dom As clsDomaine In aDom If IsNothing(dom) Then Continue For Dim rPC2! = CSng(dom.iNbOccurrences / courExp.iNbOccurrences) Dim sPC$ = "" Dim sOcc$ = "" If Not bPremiereLigne Then sOcc = courExp.iNbOccurrences.ToString sPC = rPC.ToString("0.00%") bPremiereLigne = True End If sb.Append( _ courExp.sExpediteurCourriel & sSeparChp & _ dom.sMsgIdDomaine & sSeparChp & _ sOcc & sSeparChp & _ sPC & sSeparChp & _ dom.iNbOccurrences & sSeparChp & _ rPC2.ToString("0.00%") & sSeparChp & _ dom.sExpediteurNom & sSeparChp & _ dom.sDate & sSeparChp & _ dom.sSujet).Append(vbCrLf) Next ' dom Next ' courExp ' En mode auto (completer domaine), inutile de faire un .bak If Not Me.m_bAuto AndAlso bFichierExiste(sChemin) Then Dim sFichierBak$ = IO.Path.GetFileNameWithoutExtension(sChemin) & ".bak" If Not bCopierFichier(sChemin, sFichierBak) Then Exit Function End If If Not bEcrireFichier(sChemin, sb) Then Exit Function AfficherMsg(sMsgOperationTerminee) bEcrireDomaines = True End Function Private Sub IndexerDomaine(ByVal ic As clsDbx.TInfoCourriel) ' D'abord indexer les adresses de courriel Dim sCleCourrielExped$ = ic.sExpediteurCourriel If Me.m_htCourrielsExp.ContainsKey(sCleCourrielExped) Then Dim courExp As clsCourrielExped = CType( _ Me.m_htCourrielsExp(sCleCourrielExped), clsCourrielExped) ' Via une hashtable de classe on peut incrémenter directement courExp.iNbOccurrences += 1 ' Puis indexer les domaines If courExp.htDomaines.ContainsKey(ic.sMsgID_Domaine) Then Dim dom As clsDomaine = CType( _ courExp.htDomaines(ic.sMsgID_Domaine), clsDomaine) dom.iNbOccurrences += 1 Else Dim dom As New clsDomaine dom.sMsgIdDomaine = ic.sMsgID_Domaine ' Exemple de courriel et sujet : le 1er rencontré dom.sExpediteurCourriel = ic.sExpediteurCourriel dom.sExpediteurNom = ic.sExpediteurNom dom.sDate = ic.dDate.ToString(sFormatDateHeure) dom.sSujet = ic.sSujet dom.iNbOccurrences = 1 courExp.htDomaines.Add(ic.sMsgID_Domaine, dom) End If Else Dim courExp As New clsCourrielExped courExp.sExpediteurCourriel = ic.sExpediteurCourriel courExp.iNbOccurrences = 1 Dim dom As New clsDomaine dom.sMsgIdDomaine = ic.sMsgID_Domaine ' Exemple de courriel et sujet : le 1er rencontré dom.sExpediteurCourriel = ic.sExpediteurCourriel dom.sExpediteurNom = ic.sExpediteurNom dom.sDate = ic.dDate.ToString(sFormatDateHeure) dom.sSujet = ic.sSujet dom.iNbOccurrences = 1 courExp.htDomaines.Add(ic.sMsgID_Domaine, dom) Me.m_htCourrielsExp.Add(sCleCourrielExped, courExp) End If End Sub #End Region End Class clsDbx.vb ' Fichier clsDbx : Lecture d'un fichier Dbx (Outlook Express) ' -------------- ' http://www.vbfrance.com/code.aspx?ID=41883 ' Documentation : Dbx2Txt.html ' http://patrice.dargenton.free.fr/CodesSources/Dbx2Txt.html ' http://patrice.dargenton.free.fr/CodesSources/Dbx2Txt.vbproj.html ' Version 1.03 du 26/01/2008 ' Version 1.02 du 23/08/2007 ' D'après la source : ' www.leapsecond.com/tools/dbx2txt.c ' www.leapsecond.com/tools/dbx2txt.exe ' Par Patrice Dargenton : mailto: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 Imports System.IO Imports System.Text ' Pour StringBuilder 'Imports System.Runtime.InteropServices ' Pour StructLayout Public Class clsDbx #Region "Interface" ' Evénement signalant la fin de l'extraction d'un courriel Public Event EvCourriel(ByVal ic As TInfoCourriel) ' Evénement signalant le début de l'analyse des champs de l'entete d'un courriel Public Event EvChampDepart() ' Evénement signalant la fin de l'extraction d'un champ de l'entete d'un courriel Public Event EvChamp(ByVal sChamp$, ByVal sValChamp$) Public m_bEcrireSujets As Boolean = False Public m_bEcrireDetail As Boolean = False Public m_bExtraireContenu As Boolean = False Public m_bExtraireContenuHtml As Boolean = False Public m_bEcrireChamps As Boolean = False Public m_bExtraireChamps As Boolean = True Public m_bAnalyserChamps As Boolean = False Public m_ic As TInfoCourriel Public m_infoDbx As TInfoDbx Public m_bAnnuler As Boolean Public m_bMsgTrouve As Boolean = False Public m_iNumCourrielAExtraire% = 0 Public Const sChpAbsent$ = "[Absent]" '"" Public Const iValAbsent% = 0 Public Const sChpVide$ = "[Vide]" Public Const sValChpAutre$ = "[Autre]" Public m_sCheminCourant$ = "" Public m_sDossierExport$ = "" Public Const sFichierSujets$ = "Sujets.txt" Public Const sFichierDetails$ = "Details.txt" Public Const sFichierDebug$ = "Debug" ' Deboguage identique à la source dbx2txt.c Public Const iNivDebug% = 0 Public Const bDebugCourrierNonLu As Boolean = False ' Utiliser le codage "Autre" pour les valeurs rares ne figurant ' pas dans les 3 listes ci-dessous (mettre False pour obtenir ' la liste de ces valeurs rares) Public Const bUtiliserCodageAutre As Boolean = False Public Const sListeValChpsCont$ = _ " text/plain text/html " & _ " multipart/alternative multipart/mixed multipart/related" & _ " format=flowed " Public Const sListeValType$ = _ " multipart/alternative multipart/mixed multipart/related " Public Const sListeValCharset$ = _ " iso-8859-1 us-ascii utf-8 windows-1251 windows-1252 " Public Const sSeparateurListe$ = ", " ' Pour Afficher Public Const sSeparateursListeChps$ = ";," ' Ex.: Content-Type : ;, #End Region #Region "Déclarations" Private Const sGm$ = """" Private m_acSepListe() As Char Private m_asListeValCharset$() Private m_sbSujets, m_sbDetails, m_sbDebug, m_sbCourriel As StringBuilder Private m_br As BinaryReader Private m_uiTailleTTexte As UInteger Private m_uiTailleTListeCourriel As UInteger Private m_uiTailleTEnteteListe As UInteger Private m_uiTailleTCourriel As UInteger Private m_msgDelegue As clsMsgDelegue #End Region #Region "Structures de données" ' Structure de la racine du dbx : nécessaire pour obtenir ' l'adresse du premier bloc ! ' struct { ' int32 magic[4]; ' int32 pad1[45]; ' int32 count; ' int32 pad2[7]; ' int32 offset; ' int32 pad3[70]; ' } Root; ' Class et non structure pour les tableaux ' Les classes sont en LayoutKind.Auto par défaut et Sequential pour les struct ' Il existe aussi L'attribut <FieldOffset(x)> pour indiquer ' la position du champ en mode explicite ' On ne lit pas directement la structure, donc l'attribut n'est pas nécessaire '<StructLayout(LayoutKind.Sequential)> _ Class TEnteteDbx ' UInteger : DWORD : C++.unsigned long : 4 octets ' UInteger est nécessaire car Integer ne fonctionne pas : ReadInt32 renvoi des négatifs Public magic(4 - 1) As UInteger Public pad1(45 - 1) As UInteger Public count As UInteger Public pad2(7 - 1) As UInteger Public offset As UInteger Public pad3(70 - 1) As UInteger End Class ' list_header ' struct { ' int32 self; ' int32 zero; ' int32 next; ' int32 back; ' int32 count; ' int32 int6; ' } Head; ' Attribut non nécessaire en fait car déjà par défaut '<StructLayout(LayoutKind.Sequential)> _ Structure TEnteteListe ' Structure d'un entete de liste de courriels Dim self As UInteger ' Position courante : pour vérification Dim zero As UInteger ' Toujours 0 ? Dim next1 As UInteger ' Position suivante Dim back As UInteger ' Position précédente Dim count As UInteger ' Nombre de courriels dans la liste Dim int6 As UInteger ' ? End Structure ' Structure pour un élément de liste correspondant à un courriel Structure TListeCourriel Dim mail As UInteger ' Position du courriel Dim head As UInteger ' Position de l'entete du courriel Dim int3 As UInteger ' ? End Structure ' mail_header ' struct { ' int32 self; ' int32 int2; ' int32 count; ' } Mail; Structure TCourriel ' Structure pour un courriel Dim self As UInteger ' Position actuelle pour vérification Dim int2 As UInteger ' ? Dim count As UInteger ' Codage du nombre de couples clé-valeur End Structure ' mail_header ' struct { ' unsigned key : 8; ' unsigned value : 24; ' } Info; ' Structure pour un coupe clé-valeur caractérisant un courriel Structure TInfoCourrielCleValeur Dim keyValue As UInteger 'Dim key As Char 'Dim value As UInteger End Structure ' mail_message ' struct { ' int32 self; ' int32 size; ' int32 count; ' int32 next; ' } Text; Structure TTexte ' Structure d'un bloc (de 512 octets) de courriel Dim self As UInteger ' Position actuelle pour vérification Dim size As UInteger ' Taille (512) Dim count As UInteger ' Bloc de 512 octets en général Dim next0 As UInteger ' Position du bloc suivant End Structure Structure TInfoDbx ' Structure pour noter les info. du fichier .dbx Dim sCheminDbx$, sFichierDbx$ Dim lNbCourriels&, lNbCourrielsTot& Dim lTailleFichier& Dim iNbErr%, iNbAvert% End Structure Structure TInfoCourriel ' Structure pour noter les info. d'un courriel Dim lNumCourriel& ' En fait c'est un UInt qu'on stocke dans un Long Dim sSujet$, sSujetBrute$ Dim bSujetISO As Boolean Dim sDateEmission$, sMsgInfo$, sTypesContenu$, sSousTypeContenu$ Dim dDate, dDateUTC As Date Dim bDateInvalide As Boolean Dim bSpamSelonCloudmark As Boolean Dim lTailleOctets&, rTailleKo!, rTailleMo! Dim iNumEncodageISO% Dim sExpediteurComplet$, sExpediteurNom$, sExpediteurCourriel$ Dim sEntetes$, sContenu$, sDetail$ Dim sAdresseRetour$, sRepondreA$, sDestFAI$, sMEUUID$, sMsgID$, sMsgID_Domaine$ Dim bAdresseRetourDiff As Boolean Dim sMIMEVersion$, sContentTransferEncoding$ Dim sDestinataires$, iNbDestinataires% Dim sDestinatairesCopie$, iNbDestinatairesCopie% Dim sDestinatairesCopieCachee$, iNbDestinatairesCopieCachee% Dim sDomaineDest$, sDomaineDestFAI$, sDestinataireNom$, sDestinataireCourriel$ Dim bDomaineExpDestIdem As Boolean Dim sPriorite$, sPrioriteMSMail$ Dim sMailer$, sMimeOLE$ Dim sListeCheminements$ Dim sXOriginalArrivalTime$, sStatut$, sContentLength$ Dim sCharset$, iCharset% Dim bHtml, bFormatFlowed As Boolean Dim sTypeMultipart$, iTypeMultipart% Dim iNbChps%, iNbChpsStdr% Dim bCourrielNonLu As Boolean ' Pas encore fonctionnel, cf. bDebugCourrierNonLu Dim sCodeHexa$ End Structure #End Region #Region "Lecture Dbx" Public Sub LireFichierDBX(ByVal sCheminFichierDbx$, _ ByVal msgDelegue As clsMsgDelegue) Me.m_msgDelegue = msgDelegue ' 24 Octets : faux ! ne compte que les pointeurs, mais pas les tableaux 'Dim iTailleEnteteDbx% = _ ' System.Runtime.InteropServices.Marshal.SizeOf( _ ' GetType(TEnteteDbx)) ' 6*4 = 24 Octets m_uiTailleTEnteteListe = CUInt( _ System.Runtime.InteropServices.Marshal.SizeOf( _ GetType(TEnteteListe))) ' 3*4 = 12 Octets m_uiTailleTListeCourriel = CUInt( _ System.Runtime.InteropServices.Marshal.SizeOf( _ GetType(TListeCourriel))) ' 4*4 = 16 Octets m_uiTailleTTexte = CUInt( _ System.Runtime.InteropServices.Marshal.SizeOf( _ GetType(TTexte))) ' 3*4 = 12 Octets m_uiTailleTCourriel = CUInt( _ System.Runtime.InteropServices.Marshal.SizeOf( _ GetType(TCourriel))) 'uiTailleCourriel = CType(iTailleTCourriel, UInteger) 'uiTailleCourriel = CUInt(iTailleTCourriel) ' Le fichier peut être protégé en écriture par Outlook Express ' mais on peut le copier temporairement Dim bSupprimerFichierTmpDbx As Boolean = False Dim sChemin$ = sCheminFichierDbx If Not bFichierAccessible(sChemin) Then sChemin = IO.Path.GetDirectoryName(sChemin) & "\" & _ IO.Path.GetFileNameWithoutExtension(sChemin) & "_tmp.dbx" AfficherMsg("Copie du fichier " & _ IO.Path.GetFileName(sCheminFichierDbx) & " en cours...") If Not bCopierFichier(sCheminFichierDbx, sChemin) Then Exit Sub bSupprimerFichierTmpDbx = True End If Me.m_sCheminCourant = Application.StartupPath If bRelease Then Me.m_sCheminCourant = IO.Path.GetDirectoryName(sChemin) Me.m_sbSujets = New StringBuilder Me.m_sbDetails = New StringBuilder Me.m_sbDebug = New StringBuilder Me.m_sbCourriel = New StringBuilder Me.m_infoDbx.lNbCourriels = 0 Me.m_infoDbx.lNbCourrielsTot = 0 Me.m_infoDbx.sFichierDbx = IO.Path.GetFileNameWithoutExtension(sCheminFichierDbx) Me.m_infoDbx.sCheminDbx = sCheminFichierDbx Me.m_bMsgTrouve = False Me.m_acSepListe = sSeparateursListeChps.ToCharArray Me.m_asListeValCharset = sListeValCharset.Split(" "c) Dim fs As FileStream = Nothing Try fs = New FileStream(sChemin, FileMode.Open, FileAccess.Read) Me.m_br = New BinaryReader(fs) Me.m_infoDbx.lTailleFichier = Me.m_br.BaseStream.Length ' Positionner la lecture du fichier à l'emplacement du nbr de mails ' Version C++ : 'this->Seek(0xc4,CFile::begin); //on récupère le nombre de messages 'this->Read(&NbreMessage,sizeof(NbreMessage)); Dim lPos& = 196 ' 0xc4 Me.m_br.BaseStream.Seek(lPos, SeekOrigin.Begin) Dim uiNbCourriels As UInteger = Me.m_br.ReadUInt32() Me.m_infoDbx.lNbCourrielsTot = CLng(uiNbCourriels) ' Positionner la lecture à l'emplacement de l'adresse de la TOC ' Table Of Contents : Table des matières lPos = 48 ' 0x30 Dim lOffset& = lPos lPos = 0 Me.m_br.BaseStream.Seek(lPos, SeekOrigin.Begin) Dim enteteDbx As New TEnteteDbx Dim i0% For i0 = 0 To 3 enteteDbx.magic(i0) = Me.m_br.ReadUInt32() Next ' 0xfe12adcf = 4262637007 If enteteDbx.magic(0) <> 4262637007 Then ' Format <> Dbx Exit Sub End If lPos += 4 * 4 ' MAGIC lPos += 45 * 4 ' pad1(45) ' 16 + 180 = 196 : c'est bien le nbre total de mail : ok Me.m_br.BaseStream.Seek(lPos, SeekOrigin.Begin) enteteDbx.count = Me.m_br.ReadUInt32() lPos += 1 * 4 ' count lPos += 7 * 4 ' pad2(7) Me.m_br.BaseStream.Seek(lPos, SeekOrigin.Begin) enteteDbx.offset = Me.m_br.ReadUInt32() lOffset = lPos ' Premier bloc à lire 'lPos += 1 * 4 ' offset 'lPos += 70 * 4 ' pad3(70) ' Le fichier sera fermé dans le Finally If enteteDbx.count = 0 Or enteteDbx.offset = 0 Then Exit Sub If Not bLireEnteteListe(enteteDbx.offset, 0) Then Exit Sub Me.m_br.Close() fs.Close() 'printf("%3ld header blocks, %4ld messages, %7.3lf MB, %3.0lf%%, %s", ' Sum.headers, Sum.messages, (double) Sum.bytes / MB, ' pct, dbxpath); 'if (Sum.warnings) { ' printf(" -- %ld warnings", Sum.warnings); } 'printf("\n"); 'Dim sLigne$ = String.Format( _ ' "{0} header blocks, {1} messages, {2} MB", enteteDbx.offset) 'Me.m_sbDebug.Append(sLigne).Append(vbCrLf) AfficherMsg("Ecriture des données extraites en cours...") Dim sCheminDossierExport$ = Me.m_sCheminCourant & Me.m_sDossierExport If Not bVerifierCreerDossier(sCheminDossierExport) Then Exit Sub If Me.m_iNumCourrielAExtraire > 0 Then If Not Me.m_bMsgTrouve Then MsgBox("Le message n°" & Me.m_iNumCourrielAExtraire & _ " n'a pas été trouvé !" & vbLf & _ "Base : " & Me.m_infoDbx.sCheminDbx & vbLf & _ "Nombre de messages : " & Me.m_infoDbx.lNbCourrielsTot, _ MsgBoxStyle.Exclamation, sTitreMsg) Exit Sub End If ' Eviter d'ouvrir l'eml directement sous Outlook Express ' (risque de virus : ne pas cliquer sur les pièces jointes) Dim sCheminEml$ = sCheminDossierExport & "\" & _ "Message n°" & Me.m_ic.lNumCourriel & ".eml" If Not bEcrireFichier(sCheminEml, Me.m_sbCourriel) Then Exit Sub ' Mais on peut ouvrir la version texte dans le bloc-notes Dim sCheminEmlTxt$ = sCheminDossierExport & "\" & _ "Message n°" & Me.m_ic.lNumCourriel & ".txt" If Not bEcrireFichier(sCheminEmlTxt, Me.m_sbCourriel) Then Exit Sub ProposerOuvrirFichier(sCheminEmlTxt) ProposerOuvrirFichier(sCheminEml, _ "Attention : ne cliquez pas sur les pièces jointes suspectes !") End If If iNivDebug > 0 Then Dim sCheminTxtDebug$ = sCheminDossierExport & "\" & _ Me.m_infoDbx.sFichierDbx & "_" & _ sFichierDebug & iNivDebug & ".txt" If Not bEcrireFichier(sCheminTxtDebug, Me.m_sbDebug) Then Exit Sub ProposerOuvrirFichier(sCheminTxtDebug) End If If m_bEcrireDetail Or m_bEcrireChamps Then Dim sCheminTxtDetail$ = sCheminDossierExport & "\" & _ Me.m_infoDbx.sFichierDbx & "_" & sFichierDetails If Not bEcrireFichier(sCheminTxtDetail, Me.m_sbDetails) Then Exit Sub ProposerOuvrirFichier(sCheminTxtDetail) End If If m_bEcrireSujets Then Dim sCheminTxtS$ = sCheminDossierExport & "\" & _ Me.m_infoDbx.sFichierDbx & "_" & sFichierSujets If Not bEcrireFichier(sCheminTxtS, Me.m_sbSujets) Then Exit Sub ProposerOuvrirFichier(sCheminTxtS) End If AfficherMsg(sMsgOperationTerminee) Catch Ex As Exception AfficherMsgErreur2(Ex, "LireFichierDBX") Finally If Not IsNothing(Me.m_br) Then Me.m_br.Close() If Not IsNothing(fs) Then fs.Close() Me.m_br = Nothing fs = Nothing If bSupprimerFichierTmpDbx Then bSupprimerFichier(sChemin) End Try End Sub Private Function bLireEnteteListe(ByVal uiOffset As UInteger, _ ByVal uiParent As UInteger) As Boolean ' list_header ' Il y a une série de listes de courriel, il faut relire ' l'entête de chaque liste Do Me.m_br.BaseStream.Seek(uiOffset, SeekOrigin.Begin) Dim enteteListe As TEnteteListe ' Version C/C++ : on lit la structure d'un coup : ' je ne suis pas sûr que cela soit possible en DotNet ' (à moins de redéfinir la sérialisation de la structure, ' c'est peut être juste un attribut Serialisable à mettre ?) ' Read 6-word header. ' DBX_READ(offset, &Head, sizeof Head); enteteListe.self = Me.m_br.ReadUInt32() enteteListe.zero = Me.m_br.ReadUInt32() enteteListe.next1 = Me.m_br.ReadUInt32() enteteListe.back = Me.m_br.ReadUInt32() enteteListe.count = Me.m_br.ReadUInt32() enteteListe.int6 = Me.m_br.ReadUInt32() If iNivDebug >= 1 Then 'printf("%.8lx: header::\n", offset); 'printf(" Head.self %.8lx\n", Head.self); 'printf(" Head.zero %.8lx\n", Head.zero); 'printf(" Head.next %.8lx\n", Head.next); 'printf(" Head.back %.8lx\n", Head.back); 'printf(" Head.count %.8lx\n", Head.count); 'printf(" Head.int6 %.8lx\n", Head.int6); Dim sLigne1$ = String.Format("{0:x8}: header::", uiOffset) Dim sLigne2$ = String.Format(" Head.self {0:x8}", enteteListe.self) Dim sLigne3$ = String.Format(" Head.zero {0:x8}", enteteListe.zero) Dim sLigne4$ = String.Format(" Head.next {0:x8}", enteteListe.next1) Dim sLigne5$ = String.Format(" Head.back {0:x8}", enteteListe.back) Dim sLigne6$ = String.Format(" Head.count {0:x8}", enteteListe.count) Dim sLigne7$ = String.Format(" Head.int6 {0:x8}", enteteListe.int6) Me.m_sbDebug.Append(vbCrLf) Me.m_sbDebug.Append(sLigne1 & vbCrLf) Me.m_sbDebug.Append(sLigne2 & vbCrLf) Me.m_sbDebug.Append(sLigne3 & vbCrLf) Me.m_sbDebug.Append(sLigne4 & vbCrLf) Me.m_sbDebug.Append(sLigne5 & vbCrLf) Me.m_sbDebug.Append(sLigne6 & vbCrLf) Me.m_sbDebug.Append(sLigne7 & vbCrLf) End If If enteteListe.self <> uiOffset Then Exit Function End If If enteteListe.back <> uiParent Then Exit Function End If If enteteListe.zero <> 0 Then Exit Function End If ' Read array of 3-word message descriptors. ' n = (Head.count >> 8) & 0xff; Dim lNbCourriels& = lDecalage(CLng(enteteListe.count), 8, &HFF) uiOffset += m_uiTailleTEnteteListe ' 24 Dim listeCourriel As TListeCourriel Dim lNumCourriels0& For lNumCourriels0 = 0 To lNbCourriels - 1 Me.m_br.BaseStream.Seek(uiOffset, SeekOrigin.Begin) listeCourriel.mail = Me.m_br.ReadUInt32() listeCourriel.head = Me.m_br.ReadUInt32() listeCourriel.int3 = Me.m_br.ReadUInt32() If iNivDebug >= 2 Then 'printf("%.8lx: list:: index %d / %d\n", offset, i, n); 'printf(" List.mail %.8lx\n", List.mail); 'printf(" List.head %.8lx\n", List.head); 'printf(" List.int3 %.8lx\n", List.int3); 'Dim sIndex$ = String.Format("{0:x8}", uiOffset) Dim sLigne10$ = String.Format( _ "{0:x8}: list:: index {1} / {2}", _ uiOffset, lNumCourriels0 + 1, lNbCourriels) Dim sLigne11$ = String.Format( _ " List.mail {0:x8}", listeCourriel.mail) Dim sLigne12$ = String.Format( _ " List.head {0:x8}", listeCourriel.head) Dim sLigne13$ = String.Format( _ " List.int3 {0:x8}", listeCourriel.int3) Me.m_sbDebug.Append(sLigne10).Append(vbCrLf) Me.m_sbDebug.Append(sLigne11).Append(vbCrLf) Me.m_sbDebug.Append(sLigne12).Append(vbCrLf) Me.m_sbDebug.Append(sLigne13).Append(vbCrLf) End If If listeCourriel.mail > 0 Then If Not bLireEnteteCourriel(listeCourriel.mail) Then _ Exit Function If Me.m_bAnnuler Then Exit For If Me.m_bMsgTrouve Then Exit For End If If listeCourriel.head > 0 Then ' L'astuce est ici ! ' s'il y a un entête, alors il faut le lire récursivement If Not bLireEnteteListe(listeCourriel.head, _ enteteListe.self) Then Exit Function End If uiOffset += m_uiTailleTListeCourriel If Me.m_bAnnuler Then Exit For If Me.m_bMsgTrouve Then Exit For Next lNumCourriels0 uiParent = enteteListe.self uiOffset = enteteListe.next1 If Me.m_bAnnuler Then Exit Do If Me.m_bMsgTrouve Then Exit Do Loop While uiOffset <> 0 bLireEnteteListe = True End Function Private Function bLireEnteteCourriel(ByVal uiOffset As UInteger) As Boolean ' mail_header Me.m_infoDbx.lNbCourriels += 1 Dim uiMemOffset As UInteger = uiOffset uiOffset = uiMemOffset 'DBX_READ(offset, &Mail, sizeof Mail); Me.m_br.BaseStream.Seek(uiOffset, SeekOrigin.Begin) Dim courriel As TCourriel courriel.self = Me.m_br.ReadUInt32() courriel.int2 = Me.m_br.ReadUInt32() courriel.count = Me.m_br.ReadUInt32() If iNivDebug >= 3 Then 'printf("%.8lx: mail::\n", offset); 'printf(" Mail.self %.8lx\n", Mail.self); 'printf(" Mail.int2 %.8lx\n", Mail.int2); 'printf(" Mail.count %.8lx\n", Mail.count); Dim sLigne1$ = String.Format( _ "{0:x8}: mail::", uiOffset) Dim sLigne2$ = String.Format( _ " Mail.self {0:x8}", courriel.self) Dim sLigne3$ = String.Format( _ " Mail.int2 {0:x8}", courriel.int2) Dim sLigne4$ = String.Format( _ " Mail.count {0:x8}", courriel.count) Me.m_sbDebug.Append(sLigne1).Append(vbCrLf) Me.m_sbDebug.Append(sLigne2).Append(vbCrLf) Me.m_sbDebug.Append(sLigne3).Append(vbCrLf) Me.m_sbDebug.Append(sLigne4).Append(vbCrLf) End If uiOffset += m_uiTailleTCourriel Dim lMemOffset& = uiOffset Dim sValHexG2$ = String.Format("{0:x8}", courriel.count) sValHexG2 = sValHexG2.Substring(0, 2) Dim iVal% = iConvHexa(sValHexG2) Dim bCourrielNonLu As Boolean = False If iVal Mod 2 = 0 Then bCourrielNonLu = True sValHexG2 = String.Format("{0:x8}", courriel.count) 'sValHexG2 = sValHexG2.Substring(0, 6) sValHexG2 = sValHexG2.Substring(0, 2) & "-" & sValHexG2.Substring(4, 4) ' Courriel.count est un 32 bit non signé, si on décale de 16 à droite ' on extrait donc les 2 octets de poids fort, ' puis on masque pour prendre les 2 derniers octets du poids fort ' on obtient presque tjrs 13 hexa = 19, et parfois 20 ' Ex.: 041301c8 -> --13---- : nb couples clé-val 'n = (Mail.count >> 16) & 0xff; Dim lNbCouplesCleValeur& = lDecalage(CLng(courriel.count), 16, &HFF) Dim lSender_offset& = 0 Dim lDate_offset& = 0 Dim lIndirect& = 0 Dim lMessage_offset& = 0 If lNbCouplesCleValeur > 0 Then Dim iccv As TInfoCourrielCleValeur If iNivDebug >= 4 Then ' printf("%.8lx: keys:: count %d", offset, n); Dim sLigne1$ = String.Format( _ "{0:x8}: keys:: count {1}", uiOffset, lNbCouplesCleValeur) Me.m_sbDebug.Append(sLigne1) '.Append(vbCrLf) 'Debug.WriteLine(sLigne1) End If Dim i& Dim lValueH80& = 0 Dim lValueH91& = 0 Dim uiTailleTInfoCourriel As UInteger = 4 For i = 0 To lNbCouplesCleValeur - 1 iccv.keyValue = Me.m_br.ReadUInt32() ' FFFFFF00 : 4294967040 ' 000000FF : 255 Dim lValue& = lDecalage(CLng(iccv.keyValue), 8, 0, &HFFFFFF00) Dim lkey& = (iccv.keyValue And &HFF) If iNivDebug >= 4 Then 'printf("%s%.6x-%.2x ", (i%6)? "":"\n ", Info.value, Info.key); Dim sLigne$ = String.Format(" {0:x6}-{1:x2}", lValue, lkey) If i Mod 6 = 0 Then Me.m_sbDebug.Append(vbCrLf & " ") Me.m_sbDebug.Append(sLigne) If i = lNbCouplesCleValeur - 1 Then Me.m_sbDebug.Append(vbCrLf) End If Select Case lkey Case &HE ' 0x0E : 14 lSender_offset = lValue Case &H12 ' 0x12 : 18 lDate_offset = lValue Case &H4 ' 0x04 : 4 lIndirect = 1 lMessage_offset = lValue Case &H84 ' 0x84 : 132 lMessage_offset = lValue Case &H80 lValueH80 = lValue Case &H91 lValueH91 = lValue End Select uiOffset += uiTailleTInfoCourriel Next i End If If lSender_offset = 0 And iNivDebug >= 1 Then 'WARNING("%s: Message %ld: No sender address\n", dbxpath, Sum.messages); Me.m_sbDebug.Append(String.Format( _ "{0}: Message {1}: No sender address", _ Me.m_infoDbx.sCheminDbx, Me.m_infoDbx.lNbCourriels)).Append(vbCrLf) End If 'ElseIf lDate_offset = 0 Then If lDate_offset = 0 And iNivDebug >= 1 Then Me.m_sbDebug.Append(String.Format( _ "{0}: Message {1}: Missing time stamp", _ Me.m_infoDbx.sCheminDbx, Me.m_infoDbx.lNbCourriels)).Append(vbCrLf) End If 'ElseIf lMessage_offset = 0 Then If lMessage_offset = 0 And iNivDebug >= 1 Then Me.m_sbDebug.Append(String.Format( _ "{0}: Message {1}: Empty message text", _ Me.m_infoDbx.sCheminDbx, Me.m_infoDbx.lNbCourriels)).Append(vbCrLf) End If Dim ic As TInfoCourriel = Nothing ic.bCourrielNonLu = bCourrielNonLu ic.sCodeHexa = sValHexG2 ic.lNumCourriel = Me.m_infoDbx.lNbCourriels ic.dDate = Now ic.dDateUTC = Date.UtcNow ic.bDateInvalide = True If Me.m_bEcrireDetail Or Me.m_bEcrireChamps Then Me.m_sbDetails.Append(vbCrLf & vbCrLf & _ "--- Dbx2Txt : Message suivant ---" & vbCrLf) Me.m_sbDetails.Append("Message n°" & ic.lNumCourriel & _ " / " & Me.m_infoDbx.lNbCourrielsTot & vbCrLf) End If 'If lSender_offset > 0 Then ' ' Create the special "From " line at top of email message. ' ... : cf + loin : déjà traité de façon générique et fiable 'End If If lDate_offset > 0 Then Dim lOffset& = uiOffset + lDate_offset Me.m_br.BaseStream.Seek(lOffset, SeekOrigin.Begin) Dim ui64time As ULong = Me.m_br.ReadUInt64() Dim dDate As Date = Now Dim dDateUtc As Date = Date.UtcNow Try dDate = DateTime.FromFileTime(CLng(ui64time)) dDateUtc = DateTime.FromFileTimeUtc(CLng(ui64time)) ic.bDateInvalide = False Catch End Try ic.dDate = dDate ic.dDateUTC = dDateUtc If m_bEcrireDetail Then ' Sauter une ligne car la ligne From et la date ne doivent ' pas faire partie d'un courriel véritable au format .eml Me.m_sbDetails.Append("Date : " & dDate.ToString) Me.m_sbDetails.Append(vbCrLf).Append(vbCrLf) End If End If If lMessage_offset > 0 Then If lIndirect = 1 Then uiOffset += CUInt(lMessage_offset) If bVerifierIndex(uiOffset) Then 'DBX_READ(offset + message_offset, &message_offset, sizeof (int32)); Me.m_br.BaseStream.Seek(uiOffset, SeekOrigin.Begin) lMessage_offset = Me.m_br.ReadUInt32() End If End If uiOffset = CUInt(lMessage_offset) If bVerifierIndex(uiOffset) Then If Not bLireCourriel(uiOffset, ic) Then Exit Function End If Else ' La date n'est pas bonne (heure d'hiver) et on n'a pas tjrs le sujet ' Cela arrive seulement pour les news.dbx If m_bEcrireSujets Then Me.m_sbSujets.Append( _ "Msg " & Me.m_infoDbx.lNbCourriels & "/" & _ Me.m_infoDbx.lNbCourrielsTot & _ " " & ic.dDate.ToShortDateString & " " & _ ic.dDate.ToShortTimeString & _ " []" & vbCrLf) End If bLireEnteteCourriel = True End Function Private Function bLireCourriel(ByVal uiOffset As UInteger, _ ByRef ic As TInfoCourriel) As Boolean ' fct mail_message Const sIndicSujet$ = "Subject: " Const sIndicDoubleSaut$ = vbCrLf & vbCrLf Const sIndicPJ$ = "-------=_Part0_" Const sIndicHtml$ = "Content-Type: text/html" ic.lTailleOctets = 0 ic.sDetail = "" ' Tout le courriel ic.sEntetes = "" ' Toutes les entetes ic.sContenu = "" ' Tout le contenu sans les pieces jointes ic.sSujet = "" ' Sujet ic.sSujetBrute = "" Me.m_sbCourriel = New StringBuilder Dim bExtraireCourriel As Boolean = False If ic.lNumCourriel = Me.m_iNumCourrielAExtraire Then bExtraireCourriel = True Me.m_bMsgTrouve = True End If If ic.lNumCourriel Mod 10 = 0 Or _ ic.lNumCourriel = Me.m_infoDbx.lNbCourrielsTot Or _ ic.lNumCourriel = 0 Then AfficherMsg("Lecture du courriel n°" & _ ic.lNumCourriel & "/" & Me.m_infoDbx.lNbCourrielsTot) End If Dim iTailleStructTText% = _ System.Runtime.InteropServices.Marshal.SizeOf( _ GetType(TTexte)) Dim ab() As Byte Const iTailleBloc% = 512 ReDim ab(iTailleBloc - 1) Dim txt As TTexte Dim resid& 'Dim abVerif As Byte 'Dim abVerifM1 As Byte Dim lMemOffset& = 0 Dim bSujetTrouve As Boolean = False Dim bSujetComplet As Boolean = False Dim bEntetesCompletes As Boolean = False Dim bContenuComplet As Boolean = False ' Sauf Pièces Jointes et contenu Html Dim bContenuHtmlComplet As Boolean = False ' Sauf Pièces Jointes Dim bNoterContenu As Boolean = False Dim bQuitter As Boolean = False Do Me.m_br.BaseStream.Seek(uiOffset, SeekOrigin.Begin) txt.self = Me.m_br.ReadUInt32() txt.size = Me.m_br.ReadUInt32() txt.count = Me.m_br.ReadUInt32() txt.next0 = Me.m_br.ReadUInt32() If iNivDebug >= 5 Then 'printf("\n%.8lx: text::\n", offset); 'printf(" Text.self %.8lx\n", Text.self); 'printf(" Text.size %.8lx\n", Text.size); 'printf(" Text.count %.8lx\n", Text.count); 'printf(" Text.next %.8lx\n", Text.next); Dim sLigne0$ = String.Format( _ "{0:x8}: text::", uiOffset) Me.m_sbDebug.Append(vbCrLf).Append(sLigne0).Append(vbCrLf) Dim sLigne1$ = String.Format(" Text.self {0:x8}", txt.self) Dim sLigne2$ = String.Format(" Text.size {0:x8}", txt.size) Dim sLigne3$ = String.Format(" Text.count {0:x8}", txt.count) Dim sLigne4$ = String.Format(" Text.next {0:x8}", txt.next0) Me.m_sbDebug.Append(sLigne1).Append(vbCrLf) Me.m_sbDebug.Append(sLigne2).Append(vbCrLf) Me.m_sbDebug.Append(sLigne3).Append(vbCrLf) Me.m_sbDebug.Append(sLigne4).Append(vbCrLf) End If If iNivDebug >= 6 Then If txt.self <> uiOffset Then Me.m_sbDebug.Append(vbCrLf & _ "Message n°" & ic.lNumCourriel & _ " : Avertissement : txt.self = " & txt.self & _ " <> " & uiOffset & " Offset" & vbCrLf & vbCrLf) End If If txt.size <> iTailleBloc Then Me.m_sbDebug.Append(vbCrLf & _ "Message n°" & ic.lNumCourriel & _ " : Avertissement : txt.size = " & txt.size & _ vbCrLf & vbCrLf) End If 'If txt.count <> iTailleBloc Then ' Me.m_sbDebug.Append(vbCrLf & _ ' "Message n°" & ic.lNumCourriel & _ ' " : Avertissement : txt.count = " & txt.count & _ ' vbCrLf & vbCrLf) 'End If 'Dim sOffsetHexa$ = String.Format("{0:x8}", uiOffset) 'Dim sVal$ = String.Format("{0:x8}", txt.next0) 'If sVal = "00022070" Then ' Debug.WriteLine("!") ' lMemOffset = txt.next0 'End If End If uiOffset += m_uiTailleTTexte ' 16 resid = txt.count If resid = 0 Or txt.count > iTailleBloc Then Me.m_sbDebug.Append(vbCrLf & _ "Message n°" & ic.lNumCourriel & _ " : Avertissement : txt.count = " & txt.count & _ vbCrLf & vbCrLf) GoTo Suite End If ' N.B. Text amount may be more or less than buffer size. Do Dim n% = CInt(Math.Min(resid, iTailleBloc)) ' Si le sujet est trouvé et complet et qu'on n'a pas besoin ' d'écrire tout le détail, alors ne compter que la taille : ToDo If Not bVerifierIndex(uiOffset) Then Exit Do Me.m_br.BaseStream.Seek(uiOffset, SeekOrigin.Begin) 'Dim iNbOctets% = me.m_br.Read(ab, 0, n) ab = Me.m_br.ReadBytes(n) Dim ac As Char() ReDim ac(n - 1) ab.CopyTo(ac, 0) 'abVerif = 0 'abVerifM1 = 0 'If ab.Length = n Then abVerif = ab(n - 1) 'If ab.Length = n And n >= 2 Then abVerifM1 = ab(n - 2) Dim sMsgPart$ = System.Convert.ToString(ac) If Not bContenuComplet Then ic.sContenu &= sMsgPart If bExtraireCourriel Or Me.m_bEcrireDetail Or Me.m_bEcrireChamps Then bNoterContenu = True Me.m_sbCourriel.Append(sMsgPart) End If ' La ligne Subject: peut être coupée au niveau d'un bloc ' et la fin elle-même peut être coupée : CrLf Dim iPosSujet% = -1 If Not bSujetTrouve Or Not bSujetComplet Then _ iPosSujet = ic.sContenu.IndexOf(sIndicSujet, _ StringComparison.InvariantCultureIgnoreCase) If iPosSujet > -1 Then bSujetTrouve = True iPosSujet += sIndicSujet.Length Dim iPosFin% = ic.sContenu.IndexOf(vbCrLf, iPosSujet) bSujetComplet = True If iPosFin < 0 Then bSujetComplet = False Else ic.sSujetBrute = ic.sContenu.Substring( _ iPosSujet, iPosFin - iPosSujet) End If End If If Not bEntetesCompletes Then Dim iPosCrLf% = ic.sContenu.IndexOf(sIndicDoubleSaut) If iPosCrLf >= 0 Then ic.sEntetes = ic.sContenu.Substring(0, iPosCrLf) bEntetesCompletes = True End If End If If Not bContenuComplet And Me.m_bExtraireContenu Then ' Si Html, arreter ici l'extraction Dim iPosHtml% = ic.sContenu.IndexOf(sIndicHtml) If iPosHtml >= 0 Then bContenuComplet = True ic.sContenu = ic.sContenu.Substring(0, iPosHtml) If bNoterContenu Then 'Me.m_sbCourriel.Capacity = iPosHtml iPosHtml += sIndicHtml.Length Me.m_sbCourriel.Remove(iPosHtml, _ Me.m_sbCourriel.Length - iPosHtml) End If End If End If If (Not bContenuComplet And Me.m_bExtraireContenu) Or _ (Not bContenuHtmlComplet And Me.m_bExtraireContenuHtml) Then ' Si Pièce jointe ou bien Html, arreter ici l'extraction Dim iPosPJ% = ic.sContenu.IndexOf(sIndicPJ) If iPosPJ >= 0 Then bContenuComplet = True bContenuHtmlComplet = True ic.sContenu = ic.sContenu.Substring(0, iPosPJ) If bNoterContenu Then iPosPJ += sIndicPJ.Length Me.m_sbCourriel.Remove(iPosPJ, _ Me.m_sbCourriel.Length - iPosPJ) End If End If End If bQuitter = False If bSujetComplet And Me.m_bEcrireSujets Then bQuitter = True If bEntetesCompletes And Me.m_bExtraireChamps Then bQuitter = True If bContenuComplet And Me.m_bExtraireContenu Then bQuitter = True If bContenuHtmlComplet And Me.m_bExtraireContenuHtml Then bQuitter = True ' Conditions prioritaires If iNivDebug >= 5 Then bQuitter = False If bExtraireCourriel Then bQuitter = False If bQuitter Then Exit Do ComptageTailleCourriel: uiOffset += CUInt(n) ic.lTailleOctets += n resid -= n Loop While resid > 0 Suite: If bQuitter Then Exit Do uiOffset = txt.next0 If Not bVerifierIndex(uiOffset) Then Exit Do Loop While uiOffset <> 0 If Not bEntetesCompletes Then ' Si le contenu du msg est vide, alors l'entete est complete maintenant ic.sEntetes = ic.sContenu bEntetesCompletes = True End If If Me.m_bEcrireDetail Or Me.m_bEcrireChamps Or _ Me.m_bExtraireContenu Or Me.m_bExtraireContenuHtml Then Me.m_sbDetails.Append(Me.m_sbCourriel) End If If m_bExtraireChamps Then ic.sDetail = Me.m_sbCourriel.ToString '' Les 2 derniers car se terminent bien par 13 10 (vbCrLf) 'If abVerif <> 10 Then ' Dim sLigne$ = String.Format( _ ' "{0}: Message {1}: Missing final newline\n", _ ' Me.m_infoDbx.sCheminDbx, ic.lNumCourriel) ' Me.m_sbDebug.Append(vbCrLf & sLigne & vbCrLf) 'End If ' La version en c trouve des fausses anomalies : sans doute bug : ' (on ne retrouve que certaines anomalies, en petit nombre seulement) 'if (c != '\n') { ' WARNING("%s: Message %ld: Missing final newline\n", dbxpath, Sum.messages); ' fputc('\n', output); } InitChamps(ic) AnalyserChamps(ic, bExtraireCourriel) bLireCourriel = True End Function Private Function bVerifierIndex(ByVal uiOffset As UInteger) As Boolean If uiOffset <= Me.m_infoDbx.lTailleFichier Then _ bVerifierIndex = True : Exit Function Me.m_sbDebug.Append(vbCrLf & _ "Message n°" & Me.m_infoDbx.lNbCourriels & _ " : Erreur : L'index dépasse la longueur du fichier." & _ vbCrLf & vbCrLf) If bDebug Then Debug.WriteLine("Déraillage !") End Function #End Region #Region "Analyse des champs" Public Sub Initialisation() Me.m_bEcrireSujets = False Me.m_bEcrireDetail = False Me.m_bEcrireChamps = False Me.m_bExtraireChamps = False Me.m_bExtraireContenu = False Me.m_bExtraireContenuHtml = False Me.m_bAnalyserChamps = False Me.m_iNumCourrielAExtraire = 0 End Sub Private Sub InitChamps(ByRef ic As clsDbx.TInfoCourriel) ic.sListeCheminements = sChpAbsent ic.sDateEmission = sChpAbsent ic.sAdresseRetour = sChpAbsent ic.sRepondreA = sChpAbsent ic.sDestFAI = sChpAbsent ic.sMEUUID = sChpAbsent ic.sMsgID = sChpAbsent ic.sMsgID_Domaine = sChpAbsent ic.sExpediteurNom = sChpAbsent : ic.sExpediteurCourriel = sChpAbsent ic.sExpediteurComplet = sChpAbsent ic.iNbDestinataires = 0 ic.sDestinataires = sChpAbsent ic.iNbDestinatairesCopie = 0 ic.sDestinatairesCopie = sChpAbsent ' Version 1.03 du 11/11/2007 ic.sDomaineDest = "" 'sChpAbsent ic.sDomaineDestFAI = "" ic.sDestinataireNom = "" ic.sDestinataireCourriel = "" ic.bDomaineExpDestIdem = False ic.sDestinatairesCopieCachee = sChpAbsent ic.iNbDestinatairesCopieCachee = 0 ic.sPriorite = sChpAbsent ic.sPrioriteMSMail = sChpAbsent ic.sMailer = sChpAbsent '"" ic.sMimeOLE = sChpAbsent ic.sMIMEVersion = sChpAbsent ic.sContentTransferEncoding = sChpAbsent ic.sTypesContenu = sChpAbsent ic.sSousTypeContenu = sChpAbsent ic.sMsgInfo = sChpAbsent ic.sXOriginalArrivalTime = sChpAbsent ic.sStatut = sChpAbsent ic.sContentLength = sChpAbsent ic.iCharset = iValAbsent '0 ic.sCharset = sChpAbsent ic.bHtml = False ic.bFormatFlowed = False ic.sTypeMultipart = sChpAbsent ic.iTypeMultipart = iValAbsent ic.bAdresseRetourDiff = True ic.iNbChps = 0 : ic.iNbChpsStdr = 0 RaiseEvent EvChampDepart() End Sub Private Sub AnalyserChamps(ByRef ic As clsDbx.TInfoCourriel, _ ByVal bExtraireCourriel As Boolean) Dim asEntetes$() = ic.sEntetes.Split(CChar(vbCrLf)) Dim sEntete$ Dim sMemCle$ = "" Dim sMemVal$ = "" Dim bTraiterListe As Boolean = False For Each sEntete In asEntetes sEntete = sEntete.Trim If sEntete.Length <= 0 Then Continue For Dim iPos% = sEntete.IndexOf(":") Dim sCle$ = "" Dim sVal$ = "" Dim sValMultiligne$ = "" If iPos <= 0 Then ' S'il n'y a pas : alors c'est la suite du champ précédent sCle = sMemCle sVal = sEntete sValMultiligne = sMemVal & sVal 'Continue For Else 'If iPos > 0 Then sCle = sEntete.Substring(0, iPos + 1) ' à 99.99% il y a un espace après, mais pas tjrs 'sVal = (Mid$(sEntete, iPos + 3)).Trim sVal = (Mid$(sEntete, iPos + 2)).Trim sValMultiligne = sVal End If If sVal.Length = 0 Then sVal = sChpVide sMemCle = sCle sMemVal = sVal Dim sVal2$ = sTraiterVirguleFin(sVal) Dim sCleMin$ = sCle.ToLower ic.iNbChps += 1 bTraiterListe = False Select Case sCleMin Case "from:" ic.sExpediteurComplet = sVal ExtraireCourriel(sVal, ic.sExpediteurNom, ic.sExpediteurCourriel) ic.iNbChpsStdr += 1 Case "to:" If ic.sDestinataires = sChpAbsent Then ic.sDestinataires = sVal2 Else ic.sDestinataires &= sSeparateurListe & sVal2 End If ic.iNbChpsStdr += 1 bTraiterListe = True Case "date:" ic.sDateEmission = sVal ic.iNbChpsStdr += 1 Case "subject:" ic.sSujetBrute = sValMultiligne ic.iNbChpsStdr += 1 Case "received:" ' Liste If ic.sListeCheminements = sChpAbsent Then ic.sListeCheminements = sVal Else ic.sListeCheminements &= sSeparateurListe & sVal End If ic.iNbChpsStdr += 1 bTraiterListe = True Case "return-path:" Dim sNom$ = "" ' on ne le garde pas If ic.sAdresseRetour = sChpAbsent Then ' Il peut arriver que ce chp soit présent en double ' dans ce cas, on note dans l'autre chp ExtraireCourriel(sVal, sNom, ic.sRepondreA) Else ExtraireCourriel(sVal, sNom, ic.sAdresseRetour) End If ic.iNbChpsStdr += 1 Case "reply-to:" Dim sNom$ = "" ' on ne le garde pas ExtraireCourriel(sVal, sNom, ic.sRepondreA) ic.iNbChpsStdr += 1 Case "delivered-to:" ic.sDestFAI = sVal ic.iNbChpsStdr += 1 Case "cc:" If ic.sDestinatairesCopie = sChpAbsent Then ic.sDestinatairesCopie = sVal2 Else ic.sDestinatairesCopie &= sSeparateurListe & sVal2 End If ic.iNbChpsStdr += 1 bTraiterListe = True Case "bcc:" ' Liste If ic.sDestinatairesCopieCachee = sChpAbsent Then ic.sDestinatairesCopieCachee = sVal2 Else ic.sDestinatairesCopieCachee &= sSeparateurListe & sVal2 End If ic.iNbChpsStdr += 1 bTraiterListe = True Case "message-id:" ic.sMsgID = sVal ic.iNbChpsStdr += 1 Dim iPos0% = ic.sMsgID.IndexOf("@") If iPos0 >= 0 And ic.sMsgID.Length > iPos0 + 2 Then ic.sMsgID_Domaine = Mid$(ic.sMsgID, iPos0 + 2) ic.sMsgID_Domaine = ic.sMsgID_Domaine.Replace(">", "") Else ' Si pas de @, prendre le dernier bloc ' par exemple xxxxx.MonDomaine.fr -> MonDomaine.fr iPos0 = ic.sMsgID.LastIndexOf(".") If iPos0 >= 1 Then iPos0 = ic.sMsgID.LastIndexOf(".", iPos0 - 1) If iPos0 > 2 Then _ ic.sMsgID_Domaine = Mid$(ic.sMsgID, iPos0 + 2) End If End If Case "mime-version:" ic.sMIMEVersion = sVal ic.iNbChpsStdr += 1 Case "x-priority:" ic.sPriorite = sVal ic.iNbChpsStdr += 1 Case "x-msmail-priority:" ic.sPrioriteMSMail = sVal ic.iNbChpsStdr += 1 Case "x-mimeole:" ic.sMimeOLE = sVal ic.iNbChpsStdr += 1 Case "x-mailer:" ic.sMailer = sVal ic.iNbChpsStdr += 1 Case "content-type:" ' Liste If ic.sTypesContenu = sChpAbsent Then ic.sTypesContenu = sVal2 Else ic.sTypesContenu &= sSeparateurListe & sVal2 End If ic.iNbChpsStdr += 1 bTraiterListe = True Case "content-transfer-encoding:" ic.sContentTransferEncoding = sVal ic.iNbChpsStdr += 1 Case "x-originalarrivaltime:" : ic.sXOriginalArrivalTime = sVal '19% Case "status:" : ic.sStatut = sVal '13% Case "content-length:" : ic.sContentLength = sVal ' 12% Case "x-me-uuid:" : ic.sMEUUID = sVal ' 2% Case "x-message-info:" : ic.sMsgInfo = sVal '0.01% Case "sender:", "x-sender:", "x-x-sender:", "x-sent-thru:" Case "x-unsent:" Case "x-gmail-received:" Case "importance:" '10%-5% Case "x-id:", "x_uid:", "list-id:", "x-edatis-id:" Case "x-accept-language:", "x-language:", "language:", "x-uidl:" Case "x-virus-scanned:", "x-original-date:", "x-original-return-path:" Case "x-mailman-version:", "x-ip:", "x-cs-ip:", "x-originating-ip:", "x-antiabuse:", "x-scanner:" Case "thread-index:", "organization:", "in-reply-to:" Case "user-agent:", "fcc:" Case "x-identity-key:", "x-antivirus:", "x-antivirus-status:", "x-beenthere:" Case "x-spam-status:", "x-spam-level:", "x-spam-checker-version:" Case "error-to:", "errors-to:", "content-location:", "content-class:", "references:" Case "x-originating-email:", "content-description:", "page-id:" Case "date-warning:", "content-description:", "content-disposition:" Case "approved-by:", "authentication-results:", "received-spf:", "x-keywords:" Case "x-authentication-warning:", "content-encoding:" Case "x-spam:", "alternate-recipient:", "x-original-to:" Case "x-nai-spam-score:", "x-nai-spam-rules", "x-nai-spam-level" Case "x-virus-status:", "x-mimi-autoconverted:" Case Else 'Debug.WriteLine(sCle & " : " & sVal) 'm_sbDetails.Append(sCle & ":" & sVal).Append(vbCrLf) End Select ' Analyse des champs ' Traiter les listes complètes seulement If bTraiterListe Then Continue For If Not m_bAnalyserChamps Then Continue For If sCle.Length = 0 Then Continue For ' Une vrai clé ne contient pas d'espace : ' enlever toutes les lignes coupées If sCle.IndexOf(" "c) > 0 Then Continue For If Not Me.m_bAnalyserChamps Then Continue For Dim sChamp$ = sCle Dim sValChp$ = sVal RaiseEvent EvChamp(sChamp, sValChp) Next sEntete ic.sSujet = sDecoderIso(ic.sSujetBrute, ic.bSujetISO) ic.sSujet = sTraiterCloudMark(ic.sSujet, ic.bSpamSelonCloudmark) If m_bEcrireSujets Then 'If ic.bCourrielNonLu Then 'If ic.sCodeHexa <> "01-0000" Then If bDebugCourrierNonLu Then Me.m_sbSujets.Append(ic.sCodeHexa & " ") Me.m_sbSujets.Append( _ "Msg " & ic.lNumCourriel & "/" & Me.m_infoDbx.lNbCourrielsTot & _ " " & ic.dDate.ToShortDateString & " " & ic.dDate.ToShortTimeString & _ " [" & ic.sSujet & "]") 'If ic.bCourrielNonLu Then Me.m_sbSujets.Append(" (non lu)").Append(ic.sCodeHexa) Me.m_sbSujets.Append(vbCrLf) 'End If End If If Me.m_bAnalyserChamps Then RaiseEvent EvChamp("To:", ic.sDestinataires) RaiseEvent EvChamp("Received:", ic.sListeCheminements) RaiseEvent EvChamp("cc:", ic.sDestinatairesCopie) RaiseEvent EvChamp("bcc:", ic.sDestinatairesCopieCachee) End If ' "boundary = " ou "boundary=" TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ "charset=", sListeValCharset, ic.sCharset) TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ "type=", sListeValType, ic.sSousTypeContenu) ic.iCharset = iValListe(ic.sCharset, Me.m_asListeValCharset) TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ sValSousChp2:="text/html", bSousChp2:=ic.bHtml) Dim bMixed, bAlternative, bRelated As Boolean TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ sValSousChp2:="multipart/mixed", bSousChp2:=bMixed) TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ sValSousChp2:="multipart/alternative", bSousChp2:=bAlternative) TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ sValSousChp2:="multipart/related", bSousChp2:=bRelated) ic.iTypeMultipart = iValAbsent ic.sTypeMultipart = sChpAbsent If bMixed Then ic.iTypeMultipart = 1 ic.sTypeMultipart = "Mixed" ElseIf bAlternative Then ic.iTypeMultipart = 2 ic.sTypeMultipart = "Alternative" ElseIf bRelated Then ic.iTypeMultipart = 3 ic.sTypeMultipart = "Related" If ic.sSousTypeContenu.ToLower = "multipart/alternative" Then ic.iTypeMultipart = 4 ic.sTypeMultipart = "Related/Altern." End If End If If Me.m_bAnalyserChamps Then Dim sFormat$ = "" TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ "format=", " flowed ", sFormat) End If TraiterListeChps("Content-Type:", ic.sTypesContenu, _ sListeValChpsCont, "boundary", _ sValSousChp2:="format=flowed", bSousChp2:=ic.bFormatFlowed) ic.iNbDestinataires = iCompterElementsListe(ic.sDestinataires) ic.iNbDestinatairesCopie = iCompterElementsListe(ic.sDestinatairesCopie) ic.iNbDestinatairesCopieCachee = iCompterElementsListe(ic.sDestinatairesCopieCachee) 'ic.sAdresseRetour = sEnleverDelimiteurCourriel(ic.sAdresseRetour) ' Si l'un ou l'autre des chps correspond à l'exp, ok If ic.sExpediteurCourriel = ic.sAdresseRetour Or _ ic.sExpediteurCourriel = ic.sRepondreA Then ic.bAdresseRetourDiff = False End If ' Vérifier si le domaine du destinataire est celui de l'expéditeur : spam potentiel ic.bDomaineExpDestIdem = False If ic.iNbDestinataires = 1 Then ExtraireCourriel(ic.sDestinataires, ic.sDestinataireNom, ic.sDestinataireCourriel) ic.sDomaineDest = sExtraireDomaine(ic.sDestinataireCourriel) ic.sDomaineDestFAI = sExtraireDomaine(ic.sDestFAI) If ic.sDomaineDest.ToLower = ic.sMsgID_Domaine.ToLower Then ic.bDomaineExpDestIdem = True End If End If If bExtraireCourriel Then Me.m_ic = ic RaiseEvent EvCourriel(ic) End Sub #End Region #Region "Utilitaires" Private Sub AfficherMsg(ByVal sInfo$) Me.m_msgDelegue.AfficherMsg(sInfo) End Sub Private Function iValListe%(ByVal sVal$, ByVal asListeVal$()) If sVal.Length = 0 Then iValListe = iValAbsent : Exit Function sVal = sVal.ToLower Dim sVal0$ Dim iCompteur% = 0 For Each sVal0 In asListeVal If sVal0.Length = 0 Then Continue For iCompteur += 1 If sVal0 = sVal Then iValListe = iCompteur : Exit Function Next iCompteur += 1 iValListe = iCompteur End Function Private Function iCompterElementsListe%(ByVal sListe$) ' Compter les éléments d'une liste séparés par une virgule , iCompterElementsListe = 0 If sListe.Length > 0 Then iCompterElementsListe = 1 If sListe.IndexOf(",") > 0 Then iCompterElementsListe = sListe.Split(","c).GetUpperBound(0) + 1 End If End Function Private Sub ExtraireCourriel(ByVal sAgent$, ByRef sNom$, ByRef sCourriel$) ' Extraire le courriel et le nom d'un expéditeur ou destinaitaire ' "Patrice Dargenton" <patrice.dargenton@free.fr -> ' Nom = Patrice Dargenton, Courriel = patrice.dargenton@free.fr sNom = "" : sCourriel = "" Dim iPosSup% = sAgent.IndexOf("<") If iPosSup = -1 Then sCourriel = sAgent : Exit Sub If iPosSup > 0 Then sNom = sAgent.Substring(0, iPosSup).Trim sNom = sDecoderIso(sNom) End If Dim iLen% = sAgent.Length - iPosSup - 2 ' Entetes incomplètes If iLen <= 0 Then sCourriel = sAgent : Exit Sub sCourriel = sAgent.Substring(iPosSup + 1, sAgent.Length - iPosSup - 2).Trim End Sub Private Function sExtraireDomaine$(ByVal sCourriel$) sExtraireDomaine = "" If sCourriel.Length = 0 Then Exit Function Dim iPos% = sCourriel.IndexOf("@") If Not (iPos >= 0 And sCourriel.Length > iPos + 2) Then Exit Function sExtraireDomaine = Mid$(sCourriel, iPos + 2) End Function Private Function sTraiterCloudMark$(ByVal sSujet$, ByRef bSpam As Boolean) ' Enlever [Scanned by Cloudmark] dans le sujet si spam ' + [Scanned by SafetyBar] [Scanned by SpamNet] If Not sSujet.StartsWith("[Scanned by") Then _ sTraiterCloudMark = sSujet : Exit Function Dim iPos% = sSujet.IndexOf("]") ' Anomalie : ToDo If iPos = -1 Then sTraiterCloudMark = sSujet : Exit Function Dim iLong% = sSujet.Length If iPos + 3 > iLong Then iPos = iLong - 2 sTraiterCloudMark = Mid$(sSujet, iPos + 3) bSpam = True End Function Private Function sDecoderIso$(ByVal sTexte$, _ Optional ByRef bTexteISO As Boolean = False) ' Décoder un sujet (ou bien un nom d'expéditeur) de courriel codé ISO-8859-* ' La méthode utilisée est assez sommaire, voir ici pour faire plus complet : ' http://fr.wikipedia.org/wiki/ISO_8859-15 If sTexte.ToLower.IndexOf("=?iso-") < 0 Then _ sDecoderIso = sTexte : Exit Function bTexteISO = True 'Const sIndicIso1$ = "ISO-8859-1?Q?" 'Const sIndicIso15$ = "ISO-8859-15?Q?" 'Const sIndicIso2022$ = "ISO-2022-" Const sIndicIso8859$ = "ISO-8859-" 'Const sIndicIso15$ = "ISO-8859-15?Q?" Const sIndicIso2022$ = "ISO-2022-" Const sIndicIso8859_1$ = "ISO-8859-1?" Const sIndicIso8859_1Q$ = "ISO-8859-1?Q?" Const sIndicIso8859_2Q$ = "ISO-8859-2?Q?" Const sIndicIso8859_15Q$ = "ISO-8859-15?Q?" 'Const sIndicIso1Min$ = "iso-8859-1?Q?" 'Const sIndicIso15Min$ = "iso-8859-15?Q?" ' Avec un antispam, l'indicateur peut etre décalé 'If sTexte.StartsWith("=?" & sIndicIso15) Then Dim sTexteOrig$ = sTexte If sTexte.IndexOf(sIndicIso8859, StringComparison.OrdinalIgnoreCase) >= 0 Or _ sTexte.IndexOf(sIndicIso2022, StringComparison.OrdinalIgnoreCase) >= 0 Then sTexte = sRemplacerTexteIso(sTexte, sIndicIso8859_15Q) sTexte = sRemplacerTexteIso(sTexte, sIndicIso8859_1Q) sTexte = sRemplacerTexteIso(sTexte, sIndicIso8859_1) sTexte = sRemplacerTexteIso(sTexte, sIndicIso8859_2Q) sTexte = sRemplacerTexteIso(sTexte, sIndicIso2022) If sTexte.StartsWith(sGm) And sTexte.EndsWith(sGm) Then sTexte = sTexte.Substring(1, sTexte.Length - 2) End If If sTexte.StartsWith("=?") And sTexte.EndsWith("?=") Then sTexte = sTexte.Substring(2, sTexte.Length - 4) Else Dim iPos0% = sTexte.IndexOf("=?") If iPos0 >= 0 And sTexte.EndsWith("?=") Then Dim sTexte2$ = sTexte.Substring(0, iPos0) & _ sTexte.Substring(iPos0 + 2, sTexte.Length - iPos0 - 4) sTexte = sTexte2 End If End If While True Dim iPos% = sTexte.IndexOf("="c) If iPos < 0 Then Exit While ' Pour le moment, simplement remplacer le caractère ISO ' par un espace, cf. wikipedia pour le décodage exact ' Taiter seulement [] Dim iPos0% = sTexte.IndexOf("=5B") If iPos0 = iPos Then sTexte = sRemplacerIso(sTexte, "=5B", iPos0, "[") GoTo Suite End If iPos0 = sTexte.IndexOf("=5D") If iPos0 = iPos Then sTexte = sRemplacerIso(sTexte, "=5D", iPos0, "]") GoTo Suite End If Dim sTexte2$ = "" If iPos = 0 Then iPos -= 1 Else sTexte2 = sTexte.Substring(0, iPos) & " " End If If sTexte.Length >= iPos + 3 Then sTexte2 &= sTexte.Substring(iPos + 3) End If sTexte = sTexte2 Suite: End While ' Remplacer les soulignés par des espaces sTexte = sTexte.Replace("_", " ") End If sDecoderIso = sTexte End Function Private Function sRemplacerTexteIso$(ByVal sTexte$, ByVal sIndic$) sRemplacerTexteIso = sTexte.Replace(sIndic, "") Dim sIsoMin$ = sIndic.Replace("ISO", "iso") sRemplacerTexteIso = sRemplacerTexteIso.Replace(sIsoMin, "") End Function Private Function sRemplacerIso$(ByVal sTexte$, ByVal sCarIsoIn$, _ ByVal iPos%, ByVal sCarIsoOut$) If iPos = 0 Then sRemplacerIso = sCarIsoOut & sTexte.Substring(iPos + 3) Exit Function End If sRemplacerIso = sTexte.Substring(0, iPos) & sCarIsoOut & _ sTexte.Substring(iPos + 3) End Function Private Function sTraiterVirguleFin$(ByVal sElement$) If sElement.EndsWith(",") Or sElement.EndsWith(";") Then sTraiterVirguleFin = sElement.Substring(0, sElement.Length - 1) Else sTraiterVirguleFin = sElement End If End Function Private Sub TraiterListeChps(ByVal sChp$, ByVal sListe$, _ ByVal sListeValChps$, _ Optional ByVal sChpAExclure$ = "", _ Optional ByVal sSousChp$ = "", _ Optional ByVal sListeValSousChps$ = "", _ Optional ByRef sValSousChps$ = "", _ Optional ByRef sValSousChp2$ = "", _ Optional ByRef bSousChp2 As Boolean = False) ' Analyse d'une liste selon des éléments attendus à encoder Dim asVal$() = sListe.Split(Me.m_acSepListe) Dim sVal$, sValChp$ Dim bAuMoins1ValSousChp As Boolean = False For Each sVal In asVal sValChp = sVal.Trim.ToLower If sValChp.Length = 0 Then Continue For If sChpAExclure.Length > 0 AndAlso _ sValChp.StartsWith(sChpAExclure) Then Continue For ' Ex.: charset="UTF-8" -> charset=UTF-8 sValChp = sValChp.Replace(""""c, "") If sSousChp.Length > 0 AndAlso sValChp.StartsWith(sSousChp) Then ' Présence d'un sous-champ de type TypeChp = valChp, ' par ex.: charset=xxx sValChp = Mid$(sValChp, sSousChp.Length + 1) If bAuMoins1ValSousChp Then ' Il peut y avoir plusieurs fois la même balise ! (avec la même valeur) Continue For End If bAuMoins1ValSousChp = True If bUtiliserCodageAutre AndAlso _ sListeValSousChps.Length > 0 AndAlso _ sListeValSousChps.IndexOf(sValChp) < 0 Then sValChp = sValChpAutre End If sValSousChps = sValChp ' Retourner la valeur du sous-champ If Not Me.m_bAnalyserChamps Then Continue For ' Indexer les valeurs possibles du sous-chp RaiseEvent EvChamp(sSousChp, sValSousChps) Continue For ElseIf sValSousChp2.Length > 0 AndAlso sValChp = sValSousChp2 Then ' Présence d'un sous-champ de type valChp, ' par ex.: text/html bSousChp2 = True Continue For ElseIf sListeValChps.IndexOf(sValChp) < 0 Then sValChp = sValChpAutre End If ' Indexer les chps If Not Me.m_bAnalyserChamps Then Continue For RaiseEvent EvChamp(sChp, sValChp) Next If Not Me.m_bAnalyserChamps Then Exit Sub If bAuMoins1ValSousChp Then Exit Sub If sSousChp.Length = 0 Then Exit Sub ' Ajouter la valeur [Autre] à la valeur possible du sous-champ analysé RaiseEvent EvChamp(sSousChp, sChpAbsent) End Sub #End Region End Class modDepart.vb ' Fichier modDepart.vb ' -------------------- Module modDepart ' Avec VBExpress 2005, pour choisir le mode debug ou pas, il faut ' sélectionner le menu Build : Configuration Manager... Debug ou Release ' ... mais pour voir ce menu, il faut le demander !!! ' menu Tools : Options... : Projets and Solutions : "Show Advanced Build Configuration" ' inutile donc de définir la constante DEBUG directement : '#Const DEBUG = True '#Const DEBUG = False #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 sTitreMsg$ = "VBSpamCheck" Public Const sMsgOperationTerminee$ = "Opération terminée." Public Sub Main() ' S'il n'y a aucune gestion d'erreur, on peut déboguer dans l'IDE ' Sinon, ce n'est pas pratique de retrouver la ligne du bug : ' il faut cocher Thrown dans le menu Debug:Exception... pour les 2 lignes ' (dans ce cas, il peut y avoir beaucoup d'interruptions selon la logique ' de programmation : mieux vaut prévenir les erreurs que de les traiter) ' C'était plus simple avec On Error Goto X, car on pouvait ' désactiver la gestion d'erreur avec une simple constante bTrapErr. If bDebug Then Depart() : Exit Sub ' Attention : En mode Release il faut un Try Catch ici ' car sinon il n'y a pas de gestion d'erreur ! ' (.Net renvoie un message d'erreur équivalent ' à un plantage complet sans explication) Try Depart() Catch ex As Exception AfficherMsgErreur2(ex, "Main " & sTitreMsg) End Try End Sub Private Sub Depart() If bAppliDejaOuverte(bMemeExe:=True) Then Exit Sub ' Extraire les options passées en argument de la ligne de commande ' Ne fonctionne pas avec des chemins contenant des espaces, même entre guillemets 'Dim asArgs$() = Environment.GetCommandLineArgs() Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command Dim sCheminDbx$ = "" Dim sCodeMenu$ = "" Const sInfoArg$ = "Arguments : CheminDbx [CheminDbx] CodeMenu [CodeMenu] ou bien directement [CheminDbx]" & vbLf & _ "Exemple n°1 : CheminDbx ""C:\Mes Courriels\Spam.dbx"" CodeMenu VD" & vbLf & _ "Exemple n°2 : ""C:\Mes Courriels\Spam.dbx""" & vbLf & _ "Pensez à mettre entre guillemets les chemins contenant des espaces" If sArg0 <> "" Then Dim asArgs$() = asArgLigneCmd(sArg0) Dim iNbArgs% = UBound(asArgs) + 1 If iNbArgs = 1 Then ' S'il n'y a qu'un argument, alors c'est le chemin du dbx sCheminDbx = asArgs(0) Else Dim iNumArg1% For iNumArg1 = 0 To (iNbArgs - 1) \ 2 Dim sCle$ = asArgs(iNumArg1 * 2) If iNumArg1 * 2 + 1 > UBound(asArgs) Then MsgBox("Erreur : Nombre impair d'arguments !" & vbLf & sInfoArg, _ MsgBoxStyle.Critical, sTitreMsg) Exit Sub End If Dim sVal$ = asArgs(iNumArg1 * 2 + 1) Select Case sCle.ToLower Case "CheminDbx".ToLower sCheminDbx = sVal Case "CodeMenu".ToLower sCodeMenu = sVal Case Else MsgBox("Erreur : Argument non reconnu : [" & sCle & "]" & vbLf & sInfoArg, _ MsgBoxStyle.Critical, sTitreMsg) Exit Sub End Select Next iNumArg1 End If End If Dim oFrm As New frmVBSpamCheck oFrm.m_sCheminDBX = sCheminDbx oFrm.m_sCodeMenu = sCodeMenu ' ShowDialog ne fonctionne pas si aucune session n'est ouverte 'oFrm.ShowDialog() Application.Run(oFrm) End Sub End Module clsAfficherMsg.vb ' Fichier clsAfficherMsg.vb : Classes de gestion des messages via des délégués ' ------------------------- Public Class clsMsgEventArgs : Inherits EventArgs Private m_sMsg$ = Nothing Public Sub New(ByVal sMsg$) If sMsg Is Nothing Then Throw New NullReferenceException Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property End Class Public Class clsMsgDelegue Public Delegate Sub GestEvAfficherMessage(ByVal sender As Object, ByVal e As clsMsgEventArgs) Public Event EvAfficherMessage As GestEvAfficherMessage Public m_bAnnuler as Boolean Public Sub New() End Sub Public Sub AfficherMsg(ByVal sMsg$) Dim e As clsMsgEventArgs = New clsMsgEventArgs(sMsg) RaiseEvent EvAfficherMessage(Me, e) End Sub End Class modUtilFichier.vb ' Fichier modUtilFichier.vb : Module de gestion des fichiers ' ------------------------- Imports System.Text ' Pour StringBuilder 'Imports System.IO ' Pour Path, File, Directory... Module modUtilFichier Public Const sCauseErrPoss$ = _ "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" Public Const sCauseErrPossDossier$ = _ "Le dossier est peut-être protégé en écriture" & vbLf & _ "ou bien un fichier est verrouillé par une autre application" #Region "Gestion des fichiers" Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _ ByVal sTitre$, Optional ByVal sInitDir$ = "", _ Optional ByVal bDoitExister As Boolean = True) As Boolean ' Afficher une boite de dialogue pour choisir un fichier ' Exemple de filtre : "|Fichiers texte (*.txt)|*.txt|Tous les fichiers (*.*)|*.*" ' On peut indiquer le dossier initial via InitDir, ou bien via le chemin du fichier Static bInit As Boolean = False Dim ofd As New OpenFileDialog With ofd If Not bInit Then bInit = True If sInitDir.Length = 0 Then If sCheminFichier.Length = 0 Then .InitialDirectory = Application.StartupPath Else .InitialDirectory = IO.Path.GetDirectoryName(sCheminFichier) End If Else .InitialDirectory = sInitDir End If End If If sCheminFichier.Length > 0 Then .FileName = sCheminFichier ' 14/10/2007 .CheckFileExists = bDoitExister ' 14/10/2007 .DefaultExt = sExtDef .Filter = sFiltre .Multiselect = False .Title = sTitre .ShowDialog() If .FileName <> "" Then bChoisirFichier = True : sCheminFichier = .FileName End With 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 bFichierExisteFiltre(ByVal sCheminFiltre$, ByVal sFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si au moins un fichier correspondant au filtre est trouvé ' dans le répertoire indiqué, ex.: C:\Tmp avec *.txt Dim di As New IO.DirectoryInfo(sCheminFiltre) Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre = (iNbFichiers > 0) If Not bFichierExisteFiltre And bPrompt Then _ MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _ MsgBoxStyle.Critical, sTitreMsg & " - Fichiers introuvables") End Function Public Function iNbFichiersFiltres%(ByVal sCheminDossier$, ByVal sFiltre$) ' Retourner le nombre de fichiers correspondants au filtre, par exemple : C:\ avec *.txt Dim di As New IO.DirectoryInfo(sCheminDossier) If Not di.Exists Then Exit Function Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo iNbFichiersFiltres = fi.GetLength(0) End Function Public Function bCopierFichier(ByVal sCheminSrc$, ByVal sCheminDest$, _ Optional ByVal bPromptErr As Boolean = True, _ Optional ByVal bVerifierDate As Boolean = False) As Boolean If bVerifierDate Then If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then Exit Function Dim dDateSrc As Date = IO.File.GetLastWriteTime(sCheminSrc) Dim lTailleSrc& = New IO.FileInfo(sCheminSrc).Length If bFichierExiste(sCheminDest) Then Dim dDateDest As Date = IO.File.GetLastWriteTime(sCheminDest) Dim lTailleDest& = New IO.FileInfo(sCheminDest).Length ' Si la date et la taille sont les mêmes, la copie est déjà faite ' (la vérification du hashcode serait plus sûr mais trop longue ' de toute façon : il serait alors plus rapide de tjrs recopier) If dDateSrc = dDateDest And lTailleSrc = lTailleDest Then _ bCopierFichier = True : Exit Function ' Sinon supprimer le fichier de destination If Not bSupprimerFichier(sCheminDest) Then Exit Function End If End If If Not bFichierExiste(sCheminSrc, bPromptErr) Then Exit Function 'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Exit Function 'End If Try IO.File.Copy(sCheminSrc, sCheminDest) bCopierFichier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bCopierFichier", _ "Impossible de copier le fichier source :" & vbLf & _ sCheminSrc & vbLf & "vers le fichier de destination :" & _ vbLf & sCheminDest, sCauseErrPoss) End Try End Function Public Function bSupprimerFichier(ByVal sCheminFichier$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then _ bSupprimerFichier = True : Exit Function If Not bFichierAccessible(sCheminFichier, _ bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then _ Exit Function ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) bSupprimerFichier = True Catch ex As Exception If bPromptErr Then _ MsgBox("Impossible de supprimer le fichier :" & vbLf & _ sCheminFichier & vbLf & _ sCauseErrPoss, MsgBoxStyle.Critical, sTitreMsg) End Try End Function Public Function bSupprimerFichiersFiltres(ByVal sCheminDossier$, ByVal sFiltre$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Supprimer tous les fichiers correspondants au filtre, par exemple : C:\ avec *.txt ' Si le dossier n'existe pas, on considère que c'est un succès If Not bDossierExiste(sCheminDossier) Then bSupprimerFichiersFiltres = True : Exit Function Dim asFichier$() = IO.Directory.GetFileSystemEntries(sCheminDossier, sFiltre) For Each sFichier As String In asFichier If Not bSupprimerFichier(sFichier, bPromptErr) Then Exit Function Next sFichier bSupprimerFichiersFiltres = True End Function Public Function bRenommerFichier(ByVal sSrc$, ByVal sDest$, _ Optional ByVal bConserverDest As Boolean = False) As Boolean ' Renommer ou déplacer un et un seul fichier If Not bFichierExiste(sSrc, bPrompt:=True) Then Exit Function If bConserverDest Then ' Cette option permet de conserver le fichier de destination s'il existe If bFichierExiste(sDest) Then ' Dans ce cas on supprime la source If Not bSupprimerFichier(sSrc) Then Exit Function bRenommerFichier = True Exit Function End If Else If Not bSupprimerFichier(sDest) Then Exit Function End If Try IO.File.Move(sSrc, sDest) bRenommerFichier = True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerFichier", _ "Impossible de renommer le fichier source :" & vbLf & _ sSrc & vbLf & "vers le fichier de destination :" & vbLf & sDest, _ sCauseErrPoss) End Try End Function Public Function bDeplacerFichiers2(ByVal sSrc$, ByVal sDest$) As Boolean ' Renommer ou déplacer une arborescence de fichiers ' Attention : cette fonction nécessite la suppression du dossier src ' voir aussi modUtilLT.bDeplacerFichiers et bDeplacerFichiers3 ' On pourrait faire plus rapide en déplacant les fichiers, mais tant pis ' Ex.: Déplacer C:\Tmp\*.txt -> C:\Tmp2\ ' Cette fonction est déjà dans : modUtilFichierLT.vb Dim bStatut As Boolean, sListeErr$ = "" If Not bCopierArbo(sSrc, sDest, bStatut, sListeErr) Then Exit Function Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc) If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Exit Function bDeplacerFichiers2 = True End Function Public Function bDeplacerFichiers3(ByVal sCheminSrc$, ByVal sFiltre$, ByVal sCheminDest$, _ Optional ByVal bConserverDest As Boolean = True, _ Optional ByVal sExtDest$ = "", Optional ByVal sPrefixe$ = "") As Boolean ' Déplacer tous les fichiers correspondants au filtre dans le répertoire de destination ' en vérifiant s'ils existent déjà : dans ce cas, conserver le fichier de destination ' (option par défaut pour conserver la date) If Not bVerifierCreerDossier(sCheminDest) Then Exit Function Dim bChExt As Boolean = False If sExtDest.Length > 0 Then bChExt = True Dim di As New IO.DirectoryInfo(sCheminSrc) Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = fi.GetLength(0) Dim i% For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileName(fi(i).Name) Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier ' Option possible : changer l'extension du fichier ' par exemple rename *.csv *.txt If bChExt Then sDest = sCheminDest & "\" & sPrefixe & _ IO.Path.GetFileNameWithoutExtension(sFichier) & sExtDest If Not bRenommerFichier(sSrc, sDest, bConserverDest) Then Exit Function Next i bDeplacerFichiers3 = True End Function ' 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) 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\ 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) 'reponse = MsgBox("Veuillez fermer le fichier :" & vbLf & _ ' sCheminFichier & vbLf & _ ' "(le fichier n'est pas accessible en écriture)" & sQuestion, _ ' msgbs, sTitreMsg) End If End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Sub ProposerOuvrirFichier(ByVal sCheminFichier$, _ Optional ByVal sInfo$ = "") If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub Dim lTailleFichier& = (New IO.FileInfo(sCheminFichier)).Length Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier) Dim sMsg$ = _ "Le fichier " & IO.Path.GetFileName(sCheminFichier) & _ " a été créé avec succès :" & vbLf & _ sCheminFichier If sInfo.Length > 0 Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub Public Sub OuvrirAppliAssociee(ByVal sCheminFichier$, _ Optional ByVal bMax As Boolean = False, _ Optional ByVal bVerifierFichier As Boolean = True) If bVerifierFichier Then ' Ne pas vérifier le fichier si c'est une URL à lancer If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub End If Dim p As New Process p.StartInfo = New ProcessStartInfo(sCheminFichier) If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Sub Public Function sFormaterTailleOctets$(ByVal lTailleOctets&, _ Optional ByVal bDetail As Boolean = False) ' Renvoyer une taille de fichier bien formatée dans une chaîne de caractère ' Sinon il existe aussi l'API StrFormatByteSizeA dans shlwapi.dll ' 1024 est la norme actuellement employée dans Windows, ' mais 1000 sera peut être un jour la norme ' http://fr.wikipedia.org/wiki/Octet Dim rNbKo! = CSng(Math.Round(lTailleOctets / 1024, 1)) Dim rNbMo! = CSng(Math.Round(lTailleOctets / (1024 * 1024), 1)) Dim rNbGo! = CSng(Math.Round(lTailleOctets / (1024 * 1024 * 1024), 1)) Dim sAffichage$ = "" If bDetail Then sAffichage = sFormaterNumerique(lTailleOctets) & " octets" If rNbKo >= 1 Then sAffichage &= " (" & sFormaterNumerique(rNbKo) & " Ko" If rNbMo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbMo) & " Mo" If rNbGo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbGo) & " Go" If rNbKo >= 1 Or rNbMo >= 1 Or rNbGo >= 1 Then sAffichage &= ")" Else If rNbGo >= 1 Then sAffichage = sFormaterNumerique(rNbGo, bSupprimerPt0:=False) & " Go" ElseIf rNbMo >= 1 Then sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0:=False) & " Mo" ElseIf rNbKo >= 1 Then sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0:=False) & " Ko" Else sAffichage = sFormaterNumerique(lTailleOctets, _ bSupprimerPt0:=True) & " octets" End If End If sFormaterTailleOctets = sAffichage End Function Public Function sFormaterNumerique$(ByVal rVal!, _ Optional ByVal bSupprimerPt0 As Boolean = True) ' Formater un numérique avec une précision d'une décimale ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 Dim nfi As Globalization.NumberFormatInfo = _ New Globalization.NumberFormatInfo ' Définition des spérateurs numériques nfi.NumberGroupSeparator = " " ' Séparateur des milliers, millions... nfi.NumberDecimalSeparator = "." ' Séparateur décimal ' 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) nfi.NumberGroupSizes = New Integer() {3, 3, 3} nfi.NumberDecimalDigits = 1 ' 1 décimale de précision If bSupprimerPt0 Then nfi.NumberDecimalDigits = 0 sFormaterNumerique = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 'If bSupprimerPt0 Then _ ' sFormaterNumerique = sFormaterNumerique.Replace(".0", "") End Function Public Function sFormaterNumerique2$(ByVal rVal!) ' Formater un numérique selon le format choisi dans le panneau de config. ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(ByRef sCheminDossier$) As Boolean ' Vérifier si le dossier existe, et le créer sinon Dim di As New IO.DirectoryInfo(sCheminDossier) If di.Exists Then bVerifierCreerDossier = True : Exit Function di.Create() di = New IO.DirectoryInfo(sCheminDossier) If di.Exists Then bVerifierCreerDossier = True : Exit Function MsgBox("Impossible de créer le dossier :" & vbCrLf & sCheminDossier, _ MsgBoxStyle.Critical, sTitreMsg) End Function Public Function bDossierExiste(ByVal sCheminDossier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un dossier correspondant au filtre sFiltre est trouvé 'Dim di As New IO.DirectoryInfo(sCheminDossier) 'bDossierExiste = di.Exists() bDossierExiste = IO.Directory.Exists(sCheminDossier) If Not bDossierExiste And bPrompt Then _ MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, _ MsgBoxStyle.Critical, sTitreMsg & " - Dossier introuvable") End Function Public Function bRenommerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bDeplacerDossier If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function If Not bSupprimerDossier(sCheminDossierDest, bPromptErr:=True) Then Exit Function Try IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) bRenommerDossier = True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerDossier", _ "Impossible de renommer le dossier source :" & vbLf & _ sCheminDossierSrc & vbLf & _ "vers le dossier de destination :" & vbLf & sCheminDossierDest, _ sCauseErrPossDossier) End Try End Function Public Function bDeplacerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$, _ Optional ByVal bPromptErr As Boolean = True) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bRenommerDossier ' Roir aussi My.Computer.MoveDirectory en DotNet2 If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function If Not bSupprimerDossier(sCheminDossierDest, bPromptErr) Then Exit Function Try 'Dim di As New IO.DirectoryInfo(sCheminDossierSrc) 'di.MoveTo(sCheminDossierDest) IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) bDeplacerDossier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bDeplacerDossier", _ "Impossible de déplacer le dossier source :" & vbLf & sCheminDossierSrc & vbLf & _ "vers le dossier de destination :" & vbLf & sCheminDossierDest, _ sCauseErrPossDossier) End Try End Function Public Function bSupprimerDossier(ByVal sCheminDossier$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier si le dossier existe If Not bDossierExiste(sCheminDossier) Then _ bSupprimerDossier = True : Exit Function Try IO.Directory.Delete(sCheminDossier, recursive:=True) ' Si l'explorateur est ouvert sur le dossier, il faut attendre qq sec. ' pour que le dossier soit bien détruit Dim i% = 0 While bDossierExiste(sCheminDossier) And i < 10 TraiterMsgSysteme_DoEvents() Threading.Thread.Sleep(1000) i += 1 End While If i = 10 Then If bPromptErr Then _ MsgBox("Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, MsgBoxStyle.Critical, sTitreMsg) Exit Function End If bSupprimerDossier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bSupprimerDossier", _ "Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, sCauseErrPossDossier) End Try End Function Public Function sDossierParent$(ByVal sCheminDossier$) ' Renvoyer le chemin du dossier parent ' Ex.: C:\Tmp\Tmp2 -> C:\Tmp ' (à renommer plutot en sCheminDossierParent ?) sDossierParent = IO.Path.GetDirectoryName(sCheminDossier) End Function Public Function sNomDossierFinal$(ByVal sCheminDossier$) ' Renvoyer le nom du dernier dossier à partir du chemin du dossier ' Exemples : ' C:\Tmp\Tmp\MonDossier -> MonDossier ' C:\MonDossier\ -> MonDossier ' (si on passe un fichier en argument, alors c'est le fichier qui est renvoyé) sNomDossierFinal = sCheminDossier sCheminDossier = sEnleverSlashFinal(sCheminDossier) Dim iPosDossier% = sCheminDossier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierFinal = sCheminDossier.Substring(iPosDossier + 1) End Function Public Function sExtraireChemin$(ByVal sCheminFichier$, _ Optional ByRef sNomFichier$ = "", Optional ByRef sExtension$ = "", _ Optional ByRef sNomFichierSansExt$ = "") ' Retourner le chemin du fichier passé en argument ' Non compris le caractère \ ' Retourner aussi le nom du fichier sans le chemin ainsi que son extension ' Exemple : ' C:\Tmp\MonFichier.txt -> C:\Tmp, MonFichier.txt, .txt, MonFichier sExtraireChemin = IO.Path.GetDirectoryName(sCheminFichier) sNomFichier = IO.Path.GetFileName(sCheminFichier) sNomFichierSansExt = IO.Path.GetFileNameWithoutExtension(sCheminFichier) sExtension = IO.Path.GetExtension(sCheminFichier) '(avec le point, ex.: .txt) End Function Public Function sNomDossierParent$(ByVal sCheminDossierOuFichier$, _ Optional ByVal sCheminReference$ = "") ' Renvoyer le nom du dernier dossier parent à partir du chemin du dossier ' et renvoyer aussi le fichier avec si on passe le chemin complet du fichier ' sauf si le dossier parent n'existe pas : chemin de référence ' Exemples avec un dossier : ' C:\Tmp\Tmp\MonDossier -> \Tmp\MonDossier ' C:\MonDossier -> \MonDossier ' Exemples avec un fichier : ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt sNomDossierParent = "" Dim iPosDossier% = sCheminDossierOuFichier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossier) ' Si c'est le chemin de référence, on le renvoit tel quel Dim sCheminDossierParent$ = IO.Path.GetDirectoryName(sCheminDossierOuFichier) If sCheminDossierParent = sEnleverSlashFinal(sCheminReference) Then Exit Function Dim iFin% = iPosDossier - 1 Dim iPosDossierParent% = sCheminDossierOuFichier.LastIndexOf("\", iFin) If iPosDossierParent < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossierParent) End Function Public Function sCheminRelatif$(ByVal sCheminFichier$, ByVal sCheminReference$) ' Renvoyer le chemin relatif au chemin de référence ' à partir du chemin complet du fichier ' Exemples avec C:\ pour le chemin de référence ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt ' Exemple avec C:\Tmp1 pour le chemin de référence ' C:\Tmp1\Tmp2\MonFichier.txt -> \Tmp2\MonFichier.txt sCheminReference = sEnleverSlashFinal(sCheminReference) sCheminRelatif = sCheminFichier.Substring(sCheminReference.Length) End Function Public Function sEnleverSlashFinal$(ByVal sChemin$) ' Enlever le slash final à la fin du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashFinal = "" : Exit Function If sChemin.EndsWith("\") Then sEnleverSlashFinal = sChemin.Substring(0, sChemin.Length - 1) Else sEnleverSlashFinal = sChemin End If End Function Public Function sEnleverSlashInitial$(ByVal sChemin$) ' Enlever le slash au début du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashInitial = "" : Exit Function If sChemin.StartsWith("\") Then sEnleverSlashInitial = sChemin.Substring(1) Else sEnleverSlashInitial = sChemin End If End Function Public Function bCopierArbo(ByVal sSrc$, ByVal sDest$, _ ByRef bStatut As Boolean, _ ByRef sListeErr$, Optional ByVal sListeErrExcep$ = "") As Boolean ' Copier une arborescence de fichiers ' bStatut : Succès ou Echec de la fonction récursive ' En cas d'échec, la liste des fichiers n'ayant pu être copiés est ' indiquée dans sListeErr (sListeErrExcep permet d'exclure des fichiers ' de ce rapport si on sait déjà qu'on ne pourra les copier) Dim Files$() If sDest.Chars(sDest.Length - 1) <> IO.Path.DirectorySeparatorChar Then _ sDest &= IO.Path.DirectorySeparatorChar Try If Not IO.Directory.Exists(sDest) Then IO.Directory.CreateDirectory(sDest) Catch ex As Exception AfficherMsgErreur2(ex, "bCopierArbo", _ "Impossible de créer le dossier :" & vbLf & _ sDest, sCauseErrPossDossier) Exit Function End Try Files = IO.Directory.GetFileSystemEntries(sSrc) Dim Element$ For Each Element In Files Dim sFichier$ = IO.Path.GetFileName(Element) If IO.Directory.Exists(Element) Then ' L'élement est un sous-dossier : le copier bCopierArbo(Element, sDest & sFichier, bStatut, sListeErr, sListeErrExcep) Else ' Sinon copier le fichier Try IO.File.Copy(Element, sDest & sFichier, True) Catch ex As Exception 'Dim sFichier$ = IO.Path.GetFileName(Element).ToLower If sListeErrExcep.IndexOf(" " & sFichier & " ") = -1 Then ' Noter le chemin du fichier imposs à copier ssi pas exception If sListeErr.Length < 200 Then If sListeErr = "" Then sListeErr = sDest & sFichier Else sListeErr &= vbLf & sDest & sFichier End If ElseIf Right$(sListeErr, 3) <> "..." Then sListeErr &= vbLf & "..." End If bStatut = False ' Il y a des erreurs particulières End If End Try End If Next bCopierArbo = bStatut End Function Public Function sLecteurDossier$(ByVal sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" ' Le code page 1252 correspond à FileOpen de VB .NET, l'équivalent en VB6 de ' Open sCheminFichier For Input As #1 ' Mettre & pour Long en DotNet1 et % pour Integer en DotNet2 Public Const iCodePageWindowsLatin1252% = 1252 ' windows-1252 = msoEncodingWestern Public Function sLireFichier$(ByVal sCheminFichier$) ' Lire et renvoyer le contenu d'un fichier sLireFichier = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim fs As IO.FileStream = Nothing Dim sr As IO.StreamReader = Nothing Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Try fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv sr = New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbContenu.Append(vbCrLf) bDebut = True sbContenu.Append(sLigne) Loop While True Catch Ex As Exception AfficherMsgErreur2(Ex, "sLireFichier") Exit Function Finally If Not (sr Is Nothing) Then sr.Close() If Not (fs Is Nothing) Then fs.Close() End Try sLireFichier = sbContenu.ToString End Function Public Function sbLireFichier(ByVal sCheminFichier$) As StringBuilder ' Lire et renvoyer le contenu d'un fichier sbLireFichier = New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim fs As IO.FileStream = Nothing Dim sr As IO.StreamReader = Nothing Dim bDebut As Boolean = False Try fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv sr = New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbLireFichier.Append(vbCrLf) bDebut = True sbLireFichier.Append(sLigne) Loop While True Catch Ex As Exception AfficherMsgErreur2(Ex, "sbLireFichier") Exit Function Finally If Not (sr Is Nothing) Then sr.Close() If Not (fs Is Nothing) Then fs.Close() End Try End Function Public Function bEcrireFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder) As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Exit Function End If Dim sw As IO.StreamWriter = Nothing Try sw = New IO.StreamWriter(sCheminFichier, append:=False, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) sw.Close() bEcrireFichier = True Catch Ex As Exception AfficherMsgErreur2(Ex, "bEcrireFichier", _ "Impossible d'écrire les données dans le fichier :" & _ vbCrLf & sCheminFichier) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bEcrireFichier(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal bEncodageDefaut As Boolean = False, _ Optional ByVal bEncodageISO_8859_1 As Boolean = False) As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Exit Function End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø sw = New IO.StreamWriter(sCheminFichier, append:=False) ElseIf bEncodageISO_8859_1 Then sw = New IO.StreamWriter(sCheminFichier, append:=False, _ Encoding:=Encoding.GetEncoding("ISO-8859-1")) Else ' Encodage par défaut de VB6 et de Windows en français sw = New IO.StreamWriter(sCheminFichier, append:=False, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) End If sw.Write(sContenu) sw.Close() bEcrireFichier = True Catch Ex As Exception AfficherMsgErreur2(Ex, "bEcrireFichier", _ "Impossible d'écrire les données dans le fichier :" & _ vbCrLf & sCheminFichier) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, ByVal sContenu$) As Boolean Dim sw As IO.StreamWriter = Nothing Try sw = New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sContenu) sw.Close() bAjouterFichier = True Catch Ex As Exception AfficherMsgErreur2(Ex, "bAjouterFichier", _ "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder) As Boolean Dim sw As IO.StreamWriter = Nothing Try sw = New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) sw.Close() bAjouterFichier = True Catch Ex As Exception AfficherMsgErreur2(Ex, "bAjouterFichier", _ "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bReencoder(ByVal sCheminFichier$) As Boolean ' Réencoder un fichier avec les sauts de ligne Unix (vbLf) en fichier Windows (vbCrLf) If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim sb As StringBuilder = sbLireFichier(sCheminFichier) If sb.Length = 0 Then Exit Function bReencoder = bEcrireFichier(sCheminFichier, sb.Append(vbCrLf)) End Function #End Region #Region "Divers" 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 Function sConvNomDos$(ByVal sChaine$, _ Optional ByVal bLimit8Car As Boolean = False, _ Optional ByVal bConserverSignePlus As Boolean = False) ' Remplacer les caractères interdits pour les noms de fichiers DOS ' et retourner un nom de fichier 8.3 correcte si demandé Dim iSel%, sBuffer$, sCar$, iCode%, sCarConv2$, sCarDest$ Dim bOk As Boolean, bMaj As Boolean sBuffer = Trim$(sChaine) If bLimit8Car Then sBuffer = Left$(sBuffer, 8) Const sCarConv$ = " .«»/[]:;|=,*-" ' Caractères à convertir en souligné sCarConv2 = sCarConv If Not bConserverSignePlus Then sCarConv2 &= "+" For iSel = 1 To Len(sBuffer) sCar = Mid$(sBuffer, iSel, 1) iCode = Asc(sCar) bMaj = False If iCode >= 65 And iCode <= 90 Then bMaj = True If iCode >= 192 And iCode <= 221 Then bMaj = True If InStr(sCarConv2, sCar) > 0 Then _ Mid$(sBuffer, iSel, 1) = "_" : GoTo Suite If InStr("èéêë", sCar) > 0 Then If bMaj Then sCarDest = "E" Else sCarDest = "e" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("àáâä", sCar) > 0 Then If bMaj Then sCarDest = "A" Else sCarDest = "a" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ìíîï", sCar) > 0 Then If bMaj Then sCarDest = "I" Else sCarDest = "i" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ùúûü", sCar) > 0 Then If bMaj Then sCarDest = "U" Else sCarDest = "u" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If bConserverSignePlus And iCode = 43 Then GoTo Suite 'de 65 à 90 maj 'de 97 à 122 min 'de 48 à 57 Chiff bOk = False If (iCode >= 65 And iCode <= 90) Then bOk = True If (iCode >= 97 And iCode <= 122) Then bOk = True If (iCode >= 48 And iCode <= 57) Then bOk = True If Not bOk Then Mid$(sBuffer, iSel, 1) = "_" Suite: Next iSel sConvNomDos = sBuffer End Function #End Region End Module modUtilitaire.vb ' Fichier modUtilitaire.vb ' ------------------------ Module Utilitaire #Region "Convertions" Public Function lDecalage&(ByVal lVal&, ByVal iDec%, _ Optional ByVal lMasqueApres& = 0, Optional ByVal lMasqueAvant& = 0) ' Décalage à droite de la valeur iVal, et masque le cas échéant ' iDecalage = (iVal >> iDec) & iMasque ' n = (Head.count >> 8) & 0xff; Dim lValDec& = lVal If lMasqueAvant > 0 Then lValDec = (lVal And lMasqueAvant) Dim i% For i = 1 To iDec lValDec \= 2 Next i lDecalage = lValDec 'lDecalage = (lValDec Mod lMasque) If lMasqueApres > 0 Then lDecalage = (lValDec And lMasqueApres) End Function Public Function iConvUInt%(ByVal uiVal As UInteger, ByRef bErr As Boolean, _ Optional ByVal iValDef% = 0) If uiVal > Integer.MaxValue Then bErr = True iConvUInt = iValDef Exit Function End If iConvUInt = CInt(uiVal) End Function Public Function iConvHexa%(ByVal sCodeHexa$) ' Convertir une chaine hexadécimale en integer iConvHexa = Int32.Parse(sCodeHexa, Globalization.NumberStyles.HexNumber) 'Dim i% = Convert.ToInt32("FF", 16) ' Base 16 = Hexa 'Dim i% = CInt("&HFF") ' 255 = 0xFF ' &H : Hexa 'Dim i% = Int32.Parse("FF", Globalization.NumberStyles.HexNumber) ' Coder directement un hexa dans un code source DotNet 'Dim i% = &HFF 'Debug.WriteLine(i) End Function Public Function rConvStrEnReel!(ByVal sVal$, Optional ByVal rDef! = 0.0!) ' Convertir à coup sûr une valeur dans un string en réel If sVal.Length = 0 Then rConvStrEnReel = rDef : Exit Function ' D'abord changer la , en . le cas échéant Dim sValPtDecimal$ = Replace(sVal, ",", ".") Dim sSepDecimal$ = _ Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator() If sSepDecimal <> "." And sSepDecimal <> "," And sSepDecimal.Length > 0 Then ' Quelque soit le séparateur décimal, le convertir en . sValPtDecimal = Replace(sVal, sSepDecimal, ".") End If ' Note : Val utilise toujours le . quelque soit le séparateur décimal en vigueur Try rConvStrEnReel = CSng(Val(sValPtDecimal)) Catch rConvStrEnReel = rDef End Try End Function Public Function sValeurPtDecimal$(ByVal sVal$) sValeurPtDecimal = sVal If sVal.Length = 0 Then Exit Function sValeurPtDecimal = Replace(sValeurPtDecimal, ",", ".") Dim sSepDecimal$ = Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator() If sSepDecimal.Length = 0 Then Exit Function If sSepDecimal <> "." And sSepDecimal <> "," Then ' Quelque soit le séparateur décimal, le convertir en . sValeurPtDecimal = Replace(sValeurPtDecimal, sSepDecimal, ".") End If End Function Public Function sValeurPtDecimal$(ByVal rVal!) sValeurPtDecimal = CStr(rVal) sValeurPtDecimal = Replace(sValeurPtDecimal, ",", ".") Dim sSepDecimal$ = Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator() If sSepDecimal.Length = 0 Then Exit Function If sSepDecimal <> "." And sSepDecimal <> "," Then ' Quelque soit le séparateur décimal, le convertir en . sValeurPtDecimal = Replace(sValeurPtDecimal, sSepDecimal, ".") End If End Function Public Function iConv%(ByVal sVal$, Optional ByVal iValDef% = 0) If String.IsNullOrEmpty(sVal) Then iConv = iValDef : Exit Function Try iConv = CInt(sVal) Catch iConv = iValDef End Try End Function Public Function rConv!(ByVal sVal$, Optional ByVal rValDef! = 0) If String.IsNullOrEmpty(sVal) Then rConv = rValDef : Exit Function Try rConv = CSng(sVal) Catch rConv = rValDef End Try End Function Public Function dVerifierDate(ByVal sDate$) As Date If String.IsNullOrEmpty(sDate) Then dVerifierDate = Today : Exit Function Try dVerifierDate = CDate(sDate) Catch dVerifierDate = Today End Try End Function #End Region #Region "Divers" 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 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 Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub #End Region End Module modUtilReg.vb ' Fichier modUtilReg.vb : Module de gestion de la base de registre ' --------------------- Imports Microsoft.Win32 Module modUtilReg 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 rkCRSousCle As RegistryKey = _ Registry.ClassesRoot.CreateSubKey(sTypeFichier) If sDescriptionTypeFichier.Length > 0 Then rkCRSousCle.SetValue("", sDescriptionTypeFichier) End If End Using ' rkCRSousCle.Close() est automatiquement appelé 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 rkCRSousCle As RegistryKey = _ Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd) rkCRSousCle.SetValue("", sDescriptionCmd) End Using Dim sCleCmd$ = sTypeFichier & "\shell\" & sCmd & "\command" Using rkCRSousCle 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 & """" rkCRSousCle.SetValue("", sCheminExe & " " & sCmdDef) End Using 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é 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 If IsNothing(rkLMCle) Then Exit Function Using rkLMSousCle As RegistryKey = rkLMCle.OpenSubKey(sCle, writable:=bEcriture) Dim oVal As Object = rkLMSousCle.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 sValSousCle = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle) Then Exit Function If bEcriture Then oVal = CInt(sNouvValSousCle) rkLMSousCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord) End If End Using ' rkLMSousCle.Close() est automatiquement appelé 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é CurrentUser existe dans la base de registre sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser If IsNothing(rkCUCle) Then Exit Function Using rkCUSousCle As RegistryKey = rkCUCle.OpenSubKey(sCle) Dim oVal As Object = rkCUSousCle.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 sValSousCle = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle) Then Exit Function End Using ' rkCUSousCle.Close() est automatiquement appelé 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 ' http://msdn2.microsoft.com/en-us/library/aa302340.aspx#win32map_registryfunctions 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