XL2Csv v1.0.8.*
Table des procédures 1 - AssemblyInfo.vb 2 - modDepart.vb 2.1 - Public Sub Depart 2.2 - Public Sub Main 3 - frmXL2Csv.vb 3.1 - Private Function bConvertirXLODBC 3.2 - Private Function sNomTableExcel$ 3.3 - Private Sub AfficherMessage 3.4 - Private Sub AfficherMessageEv 3.5 - Private Sub AjouterEnteteTable 3.6 - Private Sub cmdAjouterMenuCtx_Click 3.7 - Private Sub cmdAnnuler_Click 3.8 - Private Sub cmdConv_Click 3.9 - Private Sub cmdEnleverMenuCtx_Click 3.10 - Private Sub frmXL2Csv_Shown 3.11 - Private Sub m_oODBC_EvAfficherMessage 3.12 - Private Sub VerifierMenuCtx 4 - clsAfficherMsg.vb 4.1 - Public Delegate Sub GestEvAfficherAvancement 4.2 - Public Delegate Sub GestEvAfficherFEC 4.3 - Public Delegate Sub GestEvAfficherMessage 4.4 - Public Delegate Sub GestEvSablier 4.5 - Public Delegate Sub GestEvTick 4.6 - Public ReadOnly Property bDesactiver 4.7 - Public ReadOnly Property iNumFichierEnCours% 4.8 - Public ReadOnly Property lAvancement 4.9 - Public ReadOnly Property sMessage$ 4.10 - Public ReadOnly Property sMessage$ 4.11 - Public Sub AfficherAvancement 4.12 - Public Sub AfficherFichierEnCours 4.13 - Public Sub AfficherMsg 4.14 - Public Sub New 4.15 - Public Sub New 4.16 - Public Sub New 4.17 - Public Sub New 4.18 - Public Sub New 4.19 - Public Sub New 4.20 - Public Sub New 4.21 - Public Sub New 4.22 - Public Sub Sablier 4.23 - Public Sub Tick 5 - clsHebOffice.vb 5.1 - Public Function bMonInstanceOuverte 5.2 - Public Function bOuvert 5.3 - Public Overloads Shared Function bOuvert 5.4 - Public Overloads Shared Function bOuvert 5.5 - Public Shared Function bOuvert 5.6 - Public Shared Sub LibererObjetCom 5.7 - Public Shared Sub LibererObjetCom 5.8 - Public Sub Fermer 5.9 - Public Sub New 5.10 - Public Sub New 5.11 - Public Sub New 5.12 - Public Sub New 5.13 - Public Sub Quitter 5.14 - Public Sub Quitter 6 - clsODBC.vb 6.1 - Private Function bCheminFichierProbable 6.2 - Private Function bCreerFichierDsnODBC 6.3 - Private Function bCreerFichiersDsnEtSQLODBCDefaut 6.4 - Private Sub AfficherErreursADO 6.5 - Private Sub AfficherMessage 6.6 - Private Sub AjouterEntete 6.7 - Private Sub AjouterTemps 6.8 - Private Sub TraiterValChamp 6.9 - Public Function bExplorerSourceODBC 6.10 - Public Function bLireSourceODBC 6.11 - Public Function bLireSQL 6.12 - Public Function bVerifierCheminODBC 6.13 - Public Function sLireNomPiloteODBC$ 6.14 - Public ReadOnly Property bAnnuler 6.15 - Public Shared Sub VerifierConfigODBCExcel 6.16 - Public Sub Annuler 6.17 - Public Sub LibererRessources 6.18 - Public Sub New 6.19 - Public Sub ViderContenuResultat 7 - modExcel.vb 7.1 - <System.Diagnostics.DebuggerStepThrough()> Function bFeuilleExiste 7.2 - Public Function bConvertirXLAutomation 7.3 - Public Function bLireCellulesXLAutomation 7.4 - Public Function bLireCellulesXLCouleurs 7.5 - Public Function iColFinPlage% 7.6 - Public Function iColPlage% 7.7 - Public Function iLigneFinPlage% 7.8 - Public Function iLignePlage% 7.9 - Public Function sConvNumEnLettres$ 8 - modExcelRapide.vb 8.1 - Public Function bConvertirXL2Txt 8.2 - Public Function bConvertirXLRapide 9 - modUtil.vb 9.1 - Public Function bFichierAccessibleMultiTest 9.2 - Public Function iConv% 9.3 - Public Function sValeurPtDecimal$ 9.4 - Public Sub AfficherMsgErreur2 9.5 - Public Sub Attendre 9.6 - Public Sub CopierPressePapier 9.7 - Public Sub LibererRessourceDotNet 9.8 - Public Sub Sablier 9.9 - Public Sub TraiterMsgSysteme_DoEvents 10 - modUtilExcel.vb 10.1 - Public Function sFormaterNumeriqueDble$ 10.2 - Public Function sFormaterNumeriqueDec$ 11 - modUtilExcelRapide.vb 11.1 - <System.Diagnostics.DebuggerStepThrough()> Private Function dLireDate 11.2 - '<System.Diagnostics.DebuggerStepThrough()> Private Function sLireDate$ 11.3 - Private Function sLireVal$ 11.4 - Public Function bLireCellulesXLRapide 11.5 - Public Function sLireValCelluleExcelLibrary$ 11.6 - worksheet0 = m_workbook.Worksheets.Find(Function(wsheet 12 - modUtilFichier.vb 12.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible 12.2 - Public Function asArgLigneCmd 12.3 - Public Function asLireFichier 12.4 - Public Function bAjouterFichier 12.5 - Public Function bAjouterFichier 12.6 - Public Function bChoisirFichier 12.7 - Public Function bCopierArbo 12.8 - Public Function bCopierFichier 12.9 - Public Function bDeplacerDossier 12.10 - Public Function bDeplacerFichiers2 12.11 - Public Function bDeplacerFichiers3 12.12 - Public Function bDossierExiste 12.13 - Public Function bEcrireFichier 12.14 - Public Function bEcrireFichier 12.15 - Public Function bFichierExiste 12.16 - Public Function bFichierExisteFiltre 12.17 - Public Function bFichierExisteFiltre2 12.18 - Public Function bReencoder 12.19 - Public Function bRenommerDossier 12.20 - Public Function bRenommerFichier 12.21 - Public Function bSupprimerDossier 12.22 - Public Function bSupprimerFichier 12.23 - Public Function bSupprimerFichiersFiltres 12.24 - Public Function bVerifierCreerDossier 12.25 - Public Function iNbFichiersFiltres% 12.26 - Public Function sbLireFichier 12.27 - Public Function sCheminRelatif$ 12.28 - Public Function sConvNomDos$ 12.29 - Public Function sDossierParent$ 12.30 - Public Function sEnleverSlashFinal$ 12.31 - Public Function sEnleverSlashInitial$ 12.32 - Public Function sExtraireChemin$ 12.33 - Public Function sFormaterNumerique$ 12.34 - Public Function sFormaterNumerique2$ 12.35 - Public Function sFormaterTailleOctets$ 12.36 - Public Function sLecteurDossier$ 12.37 - Public Function sLireFichier$ 12.38 - Public Function sNomDossierFinal$ 12.39 - Public Function sNomDossierParent$ 12.40 - Public Sub OuvrirAppliAssociee 12.41 - Public Sub ProposerOuvrirFichier 13 - modUtilLT.vb 13.1 - Public Sub LibererObjetCom 14 - modUtilReg.vb 14.1 - Public Function asListeSousClesCU 14.2 - Public Function bAjouterMenuContextuel 14.3 - Public Function bAjouterTypeFichier 14.4 - Public Function bCleRegistreCRExiste 14.5 - Public Function bCleRegistreCRExiste 14.6 - Public Function bCleRegistreCUExiste 14.7 - Public Function bCleRegistreLMExiste AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("XL2Csv")> <Assembly: AssemblyDescription( _ "XL2Csv : Convertir un fichier Excel en fichiers Csv")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("XL2Csv")> <Assembly: AssemblyCopyright("Copyright © 2012 ORS Production")> <Assembly: AssemblyTrademark("XL2Csv")> '<Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("1.0.8.*")> modDepart.vb ' Fichier modDepart.vb ' -------------------- ' XL2Csv : Convertir un fichier Excel en fichiers Csv ' Documentation : XL2Csv.html ' http://patrice.dargenton.free.fr/CodesSources/XL2Csv.html ' http://patrice.dargenton.free.fr/CodesSources/XL2Csv.vbproj.html ' http://www.vbfrance.com/code.aspx?ID=44827 ' Par Patrice Dargenton : patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' Version 1.08 du 07/01/2012 TypeGuessRow : au moment d'ajouter les menus ctx (pour W64) ' Version 1.07 du 03/12/2011 PlatformTarget : AnyCPU -> x86 pour ODBC 64 bits ' Version 1.06 du 01/11/2011 ExcelLibrary mis à jour ' Version 1.05 du 16/04/2011 ExcelLibrary mis à jour ' Version 1.04 du 19/09/2010 ' Version 1.03 du 21/02/2009 ' Version 1.02 du 15/12/2007 ' Version 1.01 du 25/11/2007 ' 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 ' 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 ' ... ' ------------------------------------ Module modDepart Public sNomAppli$ = My.Application.Info.Title Public sTitreMsg$ = sNomAppli 'Public Const sTitreMsg$ = "XL2Csv" Public Const sTitreMsgDescription$ = " : Convertir un fichier Excel en fichiers Csv" Private Const sDateVersionXL2Csv$ = "07/01/2012" '1.07"03/12/2011" '1.06:"01/11/2011" '1.05:"16/04/2011" '1.04:"19/09/2010" Public Const sDateVersionAppli$ = sDateVersionXL2Csv 'Public Const sMsgOperationTerminee$ = "Opération terminée." #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 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 Levé (Thrown) dans le menu Déboguer:Exceptions... 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, ' sinon utiliser l'attribut de fonction <System.Diagnostics.DebuggerStepThrough()> ' Avec l'ancienne technique On Error Goto X, on pouvait désactiver la gestion ' d'erreur avec une simple constante, mais on ne pouvait pas imbriquer plusieurs ' gestions d'erreur dans une même fonction 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, "Depart " & sTitreMsg) End Try End Sub Public Sub Depart() ' On peut démarrer l'application sur la feuille, ou bien sur la procédure ' Main() si on veut pouvoir détecter l'absence de la dll sans plantage ' Extraire les options passées en argument de la ligne de commande ' Cette fct ne marche pas avec des chemins contenant des espaces, même entre guillemets 'Dim asArgs$() = Environment.GetCommandLineArgs() Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command Dim sCheminFichier$ = "" Dim iTypeConv As frmXL2Csv.TypeConv = frmXL2Csv.TypeConv.XL2Csv Dim bSyntaxeOk As Boolean = False Dim iNbArguments% = 0 If sArg0 <> "" Then Dim asArgs$() = asArgLigneCmd(sArg0) iNbArguments = UBound(asArgs) + 1 'If iNbArguments <= 2 Then bSyntaxeOk = True If iNbArguments = 1 Or iNbArguments = 2 Then bSyntaxeOk = True If Not bSyntaxeOk Then GoTo Suite If iNbArguments = 1 Then sCheminFichier = asArgs(0) If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then _ bSyntaxeOk = False GoTo Suite End If Dim sCmd$ = asArgs(1) If sCmd = frmXL2Csv.sXL2Csv Then iTypeConv = frmXL2Csv.TypeConv.XL2Csv ElseIf sCmd = frmXL2Csv.sXL2CsvAutomation Then iTypeConv = frmXL2Csv.TypeConv.XL2CsvAutomation ElseIf sCmd = frmXL2Csv.sXL2CsvODBC Then iTypeConv = frmXL2Csv.TypeConv.XL2CsvODBC ElseIf sCmd = frmXL2Csv.sXL2Txt Then iTypeConv = frmXL2Csv.TypeConv.XL2Txt ElseIf sCmd = frmXL2Csv.sXL2CsvGroup Then iTypeConv = frmXL2Csv.TypeConv.XL2CsvGroup Else MsgBox("Commande non reconnue : " & sCmd, _ MsgBoxStyle.Information, sTitreMsg & sTitreMsgDescription) bSyntaxeOk = False End If sCheminFichier = asArgs(0) If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then _ bSyntaxeOk = False End If Suite: If Not bSyntaxeOk Then MsgBox( _ "Syntaxe : Chemin du fichier Excel à convertir" & vbCrLf & _ "en autant de fichiers Csv qu'il y a de feuille Excel" & vbCrLf & _ "Options possibles :" & vbCrLf & _ "XL2Txt : pour convertir en un seul fichier Texte" & vbCrLf & _ "XL2CsvGroup : pour convertir en un seul fichier Csv fusionné" & vbCrLf & _ "XL2CsvODBC : comme XL2Csv mais via ODBC : colonnes homogènes" & vbCrLf & _ "XL2CsvAutomation : comme XL2Csv mais via Automation Excel" & vbCrLf & _ "Exemples : " & vbCrLf & _ "XL2Csv.exe C:\Tmp\MonFichierExcel" & vbCrLf & _ "XL2Csv.exe C:\Tmp\MonFichierExcel XL2CsvODBC" & vbCrLf & _ "XL2Csv.exe C:\Tmp\MonFichierExcel XL2CsvAutomation" & vbCrLf & _ "XL2Csv.exe C:\Tmp\MonFichierExcel XL2Txt" & vbCrLf & _ "XL2Csv.exe C:\Tmp\MonFichierExcel XL2CsvGroup" & vbCrLf & _ "Sinon ajouter les menus contextuels via le menu dédié" & vbCrLf & _ "(utilisation des menus contextuels avec le bouton droit" & vbCrLf & _ " de la souris dans l'explorateur de fichier)", _ MsgBoxStyle.Information, sTitreMsg & sTitreMsgDescription) If iNbArguments > 0 Then Exit Sub End If ' Cette dll ne figure pas dans le Framework .NET, elle se trouve ici : ' C:\Program Files\Microsoft.NET\Primary Interop Assemblies\adodb.dll ' Il faut donc installer les PIA, ou sinon, il suffit de copier la dll ' dans le répertoire de l'application If iTypeConv = frmXL2Csv.TypeConv.XL2CsvGroup Then If Not bFichierExiste(Application.StartupPath & "\ADODB.dll", _ bPrompt:=True) Then Exit Sub End If If iTypeConv = frmXL2Csv.TypeConv.XL2Csv Or _ iTypeConv = frmXL2Csv.TypeConv.XL2Txt Then If Not bFichierExiste(Application.StartupPath & "\ExcelLibrary.dll", _ bPrompt:=True) Then Exit Sub End If Dim oFrm As New frmXL2Csv oFrm.m_sCheminFichierXL = sCheminFichier oFrm.m_iTypeConv = iTypeConv Application.Run(oFrm) End Sub End Module frmXL2Csv.vb ' Fichier frmXL2Csv.vb : Convertir un fichier Excel en fichiers Csv ' -------------------- Imports System.Text ' Pour StringBuilder Public Class frmXL2Csv #Region "Configuration" ' Mettre False pour éviter de remplacer les , par des . pour les nombres réels ' (cela permet de réouvrir correctement les fichiers csv sous Excel avec la ,) Private Const bRemplacerSepDec As Boolean = True ' Appliquer un TrimEnd = RTrim (enlever les éventuels espaces à la fin des champs textes) Private Const bEnleverEspacesFin As Boolean = True ' Remplacer les booléens vrai et faux par 1 et vide, respectivement Private Const bRemplacerVraiFaux As Boolean = True Private Const sValFaux$ = "" Private Const sValVrai$ = "1" #End Region #Region "Interface" Public m_sCheminFichierXL$ = "" Public m_iTypeConv As TypeConv #End Region #Region "Déclarations" Public Enum TypeConv XL2Txt XL2CsvGroup ' Toujours via ODBC XL2Csv ' Méthode rapide via ExcelLibrary (et non plus via ODBC) ' Ancienne méthode via ODBC ' (pour classeur Excel correctement formaté : colonnes homogènes) XL2CsvODBC XL2CsvAutomation ' Méthode via Automation VBA Excel (lent car via Excel) End Enum ' Types de conversion Public Const sXL2Txt$ = "XL2Txt" ' Un seul fichier texte Public Const sXL2CsvGroup$ = "XL2CsvGroup" ' Un seul fichier csv groupé : fusion csv ' Option par défaut Public Const sXL2Csv$ = "XL2Csv" ' Autant de fichiers csv que de feuilles Excel Public Const sXL2CsvAutomation$ = "XL2CsvAutomation" ' XL2Csv via automation Excel Public Const sXL2CsvODBC$ = "XL2CsvODBC" ' XL2Csv via ODBC Private WithEvents m_oODBC As New clsODBC Private WithEvents m_msgDelegue As clsMsgDelegue = New clsMsgDelegue ' Menus contextuels Private Const sMenuCtx_TypeFichierExcel$ = "Excel.Sheet.8" Private Const sMenuCtx_CleCmdConvertirEnCsv$ = "ConvertirEnCsv" Private Const sMenuCtx_CleCmdConvertirEnCsvDescription$ = "Convertir en fichiers Csv" Private Const sMenuCtx_CleCmdConvertirEn1Csv$ = "ConvertirEn1Csv" ' XL2CsvGroup Private Const sMenuCtx_CleCmdConvertirEn1CsvDescription$ = "Convertir en fichier Csv fusionné" Private Const sMenuCtx_CleCmdConvertirEnTxt$ = "ConvertirEnTxt" Private Const sMenuCtx_CleCmdConvertirEnTxtDescription$ = "Convertir en fichier Texte" Private Const sMenuCtx_CleCmdConvertirEnCsvAutomation$ = "ConvertirEnCsvAutomation" Private Const sMenuCtx_CleCmdConvertirEnCsvAutomationDescription$ = _ "Convertir en fichiers Csv (automation)" Private Const sMenuCtx_CleCmdConvertirEnCsvODBC$ = "ConvertirEnCsvODBC" Private Const sMenuCtx_CleCmdConvertirEnCsvODBCDescription$ = _ "Convertir en fichiers Csv (ODBC)" #End Region #Region "Initialisations" 'Private Sub frmXL2Csv_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load 'End Sub Private Sub frmXL2Csv_Shown(ByVal sender As Object, ByVal e As EventArgs) _ Handles Me.Shown Dim sVersionAppli$ = My.Application.Info.Version.Major & _ "." & My.Application.Info.Version.Minor & _ My.Application.Info.Version.Build Dim sVersion$ = " - V" & sVersionAppli & " (" & sDateVersionAppli & ")" Dim sDebug$ = " - Debug" Dim sTxt$ = Me.Text & sVersion If bDebug Then sTxt &= sDebug Me.Text = sTxt VerifierMenuCtx() If Me.m_iTypeConv = TypeConv.XL2CsvODBC Or _ Me.m_iTypeConv = TypeConv.XL2CsvGroup Then clsODBC.VerifierConfigODBCExcel() End If Dim bModeConfig As Boolean = False If Me.m_sCheminFichierXL.Length = 0 Then bModeConfig = True Else If Not bFichierExiste(Me.m_sCheminFichierXL, _ bPrompt:=True) Then bModeConfig = True End If If bModeConfig Then Me.cmdAjouterMenuCtx.Visible = True Me.cmdEnleverMenuCtx.Visible = True Me.chkXL2Csv.Visible = True Me.chkFusionCsv.Visible = True Me.chkODBC.Visible = True Me.chkTexte.Visible = True Me.chkAutomation.Visible = True Const sCmd$ = "Ajouter/Retirer le menu contextuel " Me.ToolTip1.SetToolTip(Me.chkXL2Csv, _ sCmd & "XL2Csv : Convertir un fichier Excel en fichiers Csv") Me.ToolTip1.SetToolTip(Me.chkFusionCsv, _ sCmd & "XL2CsvGroup : Convertir un fichier Excel en fichier Csv via ODBC") Me.ToolTip1.SetToolTip(Me.chkAutomation, _ sCmd & "XL2CsvAutomation : Convertir un fichier Excel en fichiers Csv via Automation Excel") Me.ToolTip1.SetToolTip(Me.chkODBC, _ sCmd & "XL2CsvODBC : Convertir un fichier Excel en fichiers Csv via ODBC") Me.ToolTip1.SetToolTip(Me.chkTexte, _ sCmd & "XL2Txt : Convertir un fichier Excel en fichier Texte") Me.cmdConv.Visible = False Me.cmdAnnuler.Visible = False Exit Sub End If Select Case Me.m_iTypeConv Case TypeConv.XL2CsvGroup : Me.Text = _ "XL2CsvGroup" & sVersion & " : Convertir un fichier Excel en fichier Csv" Case TypeConv.XL2Csv : Me.Text = _ "XL2Csv" & sVersion & " : Convertir un fichier Excel en fichiers Csv" Case TypeConv.XL2CsvAutomation : Me.Text = _ "XL2Csv" & sVersion & " : Convertir un fichier Excel en fichiers Csv via automation Excel" Case TypeConv.XL2CsvODBC : Me.Text = _ "XL2Csv" & sVersion & " : Convertir un fichier Excel en fichiers Csv via ODBC" Case TypeConv.XL2Txt : Me.Text = _ "XL2Txt" & sVersion & " : Convertir un fichier Excel en fichier Texte" End Select If bDebug Then Me.Text &= sDebug Me.cmdAjouterMenuCtx.Visible = False Me.cmdEnleverMenuCtx.Visible = False Me.cmdConv.Visible = True Me.cmdAnnuler.Visible = True Me.cmdAnnuler.Enabled = True Me.cmdConv.Enabled = False Dim bOk As Boolean '= bConvertirXL(bAuto:=True) If Me.m_iTypeConv = TypeConv.XL2Csv Then bOk = bConvertirXLRapide(Me.m_sCheminFichierXL, Me.m_msgDelegue) 'Const sListeCellules$ = "Feuil1!A1;Feuil1!B2;Feuil2!C3;Feuil2!C1" 'Const sListeCellules$ = "Feuil1!D19" 'Const sListeCellules$ = "Feuil1!A1" 'Dim aoValeurs() As Object = Nothing 'bOk = bLireCellulesXLRapide(Me.m_sCheminFichierXL, sListeCellules, aoValeurs, Me.m_msgDelegue) 'Debug.WriteLine(aoValeurs(0).ToString) 'Debug.WriteLine(aoValeurs(0).ToString & ", " & aoValeurs(1).ToString & ", " & _ ' aoValeurs(2).ToString & ", " & aoValeurs(3).ToString) ElseIf Me.m_iTypeConv = TypeConv.XL2CsvAutomation Then bOk = bConvertirXLAutomation(Me.m_sCheminFichierXL, Me.m_msgDelegue) 'Const sListeCellules$ = "Feuil1!A1;Feuil1!B2;Feuil2!C3;Feuil2!C1" 'Const sListeCellules$ = "Feuil1!D19" 'Const sListeCellules$ = "Feuil1!A1" 'Dim aoValeurs() As Object = Nothing 'bOk = bLireCellulesXLAutomation(Me.m_sCheminFichierXL, sListeCellules, aoValeurs, Me.m_msgDelegue) 'Debug.WriteLine(aoValeurs(0).ToString) 'Debug.WriteLine(aoValeurs(0).ToString & ", " & aoValeurs(1).ToString & ", " & _ ' aoValeurs(2).ToString & ", " & aoValeurs(3).ToString) ElseIf Me.m_iTypeConv = TypeConv.XL2Txt Then bOk = bConvertirXL2Txt(Me.m_sCheminFichierXL, Me.m_msgDelegue) Else bOk = bConvertirXLODBC(bAuto:=True) End If Me.cmdConv.Enabled = True Me.cmdAnnuler.Enabled = False If bOk And bRelease Then Me.Close() End Sub Private Sub AfficherMessage(ByVal sMsg$) Me.sbStatusBar.Text = sMsg Application.DoEvents() End Sub Private Sub m_oODBC_EvAfficherMessage(ByVal sMsg$) _ Handles m_oODBC.EvAfficherMessage AfficherMessage(sMsg) End Sub Private Sub AfficherMessageEv(ByVal sender As Object, ByVal e As clsMsgEventArgs) _ Handles m_msgDelegue.EvAfficherMessage Me.AfficherMessage(e.sMessage) ' Autre solution : 'AddHandler glb.msgDelegue.EvAfficherMessage, _ ' AddressOf AfficherMessageEv End Sub #End Region #Region "Conversion" Private Sub cmdConv_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdConv.Click Me.cmdAnnuler.Enabled = True Me.cmdConv.Enabled = False If Me.m_iTypeConv = TypeConv.XL2CsvAutomation Then bConvertirXLAutomation(Me.m_sCheminFichierXL, Me.m_msgDelegue) ElseIf Me.m_iTypeConv = TypeConv.XL2Csv Then bConvertirXLRapide(Me.m_sCheminFichierXL, Me.m_msgDelegue) ElseIf Me.m_iTypeConv = TypeConv.XL2Txt Then bConvertirXL2Txt(Me.m_sCheminFichierXL, Me.m_msgDelegue) Else bConvertirXLODBC(bAuto:=False) End If Me.cmdConv.Enabled = True Me.cmdAnnuler.Enabled = False End Sub Private Sub cmdAnnuler_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdAnnuler.Click Me.m_oODBC.Annuler() Me.m_msgDelegue.m_bAnnuler = True End Sub Private Function bConvertirXLODBC(ByVal bAuto As Boolean) As Boolean ' 16/04/2011 Il faut vraiment vérifier, sinon c'est trop long ! If Not bFichierAccessibleMultiTest(Me.m_sCheminFichierXL, Me.m_msgDelegue, _ bEcriture:=False) Then Exit Function Me.m_oODBC.m_bAfficherMsg = False Me.m_oODBC.m_sChaineConnexionDirecte = _ "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & Me.m_sCheminFichierXL & ";" & _ "Extended Properties=""Excel 8.0;"";" AfficherMessage("Analyse du fichier Excel " & _ IO.Path.GetFileName(Me.m_sCheminFichierXL) & " en cours...") Me.m_oODBC.LibererRessources() Me.m_oODBC.m_bPrompt = False Me.m_oODBC.m_bVerifierConfigODBCExcel = False ' Déjà fait une fois Me.m_oODBC.m_bCopierDonneesPressePapier = False ' Sauf en mode Debug Me.m_oODBC.m_bLireToutDUnBloc = True ' Mettre False pour éviter de remplacer les , par des . pour les nombres réels ' (cela permet de réouvrir correctement les fichiers csv sous Excel avec la ,) Me.m_oODBC.m_bRemplacerSepDec = bRemplacerSepDec Me.m_oODBC.m_bEnleverEspacesFin = bEnleverEspacesFin ' Appliquer un TrimEnd = RTrim Me.m_oODBC.m_bRemplacerVraiFaux = bRemplacerVraiFaux Me.m_oODBC.m_sValFaux = sValFaux Me.m_oODBC.m_sValVrai = sValVrai If Not Me.m_oODBC.bExplorerSourceODBC( _ bExplorerChamps:=True, bRenvoyerContenu:=bDebug) Then Exit Function Dim sTable$ Dim iNumTable% = 0 Dim sbContenu As New StringBuilder ' Mémoriser les champs Dim asChamps$(,) = DirectCast(Me.m_oODBC.m_asChamps.Clone, String(,)) Dim iNbChpsMax% = asChamps.GetUpperBound(1) ' Dimension : 1 : NbTables, 2 : NbChamps Dim iNbChamps% = UBound(asChamps, 2) + 1 If Me.m_iTypeConv = TypeConv.XL2CsvGroup Then ' Mode tableau : mettre ligne entete comme premier classeur ' D'abord le nom de la table sbContenu.Append("Table;") AjouterEnteteTable(sbContenu, Me.m_oODBC.m_iNumTableMaxChamps, asChamps, iNbChamps) ElseIf Me.m_iTypeConv = TypeConv.XL2Txt Then sbContenu.Append("Fichier source : " & Me.m_sCheminFichierXL & vbCrLf) Dim fi As New IO.FileInfo(Me.m_sCheminFichierXL) Dim lTailleFichier& = fi.Length Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier) ' Attention à l'heure de la date : l'explorateur de Windows XP ' enlève 1 heure si l'on est passé à l'heure d'hiver depuis la date à afficher ' c'est n'importe quoi ! ' Heureusement fi.LastWriteTime affiche toujours la bonne heure (et la même heure) sbContenu.Append("Taille : " & sTailleFichier & _ ", Date : " & fi.LastWriteTime & vbCrLf & vbCrLf) End If ' Traiter d'abord les tables ayant le plus de champ afin d'avoir toutes les entetes Dim sCheminFichier$ = "" Dim iNbTables% = Me.m_oODBC.m_alTables.Count Dim iPasse% For iPasse = 0 To 1 ' 2 Passes iNumTable = 0 For Each sTable In Me.m_oODBC.m_alTables Dim bTableMax As Boolean = False If Me.m_oODBC.m_aiNbChamps(iNumTable) = iNbChpsMax Then bTableMax = True 'If iPasse = 0 And sTable <> Me.m_oODBC.m_sNomTableMaxChamps Then Continue For 'If iPasse = 1 And sTable = Me.m_oODBC.m_sNomTableMaxChamps Then Continue For If iPasse = 0 And Not bTableMax Then GoTo TableSuivante If iPasse = 1 And bTableMax Then GoTo TableSuivante AfficherMessage("Lecture de la feuille [" & sTable.Replace("$", "") & _ "] en cours... (" & iNumTable + 1 & "/" & iNbTables & ")") If Me.m_oODBC.bAnnuler Then Exit For Me.m_oODBC.m_sListeSQL = "Select * From [" & sTable & "]" If Not Me.m_oODBC.bLireSourceODBC(bRenvoyerContenu:=bDebug, _ bNePasFermerConnexion:=True) Then Exit Function ' Analyse du ou des tableaux résultats ' Enlever le $ à la fin de la table Dim sNomTable$ = sNomTableExcel(sTable) If Me.m_iTypeConv = TypeConv.XL2Txt Then sbContenu.Append("Table : [" & sNomTable & "]" & vbCrLf & vbCrLf) ElseIf Me.m_iTypeConv = TypeConv.XL2CsvGroup Then ' Rien à faire Else sbContenu = New StringBuilder End If Dim asTableau$(,) = CType(Me.m_oODBC.m_aoMetaTableau(0), String(,)) If IsNothing(asTableau) Then ' 21/02/2009 Aucun enregistrement Dim iNbColonnes0% = asChamps.GetUpperBound(1) + 1 ' Feuille vide et sans entête (sauf si l'entête est justement F1 !) If iNbColonnes0 = 1 And asChamps(0, 0) = "F1" Then GoTo TableSuivante ' Feuille vide et avec entête If Me.m_iTypeConv = TypeConv.XL2Txt Or _ Me.m_iTypeConv = TypeConv.XL2CsvODBC Then AjouterEnteteTable(sbContenu, iNumTable, asChamps, iNbColonnes0) End If If Me.m_iTypeConv = TypeConv.XL2CsvODBC Then Dim sCheminFichier0$ = IO.Path.GetDirectoryName( _ Me.m_sCheminFichierXL) & "\" & sNomTable & ".csv" If Not bEcrireFichier(sCheminFichier0, sbContenu) Then GoTo Erreur sCheminFichier = sCheminFichier0 End If GoTo TableSuivante End If If Me.m_iTypeConv = TypeConv.XL2Txt Then _ sbContenu.Append("Table;") Dim iNbColonnes% = asTableau.GetUpperBound(0) + 1 If Me.m_iTypeConv = TypeConv.XL2Txt Or _ Me.m_iTypeConv = TypeConv.XL2CsvODBC Then AjouterEnteteTable(sbContenu, iNumTable, asChamps, iNbColonnes) End If Dim iNbLignes% = asTableau.GetUpperBound(1) + 1 Dim i%, j% For j = 0 To iNbLignes - 1 If Me.m_iTypeConv = TypeConv.XL2CsvGroup Or _ Me.m_iTypeConv = TypeConv.XL2Txt Then _ sbContenu.Append(sNomTable & ";") For i = 0 To iNbColonnes - 1 Dim sVal$ = asTableau(i, j) ' Rq sans enreg. : 1 ligne en fait If IsNothing(sVal) Then Exit For sbContenu.Append(sVal) ' Ne pas ajouter le dernier ; pour faire comme Excel If i < iNbColonnes - 1 Then sbContenu.Append(";") Next i sbContenu.Append(vbCrLf) Next j If Me.m_iTypeConv = TypeConv.XL2Txt Then sbContenu.Append(vbCrLf & vbCrLf) ElseIf Me.m_iTypeConv = TypeConv.XL2CsvGroup Then ' Ne rien ajouter Else Dim sCheminFichier0$ = IO.Path.GetDirectoryName( _ Me.m_sCheminFichierXL) & "\" & sNomTable & ".csv" If Not bEcrireFichier(sCheminFichier0, sbContenu) Then GoTo Erreur sCheminFichier = sCheminFichier0 ' 15/12/2007 Le noter s'il n'y en a qu'un End If TableSuivante: iNumTable += 1 Next sTable Next iPasse If bDebug And Not IsNothing(Me.m_oODBC.m_sbContenuRetour) Then _ CopierPressePapier(Me.m_oODBC.m_sbContenuRetour.ToString) Me.m_oODBC.LibererRessources() AfficherMessage("Opération terminée.") If Me.m_oODBC.bAnnuler Then Exit Function Dim sTypeConv$ = "en fichiers csv" Dim sExt$ = ".csv" If Me.m_iTypeConv = TypeConv.XL2CsvGroup Then sTypeConv = "en fichier csv" ElseIf Me.m_iTypeConv = TypeConv.XL2Txt Then sTypeConv = "en fichier texte" sExt = ".txt" End If ' 15/12/2007 Non car déjà fait : Or (Me.m_iTypeConv = TypeConv.XL2CsvODBC And iNumTable = 1) If Me.m_iTypeConv = TypeConv.XL2CsvGroup Or _ Me.m_iTypeConv = TypeConv.XL2Txt Then sCheminFichier = IO.Path.GetDirectoryName( _ Me.m_sCheminFichierXL) & "\" & _ IO.Path.GetFileNameWithoutExtension( _ Me.m_sCheminFichierXL) & sExt If Not bEcrireFichier(sCheminFichier, sbContenu) Then GoTo Erreur End If bConvertirXLODBC = True Me.cmdAnnuler.Enabled = False If Me.m_iTypeConv = TypeConv.XL2CsvODBC And iNumTable > 1 Then ' Plusieurs fichiers possibles Dim sInfo$ = "Le classeur :" & vbCrLf & Me.m_sCheminFichierXL & vbCrLf & _ "a été converti " & sTypeConv & " avec succès !" & vbCrLf & "(via ODBC)" MsgBox(sInfo, MsgBoxStyle.Information, sTitreMsg) Else If sCheminFichier.Length = 0 Then ' 21/02/2009 Dim sInfo$ = "Le classeur est vide !" & vbCrLf & Me.m_sCheminFichierXL MsgBox(sInfo, MsgBoxStyle.Information, sTitreMsg) Else ProposerOuvrirFichier(sCheminFichier) End If End If Exit Function Erreur: AfficherMessage("Erreur !") End Function Private Sub AjouterEnteteTable(ByRef sbContenu As StringBuilder, _ ByVal iNumTable%, ByVal asChamps$(,), ByVal iNbChamps%) Dim i% ' Dimension : 1 : NbTables, 2 : NbChamps 'Dim iNbChamps% = UBound(asChamps, 2) + 1 For i = 0 To iNbChamps - 1 Dim sChamp$ = asChamps(iNumTable, i) sbContenu.Append(sChamp) ' Ne pas ajouter le dernier ; pour faire comme Excel If i < iNbChamps - 1 Then sbContenu.Append(";") Next i sbContenu.Append(vbCrLf) End Sub Private Function sNomTableExcel$(ByVal sTable$) ' Enlever le $ à la fin de la table Dim iLen% = sTable.Length sNomTableExcel = sTable.Substring(0, iLen - 1) If sTable.Chars(0) = "'"c And _ sTable.Chars(iLen - 1) = "'"c Then sNomTableExcel = sTable.Substring(1, iLen - 3) End If ' 12/03/2010 sNomTableExcel = sConvNomDos(sNomTableExcel) End Function #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 Const sChemin$ = """%1""" If Me.chkXL2Csv.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsv, _ bPrompt, , sMenuCtx_CleCmdConvertirEnCsvDescription, sCheminExe, _ sChemin) If Me.chkFusionCsv.Checked Then If bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEn1Csv, _ bPrompt, , sMenuCtx_CleCmdConvertirEn1CsvDescription, sCheminExe, _ sChemin & " " & sXL2CsvGroup) Then clsODBC.VerifierConfigODBCExcel() ' 07/01/2012 V1.08 End If End If If Me.chkTexte.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnTxt, _ bPrompt, , sMenuCtx_CleCmdConvertirEnTxtDescription, sCheminExe, _ sChemin & " " & sXL2Txt) If Me.chkODBC.Checked Then If bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvODBC, _ bPrompt, , sMenuCtx_CleCmdConvertirEnCsvODBCDescription, sCheminExe, _ sChemin & " " & sXL2CsvODBC) Then clsODBC.VerifierConfigODBCExcel() ' 07/01/2012 V1.08 End If End If If Me.chkAutomation.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvAutomation, _ bPrompt, , sMenuCtx_CleCmdConvertirEnCsvAutomationDescription, sCheminExe, _ sChemin & " " & sXL2CsvAutomation) VerifierMenuCtx() End Sub Private Sub cmdEnleverMenuCtx_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdEnleverMenuCtx.Click If Me.chkXL2Csv.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsv, _ bEnlever:=True, bPrompt:=False) If Me.chkFusionCsv.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEn1Csv, _ bEnlever:=True, bPrompt:=False) If Me.chkTexte.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnTxt, _ bEnlever:=True, bPrompt:=False) If Me.chkODBC.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvODBC, _ bEnlever:=True, bPrompt:=False) If Me.chkAutomation.Checked Then _ bAjouterMenuContextuel(sMenuCtx_TypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvAutomation, _ bEnlever:=True, bPrompt:=False) VerifierMenuCtx() End Sub Private Sub VerifierMenuCtx() Dim sCleDescriptionCmd$ = sMenuCtx_TypeFichierExcel & "\shell\" & _ sMenuCtx_CleCmdConvertirEnCsv Dim bCleXL2Csv As Boolean = bCleRegistreCRExiste(sCleDescriptionCmd) Dim sCleDescriptionCmdFusion$ = sMenuCtx_TypeFichierExcel & "\shell\" & _ sMenuCtx_CleCmdConvertirEn1Csv Dim bCleFusion As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdFusion) Dim sCleDescriptionCmdAutomation$ = sMenuCtx_TypeFichierExcel & "\shell\" & _ sMenuCtx_CleCmdConvertirEnCsvAutomation Dim bCleAutom As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdAutomation) Dim sCleDescriptionCmdODBC$ = sMenuCtx_TypeFichierExcel & "\shell\" & _ sMenuCtx_CleCmdConvertirEnCsvODBC Dim bCleODBC As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdODBC) Dim sCleDescriptionCmdTxt$ = sMenuCtx_TypeFichierExcel & "\shell\" & _ sMenuCtx_CleCmdConvertirEnTxt Dim bCleTxt As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdTxt) If bCleXL2Csv Or bCleFusion Or bCleAutom Or bCleODBC Or bCleTxt Then Me.cmdAjouterMenuCtx.Enabled = False Me.cmdEnleverMenuCtx.Enabled = True Me.chkXL2Csv.Checked = bCleXL2Csv Me.chkFusionCsv.Checked = bCleFusion Me.chkAutomation.Checked = bCleAutom Me.chkODBC.Checked = bCleODBC Me.chkTexte.Checked = bCleTxt ' Interdire de décocher Me.chkXL2Csv.Enabled = False Me.chkFusionCsv.Enabled = False Me.chkAutomation.Enabled = False Me.chkODBC.Enabled = False Me.chkTexte.Enabled = False Else Me.cmdAjouterMenuCtx.Enabled = True Me.cmdEnleverMenuCtx.Enabled = False ' Autoriser à cocher Me.chkXL2Csv.Enabled = True Me.chkFusionCsv.Enabled = True Me.chkODBC.Enabled = True Me.chkTexte.Enabled = True Me.chkAutomation.Enabled = True End If End Sub #End Region End Class clsAfficherMsg.vb ' Fichier clsAfficherMsg.vb : Classes de gestion des messages via des délégués ' ------------------------- Public Class clsTickEventArgs : Inherits EventArgs ' Classe pour l'événement Tick : avancement d'une unité de temps : TIC-TAC ' utile pour mettre à jour l'heure en cours, ou pour scruter une annulation Public Sub New() End Sub End Class Public Class clsMsgEventArgs : Inherits EventArgs ' Classe pour l'événement Message Private m_sMsg$ = "" 'Nothing Public Sub New(ByVal sMsg$) 'If sMsg Is Nothing Then Throw New NullReferenceException If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property End Class Public Class clsFECEventArgs : Inherits EventArgs ' Classe pour l'événement Fichier En Cours (FEC) Private m_iNumFichierEnCours% = 0 Public Sub New(ByVal iNumFichierEnCours%) Me.m_iNumFichierEnCours = iNumFichierEnCours End Sub Public ReadOnly Property iNumFichierEnCours%() Get Return Me.m_iNumFichierEnCours End Get End Property End Class Public Class clsAvancementEventArgs : Inherits EventArgs ' Classe pour l'événement Avancement Private m_sMsg$ = "" Private m_lAvancement& = 0 Public Sub New(ByVal sMsg$) If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public Sub New(ByVal lAvancement&) Me.m_lAvancement = lAvancement End Sub Public Sub New(ByVal lAvancement&, ByVal sMsg$) Me.m_lAvancement = lAvancement If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public ReadOnly Property sMessage$() Get Return Me.m_sMsg End Get End Property Public ReadOnly Property lAvancement&() Get Return Me.m_lAvancement End Get End Property End Class Public Class clsSablierEventArgs : Inherits EventArgs ' Classe pour l'événement Sablier Private m_bDesactiver As Boolean = False Public Sub New(ByVal bDesactiver As Boolean) Me.m_bDesactiver = bDesactiver End Sub Public ReadOnly Property bDesactiver() As Boolean Get Return Me.m_bDesactiver End Get End Property End Class Public Class clsMsgDelegue ' Classe de gestion des messages via des délégués Public Delegate Sub GestEvTick(ByVal sender As Object, _ ByVal e As clsTickEventArgs) Public Event EvTick As GestEvTick Public Delegate Sub GestEvAfficherMessage(ByVal sender As Object, _ ByVal e As clsMsgEventArgs) Public Event EvAfficherMessage As GestEvAfficherMessage Public Delegate Sub GestEvAfficherFEC(ByVal sender As Object, _ ByVal e As clsFECEventArgs) Public Event EvAfficherNumFichierEnCours As GestEvAfficherFEC Public Delegate Sub GestEvAfficherAvancement(ByVal sender As Object, _ ByVal e As clsAvancementEventArgs) Public Event EvAfficherAvancement As GestEvAfficherAvancement Public Delegate Sub GestEvSablier(ByVal sender As Object, _ ByVal e As clsSablierEventArgs) Public Event EvSablier As GestEvSablier Public m_bAnnuler As Boolean Public Sub New() End Sub Public Sub AfficherMsg(ByVal sMsg$) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvAfficherMessage(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFichierEnCours(ByVal iNumFichierEnCours%) Dim e As New clsFECEventArgs(iNumFichierEnCours) RaiseEvent EvAfficherNumFichierEnCours(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherAvancement(ByVal lAvancement&, ByVal sMsg$) Dim e As New clsAvancementEventArgs(lAvancement, sMsg) RaiseEvent EvAfficherAvancement(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub Tick() Dim e As New clsTickEventArgs() RaiseEvent EvTick(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub Sablier(Optional ByVal bDesactiver As Boolean = False) Dim e As New clsSablierEventArgs(bDesactiver) RaiseEvent EvSablier(Me, e) TraiterMsgSysteme_DoEvents() End Sub End Class clsHebOffice.vb Option Strict Off ' Pour oWkb.Close() ' clsHebOffice : classe pour héberger une application Office (Word, Excel, ...) ' basée sur clsExcelHost, cf. XLDOTNET : ' XLDOTNET : QUITTER EXCEL SANS LAISSER D'INSTANCE EN RAM ' http://www.vbfrance.com/code.aspx?id=27541 #Region "Informations" ' D'après : ' ====================================================================================== ' clsExcelHost : Classe pour héberger Excel ' ============ ' Title: EXCEL.EXE Process Killer ' Description: After many weeks of trying to figure out why the EXCEL.EXE Process ' does not want to go away from the Task Manager, I wrote this class that will ensure ' that the correct EXCEL.EXE Process is closed. This is after using Excel.Application ' via Automation from a VB.NET/ASP.NET application. ' This file came from Planet-Source-Code.com... the home millions of lines of source code ' You can view comments on this code/and or vote on it at: ' http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=1998&lngWId=10 ' The author may have retained certain copyrights to this code... ' please observe their request and the law by reviewing all copyright conditions ' at the above URL. ' Author: I.W Coetzer 2004/01/22 ' *Thanks Dan for the process idea. ' Classe commentée et légèrement modifiée par Patrice Dargenton le 05/11/2004 ' *Solution to the EXCEL.EXE Process that does not want to go away from task manager. ' ' ====================================================================================== #End Region #Region "clsHebOffice" Public Class clsHebOffice Public m_oApp As Object = Nothing 'Protected Private m_iIdProcess% = 0 Public m_bAppliDejaOuverte As Boolean = False Public m_bInterdireAppliAvant As Boolean = True Public m_sNomProcess$ = "" Public Sub New(ByVal sNomProcess$, ByVal sClasseObjet$, _ Optional ByVal bInterdireAppliAvant As Boolean = True, _ Optional ByVal bReutiliserInstance As Boolean = False) ' Exemple : 'Private Const sClasseObjetWord$ = "Word.Application" 'Private Const sNomProcessWord$ = "Word" 'Private Const sClasseObjetExcel$ = "Excel.Application" 'Private Const sNomProcessExcel$ = "Excel" Me.m_iIdProcess = 0 Me.m_bAppliDejaOuverte = False Me.m_bInterdireAppliAvant = bInterdireAppliAvant Me.m_sNomProcess = sNomProcess Dim sNomProcessMaj$ = sNomProcess.ToUpper ' Liste des processus avant le mien Dim aProcessAv() As Process = Process.GetProcesses() Dim j% For j = 0 To aProcessAv.GetUpperBound(0) If aProcessAv(j).ProcessName = sNomProcessMaj Then Me.m_bAppliDejaOuverte = True Exit For End If Next j If bInterdireAppliAvant And Me.m_bAppliDejaOuverte Then Exit Sub ' Créer le processus demandé Try If Me.m_bAppliDejaOuverte And bReutiliserInstance Then ' Pb : on récupère n'importe quelle instance ' il faudrait plutôt conserver l'instance qu'on a créée Me.m_oApp = GetObject(, sClasseObjet) Else Me.m_oApp = CreateObject(sClasseObjet) End If Catch Ex As Exception 'AfficherMsgErreur2(Ex, "clsHebOffice:New", _ ' sNomProcess & " n'est pas installé !") MsgBox(sClasseObjet & " n'est pas installé !" & vbLf & _ Ex.Message, MsgBoxStyle.Critical, _ "Lancement de " & sNomProcess) Me.m_oApp = Nothing Exit Sub End Try ' Liste des processus après le mien : la différence me donnera l'Id du mien Dim aProcessAp() As Process = Process.GetProcesses() Dim i% Dim bMonProcess As Boolean For j = 0 To aProcessAp.GetUpperBound(0) If aProcessAp(j).ProcessName = sNomProcessMaj Then bMonProcess = True ' Parcours des processus avant le mien For i = 0 To aProcessAv.GetUpperBound(0) If aProcessAv(i).ProcessName = sNomProcessMaj Then If aProcessAp(j).Id = aProcessAv(i).Id Then ' S'il existait avant, ce n'était pas le mien bMonProcess = False Exit For End If End If Next i If bMonProcess = True Then ' Maintenant que j'ai son Id, je pourrai le tuer ' cette méthode marche toujours ! Me.m_iIdProcess = aProcessAp(j).Id Exit For End If End If Next j End Sub Public Sub Quitter() If Me.m_iIdProcess = 0 Then Exit Sub If Not bMonInstanceOuverte() Then ' 28/08/2009 L'instance n'est plus ouverte, mais voir s'il faut libérer les variables 'Try ' 27/02/2011 Déjà Try catch dans la fct LibererObjetCom LibererObjetCom(Me.m_oApp) 'Me.m_oApp = Nothing : Déjà fait 'Catch ex As Exception ' Debug.WriteLine(ex) 'End Try Exit Sub End If LibererObjetCom(Me.m_oApp) ' 27/02/2011 ' 27/02/2011 Cette ligne peut echouer si le process est déjà quitté : ' "Un processus ayant l'ID x n'est pas exécuté" 'Dim monProc As Process = Process.GetProcessById(Me.m_iIdProcess) Dim monProc As Process = Nothing Try monProc = Process.GetProcessById(Me.m_iIdProcess) Catch 'ex As Exception ' Le processus vient de se terminer, il n'y a plus rien à faire Exit Sub End Try ' Même si l'instance a été fermée, monProc est toujours valide : ' ce test n'est pas suffisant If Not IsNothing(monProc) Then Try ' 15/05/2009 Libérer avant de tuer le processus ' Pour Excel l'objet oXL a déjà été libéré, ' mais il faut aussi libérer m_oApp ? c'est pourtant le même pointeur !? 'LibererObjetCom(Me.m_oApp) 27/02/2011 'Me.m_oApp = Nothing : Déjà fait ' Si l'instance ne nous appartient pas, on ne peut pas la fermer ' mais on ne reçoit aucune exception ! ' 27/02/2011 If Not monProc.HasExited : inutile de tuer alors If Not monProc.HasExited Then monProc.Kill() ' On ne peut pas interroger immédiatement ExitCode, seule solution : ' vérifier si l'appli est toujours ouverte avec l'iIdProcess 'If monProc.ExitCode = -1 Then ' ' MainModule vaut alors {"Accès refusé"} ' Debug.WriteLine("Impossible de fermer " & _ ' Me.m_sNomProcess & " : " & monProc.MainModule.ToString) 'End If Catch ex As Exception Debug.WriteLine(ex) End Try End If End Sub Public Function bMonInstanceOuverte() As Boolean ' Vérifier si l'instance que j'ai utilisée est encore ouverte ' (elle a pu être fermée par l'utilisateur si on l'autorise) If Me.m_iIdProcess = 0 Then Exit Function ' 28/08/2009 Avec Word cela ne marche pas, car Word déjà quitté ' D'abord on vérifie s'il ne reste plus aucune instance If Not bOuvert(Me.m_sNomProcess) Then Exit Function Dim monProc As Process Try ' Puis on teste si on peut récupérer l'instance monProc = Process.GetProcessById(Me.m_iIdProcess) Catch ' On ne peut pas : l'instance est déjà fermée ' "Un processus ayant l'ID xxxx n'est pas exécuté." Exit Function End Try ' Même si l'instance a été fermée, monProc est toujours valide : ' cette fonction n'est pas suffisante 'If IsNothing(monProc) Then Exit Function 'bMonInstanceOuverte = True ' 15/05/2009 Try bMonInstanceOuverte = Not monProc.HasExited() Catch 'ex As Exception ' On vient juste de fermer End Try End Function Public Shared Function bOuvert(ByVal sNomProcess$) As Boolean ' Vérifier si l'application est déjà ouverte ' (pour le cas où cela poserait problème, faire la vérification au départ) Dim sNomProcessMaj$ = sNomProcess.ToUpper ' Liste des processus avant le mien Dim aProcessAv() As Process = Process.GetProcesses() Dim j% For j = 0 To aProcessAv.GetUpperBound(0) If aProcessAv(j).ProcessName = sNomProcessMaj Then bOuvert = True : Exit Function Next j End Function Public Shared Sub LibererObjetCom(ByRef oCom As Object) ' ByRef car on fait oCom = Nothing) ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing ' Pour Excel : ' Quit Excel and clean up. ' oBook.Close(false, oMissing, oMissing); ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBook); ' oBook = null; ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBooks); ' oBooks = null; ' oExcel.Quit(); ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oExcel); ' oExcel = null; If IsNothing(oCom) Then Exit Sub Try Runtime.InteropServices.Marshal.ReleaseComObject(oCom) Catch ex As Exception Debug.WriteLine(ex) Finally oCom = Nothing End Try End Sub End Class #End Region #Region "clsHebExcel" Public Class clsHebExcel : Inherits clsHebOffice ' clsHebExcel : classe pour héberger Excel, basée sur clsHebOffice Private Const sClasseObjetExcel$ = "Excel.Application" Private Const sNomProcessExcel$ = "Excel" Public oXL As Object = Nothing Public Sub New(Optional ByVal bInterdireAppliAvant As Boolean = True, _ Optional ByVal bReutiliserInstance As Boolean = False) MyBase.New(sNomProcessExcel, sClasseObjetExcel, _ bInterdireAppliAvant, bReutiliserInstance) Me.oXL = Me.m_oApp End Sub Public Overloads Shared Function bOuvert() As Boolean bOuvert = clsHebOffice.bOuvert(sNomProcessExcel) End Function Public Sub Fermer(ByRef oSht As Object, ByRef oWkb As Object, ByVal bQuitter As Boolean, _ Optional ByVal bFermerClasseur As Boolean = True, _ Optional ByVal bLibererXLSiResteOuvert As Boolean = True) ' Liberer correctement le classeur, et le femer si demandé, ' et quitter Excel si demandé If bFermerClasseur AndAlso Not IsNothing(oWkb) Then 'msgDelegue.AfficherMsg("Fermeture du classeur...") Try oWkb.Close(SaveChanges:=False) ' Si Excel 2007 veut sauver qqch.: Non merci. Catch ex As Exception Debug.WriteLine(ex) End Try End If LibererObjetCom(oSht) LibererObjetCom(oWkb) ' Conserver Excel ouvert (par exemple pour visualiser l'actualisation d'un classeur) ' on libère oXL dans le cas général (sauf si on doit continuer d'utiliser l'instance ' par ex. pour effectuer d'autres traitements) If Not bQuitter Then If bLibererXLSiResteOuvert Then LibererObjetCom(Me.oXL) Exit Sub End If If Not IsNothing(Me.oXL) Then Try 'msgDelegue.AfficherMsg("Fermeture d'Excel...") If Me.bMonInstanceOuverte() Then Me.oXL.Quit() Catch ex As Exception ' L'application a été fermée par l'utilisateur, on n'y a plus accès ' ou bien on tente d'utiliser l'objet Me.oXL qui a déjà été libéré ' "Un objet COM qui a été séparé de son RCW sous-jacent ne peut pas être utilisé." Debug.WriteLine(ex) End Try 'msgDelegue.AfficherMsg("Libération d'Excel...") LibererObjetCom(Me.oXL) End If Me.Quitter() End Sub End Class #End Region #Region "clsHebWord" Public Class clsHebWord : Inherits clsHebOffice ' clsHebWord : classe pour héberger Word, basée sur clsHebOffice Private Const sClasseObjetWord$ = "Word.Application" Private Const sNomProcessWrd$ = "Winword" '"Word" Public oWrd As Object = Nothing Public Sub New(Optional ByVal bInterdireAppliAvant As Boolean = True) MyBase.New(sNomProcessWrd, sClasseObjetWord, bInterdireAppliAvant) oWrd = Me.m_oApp End Sub Public Overloads Shared Function bOuvert() As Boolean bOuvert = clsHebOffice.bOuvert(sNomProcessWrd) End Function End Class #End Region #Region "clsHebNav" Public Class clsHebNav ' clsHebNav : classe pour héberger un navigateur (Internet Explorer ou Firefox) Private Const sNomProcessIE$ = "iexplore" Private Const sNomProcessFireFox$ = "firefox" Public oAppNav As Object = Nothing Private m_iIdProcess% Public Sub New(ByVal sURL$) Me.m_iIdProcess = 0 ' Liste des processus avant le mien Dim aProcessAv() As Process = Process.GetProcesses() OuvrirAppliAssociee(sURL, bVerifierFichier:=False) ' Liste des processus après le mien : la différence me donnera l'Id du mien Dim aProcessAp() As Process = Process.GetProcesses() Dim i%, j% Dim bMonProcessNav As Boolean For j = 0 To aProcessAp.GetUpperBound(0) Dim sNomProcess$ = aProcessAp(j).ProcessName If sNomProcess = sNomProcessIE Or sNomProcess = sNomProcessFireFox Then bMonProcessNav = True ' Parcours des processus avant le mien For i = 0 To aProcessAv.GetUpperBound(0) Dim sNomProcess1$ = aProcessAv(i).ProcessName If sNomProcess1 = sNomProcessIE Or _ sNomProcess1 = sNomProcessFireFox Then If aProcessAp(j).Id = aProcessAv(i).Id Then ' S'il existait avant, ce n'était pas le mien bMonProcessNav = False Exit For End If End If Next i If bMonProcessNav = True Then ' Maintenant que j'ai son Id, je pourrai le controler Me.m_iIdProcess = aProcessAp(j).Id Exit For End If End If Next j End Sub Public Function bOuvert() As Boolean ' On peut savoir si l'utilisateur a fermé le navigateur ouvert ' par l'application If Me.m_iIdProcess = 0 Then Exit Function Try bOuvert = Not Process.GetProcessById(Me.m_iIdProcess).HasExited() Catch 'ex As Exception ' On vient juste de fermer End Try End Function Public Sub Quitter() If Me.m_iIdProcess = 0 Then Exit Sub 'Process.GetProcessById(Me.m_iIdProcess).Kill() Dim monProc As Process = Process.GetProcessById(Me.m_iIdProcess) ' Même si l'instance a été fermée, monProc est toujours valide : ' ce test n'est pas suffisant If Not IsNothing(monProc) Then Try ' 15/05/2009 Libérer avant de tuer le processus LibererObjetCom(Me.oAppNav) 'Me.oAppNav = Nothing : Déjà fait ' Si l'instance ne nous appartient pas, on ne peut pas la fermer ' mais on ne reçoit aucune exception ! monProc.Kill() ' On ne peut pas interroger immédiatement ExitCode, seule solution : ' vérifier si l'appli est toujours ouverte avec l'iIdProcess 'If monProc.ExitCode = -1 Then ' ' MainModule vaut alors {"Accès refusé"} ' Debug.WriteLine("Impossible de fermer " & _ ' Me.m_sNomProcess & " : " & monProc.MainModule.ToString) 'End If Catch ex As Exception Debug.WriteLine(ex) End Try End If End Sub Public Shared Sub LibererObjetCom(ByRef oCom As Object) ' ByRef car on fait oCom = Nothing) ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing If IsNothing(oCom) Then Exit Sub Try Runtime.InteropServices.Marshal.ReleaseComObject(oCom) Catch Finally oCom = Nothing End Try End Sub End Class #End Region clsODBC.vb ' Fichier clsODBC.vb ' ------------------ ' Version 1.15 du 16/11/2011 : Dsn auto : If Me.m_bPrompt seulement ' Version 1.14 du 19/09/2010 : Vérification du dépassement de colonnes ' Version 1.13 du 10/04/2009 : m_iNbTentatives de lectures pour Excel ' Version 1.12 du 14/10/2008 : TypeGuessRows Excel : même avec Office 2003 ! ' Version 1.11 du 13/04/2008 : Mode bLireToutDUnBlocRapide amélioré ' Version 1.10 du 26/01/2008 : TypeGuessRows Excel automatique par le code ' Version 1.09 du 25/11/2007 : TypeGuessRows Excel automatique amélioré ' Version 1.08 du 22/11/2007 : Correction requête insertion ' Version 1.07 du 18/11/2007 : Correction bilan exploration ' Version 1.06 du 08/11/2007 : Correction chronométrage ' Version 1.05 du 12/05/2007 : Autre table fantôme Excel : [MonClasseur$_] ' Version 1.04 du 11/03/2007 : Gestion des tables fantômes d'Excel Imports System.Text ' Pour StringBuilder Public Class clsODBC #Region "Déclarations" Public Const sValErreurDef$ = "#Erreur#" ' Evénement signalant l'arrivée d'un message ' (avancement de l'opération en cours ou bien erreur par exemple) Public Event EvAfficherMessage(ByVal sMsg$) ' Si vous voulez contrôler strictement l'état des variables affectées ' depuis l'extérieur de la classe, alors utilisez des propriétés ' Set et Get, et passez ces variables membres en privé dans ce cas ' Requête faite à la volée par le code ' (ou bien liste de requêtes SQL séparées par des ; ) ' (au lieu de requêtes figurant dans un fichier .sql externe) Public m_sListeSQL$ ' Requête spécifique dans le cas où la source est un fichier Excel Public m_sListeSQLExcel$ ' Chaîne de connexion directe à un fichier source, par exemple un fichier Excel Public m_sChaineConnexionDirecte$ ' Chemins vers un fichier DSN et une requête SQL stockés en externe Public m_sCheminDSN$, m_sCheminSQL$ ' Chemins et SQL par défaut lors de la création automatique des fichiers DNS et SQL Public m_sCheminSrcExcel$, m_sCheminSrcAccess$, m_sCheminSrcOmnis$ Public m_sSQLExcelDef$, m_sSQLAccessDef$, m_sSQLOmnisDef$ ' SQL ou liste de SQL Public m_sSQLNavisionDef$, m_sSQLDB2Def$ ' Pour les accès ODBC nécessitant une authentification Public m_sCompteUtilisateur$, m_sMotDePasse$ ' Pour les accès ODBC de type serveur, comme Navision, DB2, ... Public m_sCompteSociete$, m_sNomServeur$ ' Afficher les messages dans les boites de dialogues Public m_bPrompt As Boolean ' Générer des événements pour afficher le détail des opérations en cours Public m_bAfficherMsg As Boolean ' Booléen pour indiquer si le pilote ODBC supporte le retour arrière ' (vrai pour Excel et Access, faux pour Omnis) ' C'est utile pour connaitre à l'avance le nombre de lignes de la source ODBC ' mais cela peut faire perdre du temps : on peut laisser à faux dans ce cas Public m_bODBCArriere As Boolean ' Utile pour effectuer une requête action via une chaîne de connexion directe Public m_bModeEcriture As Boolean ' Copier tout le contenu retourné par les requêtes SQL dans le presse-papier Public m_bCopierDonneesPressePapier As Boolean ' Vérifier la présence du fichier source de données ' (ne pas vérifier s'il n'y a pas de fichier spécifique) Public m_bVerifierFichierSourceDonnees As Boolean ' Vérifier le risque d'erreur de lecture avec Excel < 2003 Public m_bVerifierConfigODBCExcel As Boolean ' Possibilité d'annuler proprement le requêtage depuis l'interface Private m_bAnnuler As Boolean ' Si on lance des requêtes succesives par petits groupes de données ' permet de conserver si une annulation a été demandé Public m_bNePasInitAnnulation As Boolean ' S'il y a plusieurs requêtes consécutives (liste de SQL séparés par un ;), ' cette option permet d'interrompre la requête en cours, ' mais de poursuivre les autres requêtes Public m_bInterrompreSeulementRqEnCours As Boolean ' Remplacer le séparateur décimal dans les valeurs par le . ' pour pouvoir convertir les nombres en réels via Val Public m_bRemplacerSepDec As Boolean ' Remplacer seulement les champs numériques : tester avec IsNumeric ' (attention : IsNumeric est très lent : mieux vaut remplacer tous les champs) ' Autre solution : se baser sur le schéma de la table pour détecter les numériques Public m_bRemplacerSepDecNumSeul As Boolean Private m_bRemplacerSepDecRequis As Boolean Private m_sSepDecimal$ Public m_bEnleverEspacesFin As Boolean ' Appliquer un TrimEnd = RTrim Public m_bRemplacerVraiFaux As Boolean Public m_sValVrai$, m_sValFaux$ ' Valeurs à appliquer en guise de Vrai et Faux Public m_sValErreur$ ' Indiquer la présence d'au moins 1 erreur de lecture de la valeur d'un champ ' (pour l'ensemble des requêtes successives) Public m_bErreursLecture As Boolean ' Méthode ADODB.GetString : Attention, le format des dates peut être différent Public m_bLireToutDUnBloc As Boolean ' Délimiteur ; par défaut et pas de traitement du contenu des champs : Public m_bLireToutDUnBlocRapide As Boolean Public m_sbLignes As StringBuilder ' Stocker les résultats Public m_aoMetaTableau() As Object ' Explorateur ODBC Public m_alTables As ArrayList Public m_asChamps$(,) ' 18/11/2007 Public m_sNomTableMaxChamps$, m_iNumTableMaxChamps%, m_aiNbChamps%() Public m_sbContenuRetour As StringBuilder Public m_bAjouterChronoDebug As Boolean Private Const sTypeODBCExcel$ = "Excel" Private Const sTypeODBCAccess$ = "Access" Private Const sTypeODBCOmnis$ = "Omnis" Private Const sTypeODBCNavision$ = "Navision" Private Const sTypeODBCDB2$ = "DB2" ' Nombre d'enregistrement alloués à l'avance pour le stockage des lignes Public m_iNbEnregAlloues% Private Const iNbEnregAllouesDef% = 100 Private m_oConn As ADODB.Connection = Nothing Public m_iNbTentatives% = 0 ' Tentatives de lecture, par ex. fichier Excel partagé Public ReadOnly Property bAnnuler() As Boolean Get ' Savoir si une annulation est en cours bAnnuler = Me.m_bAnnuler End Get End Property Public Sub Annuler() ' Demander une annulation Me.m_bAnnuler = True End Sub #End Region #Region "Divers" Public Sub New() Me.m_sCheminDSN = "" Me.m_sCheminSQL = "" Me.m_sChaineConnexionDirecte = "" Me.m_sListeSQL = "" Me.m_sListeSQLExcel = "" Me.m_sCheminSrcExcel = "" Me.m_sCheminSrcAccess = "" Me.m_sCheminSrcOmnis = "" Me.m_sSQLExcelDef = "" Me.m_sSQLAccessDef = "" Me.m_sSQLOmnisDef = "" Me.m_sSQLNavisionDef = "" Me.m_sSQLDB2Def = "" Me.m_sNomTableMaxChamps = "" Me.m_iNumTableMaxChamps = 0 Me.m_sCompteSociete = "" Me.m_sNomServeur = "" Me.m_sCompteUtilisateur = "" Me.m_sMotDePasse = "" Me.m_bODBCArriere = False Me.m_bCopierDonneesPressePapier = True Me.m_bPrompt = True Me.m_bRemplacerSepDec = True Me.m_bRemplacerSepDecNumSeul = False Me.m_bEnleverEspacesFin = True Me.m_bRemplacerVraiFaux = True Me.m_sValVrai = "1" Me.m_sValFaux = "" Me.m_sValErreur = sValErreurDef Me.m_bNePasInitAnnulation = False Me.m_bInterrompreSeulementRqEnCours = False Me.m_bAfficherMsg = True Me.m_bVerifierFichierSourceDonnees = True Me.m_bVerifierConfigODBCExcel = True Me.m_bLireToutDUnBloc = False Me.m_bLireToutDUnBlocRapide = False Me.m_bAjouterChronoDebug = True Me.m_iNbEnregAlloues = iNbEnregAllouesDef LibererRessources() End Sub Public Sub LibererRessources() Me.m_bErreursLecture = False Me.m_bAnnuler = False Me.m_aoMetaTableau = Nothing Me.m_alTables = Nothing Me.m_asChamps = Nothing Me.m_aiNbChamps = Nothing 'Me.m_sLignes = "" Me.m_sbLignes = New StringBuilder ViderContenuResultat() If Not Me.m_oConn Is Nothing Then Me.m_oConn.Close() Me.m_oConn = Nothing End If End Sub Public Sub ViderContenuResultat() Me.m_sbContenuRetour = Nothing End Sub Private Sub AfficherMessage(ByVal sMsg$) If Not Me.m_bAfficherMsg Then Exit Sub RaiseEvent EvAfficherMessage(sMsg) Application.DoEvents() End Sub Private Sub AfficherErreursADO(ByVal oConnexion As ADODB.Connection, ByRef sMsgErr$) ' Note sur ByVal oConnexion : ' En VB .NET, il n'est plus nécessaire de passer les objets par ' reférence. De plus, le ByVal est plus rapide (même pour les objets), ' ce qui n'est pas le cas en VB6. Explication : en VB .NET ' si on utilise ByVal, l'objet est copié une fois, mais il est copié ' 2 fois dans le cas du ByRef, selon "VB.NET Professionnel" de Wrox Team If oConnexion Is Nothing Then Exit Sub Dim sMsg$ = "" Dim oErrADO As ADODB.Error For Each oErrADO In oConnexion.Errors sMsg &= "Erreur ADO : " & oErrADO.Description & vbCrLf sMsg &= "Numéro : " & oErrADO.Number & " (" & _ Hex(oErrADO.Number) & ")" & vbCrLf If oErrADO.SQLState <> "" Then _ sMsg &= "Erreur Jet : " & oErrADO.SQLState & vbCrLf If oErrADO.Number = -2147467259 Then ' Si le pilote ODBC n'est pas installé, on peut obtenir l'erreur : ' [Microsoft][Gestionnaire de pilotes ODBC] ' Source de données introuvable et nom de pilote non spécifié" ' Numéro : -2147467259 (80004005), Erreur Jet : IM002 sMsg &= "Cause possible : Le pilote ODBC spécifié n'est pas installé sur ce poste." & vbCrLf End If If oErrADO.Number = -2147217884 Then ' L'ensemble de lignes ne prend pas en charge les récupérations arrière sMsg &= "Explication : Le pilote ODBC ne supporte pas le retour en arrière." & vbCrLf sMsg &= "(Utilisez m_bODBCArriere = False en paramètre)" & vbCrLf End If MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) Next oErrADO sMsgErr &= vbCrLf & sMsg End Sub Public Shared Sub VerifierConfigODBCExcel() ' Vérifier la configuration ODBC pour Excel : ' Pour Excel < 2003, la configuration par défaut peut être insuffisante ' voir la fonction bCreerFichierDsnODBC() Const sCle$ = "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel" Const sSousCleTGR$ = "TypeGuessRows" Dim sValCleTGR$ = "" If Not bCleRegistreLMExiste(sCle, sSousCleTGR, sValCleTGR) Then Exit Sub ' 14/10/2008 Même avec Office2003 le problème existe ! ' Si on détermine qu'Office2003 ou > est installé, inutile de générer une alerte 'Const sSousCleWin32$ = "win32" 'Const sSousCleWin32Old$ = "win32old" 'Dim sValCleWin32$ = "" 'Dim sValCleWin32Old$ = "" 'bCleRegistreLMExiste(sCle, sSousCleWin32, sValCleWin32) 'bCleRegistreLMExiste(sCle, sSousCleWin32Old, sValCleWin32Old) 'sValCleWin32 = sValCleWin32.ToLower 'If sValCleWin32.Length > 0 And sValCleWin32Old.Length > 0 Then ' ' 24/11/2007 : Office10 = XP : insuffisant, il faut 11 ou > ' If (sValCleWin32.IndexOf("office11\msaexp30.dll") > -1 Or _ ' sValCleWin32.IndexOf("office12\msaexp30.dll") > -1) And _ ' sValCleWin32Old.IndexOf("msexcl40.dll") > -1 Then Exit Sub 'End If If sValCleTGR.Length = 0 Then Exit Sub ' Eviter IsNumeric : très lent ! AndAlso IsNumeric(sValCleTGR) Then Dim iValCleTGR% = iConv(sValCleTGR, -1) If Not (iValCleTGR > -1 And iValCleTGR < 1024) Then Exit Sub 'MsgBox("La configuration ODBC pour Excel risque d'être insuffisante :" & vbLf & _ ' "Augmentez la valeur pour lire un plus grand nombre de lignes pour déterminer" & vbLf & _ ' "le type de données capable de stocker les valeurs d'une colonne Excel" & vbLf & _ ' "TypeGuessRow=" & iValCleTGR & " < 1024" & vbLf & _ ' "Clé : HKEY_LOCAL_MACHINE\" & sCle & vbLf & _ ' "Pour cela, il suffit de lancer ODBCExcelAugmenterTypeGuessRows.reg", _ ' MsgBoxStyle.Exclamation, sTitreMsg) Dim sNouvVal$ = "16384" If MsgBoxResult.Cancel = MsgBox( _ "La configuration ODBC pour Excel risque d'être insuffisante :" & vbLf & _ "Cliquez sur OK pour augmentez la valeur (" & sNouvVal & ")" & vbLf & _ "pour lire un plus grand nombre de lignes pour déterminer" & vbLf & _ "le type de données capable de stocker les valeurs d'une colonne Excel" & vbLf & _ "TypeGuessRow=" & iValCleTGR & " < 1024" & vbLf & _ "Clé : HKEY_LOCAL_MACHINE\" & sCle, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, sTitreMsg) Then Exit Sub ' Faire la modif par le code si on a le droit Dim sMsg$ = "Echec de la correction de TypeGuessRow !" Dim bOk As Boolean = False If bCleRegistreLMExiste(sCle, sSousCleTGR, sValCleTGR, sNouvVal) Then If bCleRegistreLMExiste(sCle, sSousCleTGR, sValCleTGR) Then If sValCleTGR = sNouvVal Then _ bOk = True : sMsg = "La correction de TypeGuessRow a réussie !" End If End If If bOk Then MsgBox(sMsg, MsgBoxStyle.Exclamation, sTitreMsg) Else MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) End If End Sub #End Region #Region "Lecture de la source ODBC" Public Function bLireSQL(ByRef sListeSQL$, ByRef sContenuDSN$, _ ByVal bNoterContenu As Boolean, ByRef sbContenu As StringBuilder, _ Optional ByVal bVerifierSQL As Boolean = True, _ Optional ByRef bExcel As Boolean = False) As Boolean sListeSQL$ = "" sContenuDSN$ = "" 'Dim bExcel As Boolean = False If Me.m_sChaineConnexionDirecte.Length > 0 Then If bNoterContenu Then _ sbContenu.Append("Chaîne de connexion directe : " & _ Me.m_sChaineConnexionDirecte & vbCrLf) sListeSQL = Me.m_sListeSQL If Me.m_sChaineConnexionDirecte.IndexOf("Excel") > -1 Then bExcel = True If Me.m_bVerifierConfigODBCExcel Then VerifierConfigODBCExcel() End If Else ' S'il n'y a pas de chaîne de connexion directe, on utilise un fichier DSN ' ainsi qu'un fichier SQL : on peut ainsi personnaliser les requêtes en ' fonction de la source ODBC (si la source DSN est détectée comme étant de ' type Excel, c'est plus simple d'utiliser une requête spécifique ' (Me.m_sListeSQLExcel) que d'ajouter un $ à la fin des noms des tables, ' ce qui n'est envisageable que pour une requête simple ' Si le fichier DSN est absent, on peut le créer automatiquement If Not bFichierExiste(Me.m_sCheminDSN) Then If Not bCreerFichiersDsnEtSQLODBCDefaut() Then Exit Function End If sContenuDSN = sLireFichier(Me.m_sCheminDSN) ' Si par exemple base AS400, alors ne pas faire de vérification ' car DBQ n'indique pas un chemin vers un fichier spécifique du disque dur If Me.m_bVerifierFichierSourceDonnees Then ' Lorsque le fichier DSN est déjà créé, vérifier la présence de la source ODBC ' si le pilote fonctionne ainsi (on teste toutes les possibilités) ' Dans le cas d'un accès réseau, cela permet de tester l'accessibilité ' à la base plutôt que d'afficher un message d'erreur obscur If Not bVerifierCheminODBC("DataFilePath=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("DBQ=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("Database=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("Dbf=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("SourceDB=", sContenuDSN) Then Exit Function ' Vérification des dossiers aussi If Not bVerifierCheminODBC("DefaultDir=", sContenuDSN, _ bDossier:=True) Then Exit Function If Not bVerifierCheminODBC("PPath=", sContenuDSN, _ bDossier:=True) Then Exit Function End If ' Si le pilote est pour Omnis et qu'on a oublié de désactiver m_bODBCArriere ' on le fait, car un MoveLast() peut être très très long ! If Me.m_bODBCArriere AndAlso _ sContenuDSN.IndexOf("DRIVER=OMNIS ODBC Driver") > -1 Then Me.m_bODBCArriere = False End If If sContenuDSN.IndexOf("DRIVER=Microsoft Excel Driver") > -1 Then bExcel = True If Me.m_bVerifierConfigODBCExcel Then VerifierConfigODBCExcel() End If If bNoterContenu Then sbContenu.Append("Fichier DSN : " & Me.m_sCheminDSN & " : " & vbCrLf) sbContenu.Append(sContenuDSN & vbCrLf) End If If Me.m_sListeSQL.Length > 0 Then ' Requête(s) à la volée par le code sListeSQL = Me.m_sListeSQL Else If bVerifierSQL Then If Me.m_sCheminSQL.Length = 0 Then _ MsgBox("Le chemin vers le fichier SQL est vide !", _ MsgBoxStyle.Critical, sTitreMsg) : Exit Function ' S'il n'y a pas de requête à la volée par le code, ' alors lire le contenu du fichier SQL externe If Not bFichierExiste(Me.m_sCheminSQL, bPrompt:=True) Then _ Exit Function sListeSQL = sLireFichier(Me.m_sCheminSQL) End If End If End If If bExcel AndAlso Me.m_sListeSQLExcel.Length > 0 Then _ sListeSQL = Me.m_sListeSQLExcel bLireSQL = True End Function Private Function bCheminFichierProbable(ByVal sChemin$) As Boolean ' Voir si le chemin supposé est un vrai chemin, ou bien simplement ' un nom de base de données de type serveur, ' auquel cas, il ne faut pas chercher à vérifier la présence du fichier ' de source de donnée If sChemin.IndexOf("\") > -1 Then bCheminFichierProbable = True End Function Public Function bExplorerSourceODBC( _ Optional ByVal bExplorerChamps As Boolean = True, _ Optional ByVal sNomTableAExplorer$ = "", _ Optional ByVal bRenvoyerContenu As Boolean = False) As Boolean ' Explorer la structure de la source ODBC indiquée par le fichier .dsn ' Pour manipuler des grandes quantités de chaînes, ' StringBuilder est beaucoup plus rapide que String Dim sbContenu As StringBuilder = Nothing Dim bNoterResultat As Boolean = False If bRenvoyerContenu Or Me.m_bCopierDonneesPressePapier Then bNoterResultat = True sbContenu = New StringBuilder End If Dim sListeSQL$ = "" Dim sContenuDSN$ = "" Dim bExcel As Boolean = False If Not bLireSQL(sListeSQL, sContenuDSN, bNoterResultat, sbContenu, _ bVerifierSQL:=False, bExcel:=bExcel) Then Me.AfficherMessage("Erreur !") Exit Function End If ' On initialise à Nothing pour éviter les avertissements intempestifs de VB8 Dim oConn As ADODB.Connection = Nothing Dim oRq As ADODB.Recordset = Nothing Dim bConnOuverte As Boolean, bRqOuverte As Boolean If Not Me.m_bNePasInitAnnulation Then Me.m_bAnnuler = False Me.m_bErreursLecture = False End If Try oConn = New ADODB.Connection oRq = New ADODB.Recordset AfficherMessage("Ouverture de la connexion ODBC en cours...") Sablier() oConn.Mode = ADODB.ConnectModeEnum.adModeRead Dim sConnexion$ If Me.m_sChaineConnexionDirecte.Length = 0 Then sConnexion = "FILEDSN=" & Me.m_sCheminDSN & ";" Else sConnexion = Me.m_sChaineConnexionDirecte End If oConn.Open(sConnexion) bConnOuverte = True Me.m_alTables = New ArrayList If bNoterResultat Then _ sbContenu.Append(vbCrLf & vbCrLf & "Tables :" & vbCrLf) AfficherMessage("Exploration des tables en cours...") oRq.CursorType = ADODB.CursorTypeEnum.adOpenForwardOnly ' Exploration des clés primaires : non pris en charge par les pilotes ODBC 'ADODB.SchemaEnum.adSchemaPrimaryKeys 'Dim asRestrictions$(4) ' Non pris en charge par les pilotes ODBC 'asRestrictions(0) = Nothing ' TABLE_CATALOG 'asRestrictions(1) = Nothing ' TABLE_SCHEMA 'asRestrictions(2) = sNomTableAExplorer ' TABLE_NAME 'asRestrictions(3) = Nothing ' TABLE_TYPE ' http://www.sahirshah.com/articles/ADOOpenSchema.html oRq = oConn.OpenSchema(ADODB.SchemaEnum.adSchemaTables) ', asRestrictions) bRqOuverte = True Dim iNbChamps% = oRq.Fields.Count If iNbChamps = 0 Then GoTo RequeteSuivante ' 18/11/2007 'If iNbChamps = 0 Then bRqOuverte = False : GoTo RequeteSuivante If oRq.EOF Then If Me.m_bPrompt Then _ MsgBox("Aucune table trouvée !", MsgBoxStyle.Exclamation) GoTo RequeteSuivante End If Dim iNumTable% = 0 While Not oRq.EOF Dim sNomTable$ = oRq.Fields("TABLE_NAME").Value.ToString 'If (iNumTable Mod 10 = 0) And iNumTable > 0 Then ' Dim sAvancement$ = _ ' "Exploration des tables en cours... (enreg. n°" & _ ' iNumTable + 1 & ")" ' AfficherMessage(sAvancement) ' ' Interrompre l'exploration ' If Me.m_bAnnuler Then Exit While 'End If ' Si une table à explorer est précisée, ne lister que cette table ' (car l'exploration peut être très longue sur les grosses bases) If sNomTableAExplorer.Length > 0 AndAlso _ sNomTable <> sNomTableAExplorer Then GoTo TableSuivante ' Un classeur Excel contient parfois aussi ' des tables fantômes (sauvegarde de l'aperçu impression ?) Dim sTypeObjet$ = oRq.Fields("TABLE_TYPE").Value.ToString If bExcel AndAlso sNomTable.EndsWith("$Impression_des_t") Then If bNoterResultat Then _ sbContenu.Append(sTypeObjet & " : [" & _ sNomTable & "] : Table fantôme Excel ignorée" & vbCrLf) GoTo TableSuivante End If ' Autre exemple de table fantôme sous Excel : [MonClasseur$_] If bExcel AndAlso Not (sNomTable.EndsWith("$") Or sNomTable.EndsWith("$'")) Then ' Normalement, le nom de la table Excel doit se terminer par $ ou $' ' Parfois (???) on ne peut pas explorer ce genre de table ' Il peut s'agir aussi de plages nommées sous Excel If bNoterResultat Then _ sbContenu.Append(sTypeObjet & " : [" & _ sNomTable & "] : Table fantôme Excel ignorée" & vbCrLf) GoTo TableSuivante End If Me.m_alTables.Add(sNomTable) iNumTable += 1 ' 18/11/2007 ' Pour Excel, la plupart des tables sont de type "SYSTEM TABLE" ' Ignorer les tables systèmes de MS-Access 'If Left(sNomTable, 4) = "MSys" Then GoTo TableSuivante If bNoterResultat Then sbContenu.Append( _ sTypeObjet & " : [" & sNomTable & "]" & vbCrLf) ' 25/11/2007 'If bNoterResultat Then ' sbContenu.Append(vbCrLf).Append("Informations sur la table :").Append(vbCrLf) ' sbContenu.Append(sTypeObjet & " : [" & sNomTable & "]" & vbCrLf) ' Dim i%, j% ' For i = 0 To oRq.Fields.Count - 1 ' sbContenu.Append(oRq.Fields(i).Name & _ ' " : [" & oRq.Fields(i).Value.ToString & "]" & vbCrLf) ' 'For j = 0 To oRq.Fields(i).Properties.Count - 1 ' ' sbContenu.Append( _ ' ' "P " & oRq.Fields(i).Properties(j).Name & _ ' ' " : [" & oRq.Fields(i).Properties(j).Value.ToString & "]" & vbCrLf) ' 'Next j ' Next i 'End If TableSuivante: oRq.MoveNext() 'iNumTable += 1 ' 18/11/2007 End While AfficherMessage("Exploration des tables terminée : " & iNumTable) 'If bDebug Then Threading.Thread.Sleep(500) RequeteSuivante: If bRqOuverte Then oRq.Close() : bRqOuverte = False If Not bExplorerChamps Then GoTo FinOk ' Exploration des champs des tables ' Documentation : ADO Data Types (incomplet pour Access) ' http://www.w3schools.com/ado/ado_datatypes.asp ' Comment interpréter les données via ADO OpenSchema adSchemaColumns : ' MS SQL DataTypes QuickRef ' http://webcoder.info/reference/MSSQLDataTypes.html If bNoterResultat Then sbContenu.Append(vbCrLf) Dim sTable$ 'Dim iNbTables% = iNumTable Dim iNbTables% = Me.m_alTables.Count ' 18/11/2007 ReDim Me.m_aiNbChamps(iNbTables - 1) ReDim Me.m_asChamps(iNbTables, 0) iNumTable = 0 Dim iNbChampsTableMax% = 0 For Each sTable In Me.m_alTables If (iNumTable Mod 10 = 0 Or iNumTable = iNbTables - 1) And iNumTable > 0 Then Dim sAvancement$ = _ "Exploration des champs en cours... (table n°" & _ iNumTable + 1 & "/" & iNbTables & ")" AfficherMessage(sAvancement) ' Interrompre l'exploration If Me.m_bAnnuler Then sbContenu.Append( _ "(interruption de l'utilisateur)").Append(vbCrLf) Exit For End If End If ' Attention, avec une connexion directe sur un fichier Excel ' l'ordre des champs est perdu ! mais pas avec un dsn !!! ' Heureusement, en lisant la valeur du champ ORDINAL_POSITION ' et en stockant le résultat dans un tableau de string, ' on retrouve l'ordre exact des champs oRq.CursorType = ADODB.CursorTypeEnum.adOpenKeyset oRq = oConn.OpenSchema(ADODB.SchemaEnum.adSchemaColumns, _ New Object() {Nothing, Nothing, sTable}) bRqOuverte = True If bNoterResultat Then _ sbContenu.Append(vbCrLf & "Table [" & sTable & "] :" & vbCrLf) ' Ne marche pas ici : 'oRq.MoveLast() 'Dim iNbChampsTable% = oRq.RecordCount 'oRq.MoveFirst() Dim iNumChampMax% = 0 Dim iNumChamp% = 0 If (oRq.BOF And oRq.EOF) Then GoTo TableSuivante2 ' Table vide 18/11/2007 While Not oRq.EOF Dim iNumChampTable% = 0 Dim oValChamp As Object = oRq.Fields("ORDINAL_POSITION").Value If IsDBNull(oValChamp) Then iNumChampTable = iNumChamp Else iNumChampTable = CInt(oValChamp) - 1 End If If iNumChampTable > iNumChampMax Then _ iNumChampMax = iNumChampTable iNumChamp += 1 oRq.MoveNext() End While oRq.MoveFirst() Me.m_aiNbChamps(iNumTable) = iNumChampMax Dim iNbChampsTable% = iNumChampMax If iNbChampsTable > iNbChampsTableMax Then iNbChampsTableMax = iNbChampsTable Me.m_sNomTableMaxChamps = sTable ' 18/11/2007 Me.m_iNumTableMaxChamps = iNumTable End If ' Prendre tjrs le max du nbre de champs sur toutes les tables ReDim Preserve Me.m_asChamps(iNbTables, iNbChampsTableMax) iNumChamp = 0 While Not oRq.EOF Dim sDescription$ = "" If Not IsDBNull(oRq.Fields("Description").Value) Then _ sDescription = oRq.Fields("Description").Value.ToString Dim sChamp$ = oRq.Fields("COLUMN_NAME").Value.ToString Dim oValChamp As Object = oRq.Fields("ORDINAL_POSITION").Value Dim iNumChampTable% = 1 If IsDBNull(oValChamp) Then iNumChampTable = iNumChamp Else iNumChampTable = CInt(oValChamp) - 1 End If If bNoterResultat Then Dim sAffTaille$ = "" Dim lTailleCar& = 0 If Not IsDBNull(oRq.Fields("CHARACTER_MAXIMUM_LENGTH").Value) Then lTailleCar = CLng(oRq.Fields("CHARACTER_MAXIMUM_LENGTH").Value) If lTailleCar = 1073741823 Then sAffTaille = ":1Go" Else sAffTaille = ":" & lTailleCar.ToString End If End If Dim sAffTypeDonnees$ = "" Dim lDataType& = 0 If Not IsDBNull(oRq.Fields("DATA_TYPE").Value) Then lDataType& = CLng(oRq.Fields("DATA_TYPE").Value) Dim lVal As ADODB.DataTypeEnum = CType(lDataType, ADODB.DataTypeEnum) sAffTypeDonnees = " (" & lVal.ToString & sAffTaille & ")" End If Dim sAffDescr$ = "" If sDescription.Length > 0 Then sAffDescr = " : " & sDescription sbContenu.Append(" [" & sChamp & "]" & _ sAffTypeDonnees & sAffDescr & vbCrLf) End If 'Dim lFlags& = 0 'If Not IsDBNull(oRq.Fields("COLUMN_FLAGS").Value) Then ' lFlags = CLng(oRq.Fields("COLUMN_FLAGS").Value) 'End If Me.m_asChamps(iNumTable, iNumChampTable) = sChamp iNumChamp += 1 oRq.MoveNext() End While TableSuivante2: oRq.Close() : bRqOuverte = False iNumTable += 1 Next sTable If iNbTables > 0 Then AfficherMessage("Exploration des champs terminée : " & _ iNumTable & "/" & iNbTables) If bDebug Then Threading.Thread.Sleep(500) End If FinOk: If bNoterResultat Then If sNomTableAExplorer.Length > 0 And Me.m_alTables.Count = 0 Then sbContenu.Append( _ "Table [" & sNomTableAExplorer & "] non trouvée !" & vbCrLf) End If sbContenu.Append(vbCrLf & vbCrLf) sbContenu.Append( _ "Documentation : ADO Data Types (incomplet pour Access) :" & vbCrLf) sbContenu.Append("www.w3schools.com/ado/ado_datatypes.asp" & vbCrLf) End If Catch ex As Exception Sablier(bDesactiver:=True) Dim sMsg$ = "" If Me.m_sChaineConnexionDirecte.Length = 0 Then sMsg &= vbCrLf & "Dsn : " & Me.m_sCheminDSN Else sMsg &= vbCrLf & "Chaîne de connexion : " & Me.m_sChaineConnexionDirecte End If Dim sDetailMsgErr$ = "" ' Ne pas copier l'erreur dans le presse-papier maintenant ' car on va le faire dans le Finally Dim sMsgErrFinal$, sMsgErrADO$, sDetail$ If bConnOuverte Then sDetail = "Certains champs sont peut-être introuvables, ou bien :" Else sDetail = "Erreur lors de l'ouverture de la connexion " If sContenuDSN.Length > 0 Then sDetail &= "'" & sLireNomPiloteODBC(sContenuDSN) & "' :" Else sDetail &= ":" End If End If sMsgErrFinal = "" : sMsgErrADO = "" AfficherMsgErreur2(ex, "bExplorerSourceODBC", sMsg, sDetail, _ bCopierMsgPressePapier:=False, sMsgErrFinal:=sMsgErrFinal) If Me.m_bCopierDonneesPressePapier Then _ sbContenu.Append(vbCrLf & sMsgErrFinal & vbCrLf) AfficherErreursADO(oConn, sMsgErrADO) If Me.m_bCopierDonneesPressePapier Then _ sbContenu.Append(sMsgErrADO & vbCrLf) Me.AfficherMessage("Erreur !") Exit Function Finally Sablier(bDesactiver:=True) If bRqOuverte Then oRq.Close() : bRqOuverte = False ' Connexion ADODB et non OleDb If bConnOuverte Then oConn.Close() : bConnOuverte = False ' Copier les informations dans le presse-papier (utile pour le debogage) If Me.m_bCopierDonneesPressePapier Then _ CopierPressePapier(sbContenu.ToString) ' Dans le cas de plusieurs accès ODBC, ' on peut avoir besoin de mémoriser tous les contenus successifs If bRenvoyerContenu Then sbContenu.Append(vbCrLf).Append(vbCrLf).Append(vbCrLf) If IsNothing(Me.m_sbContenuRetour) Then _ Me.m_sbContenuRetour = New StringBuilder Me.m_sbContenuRetour.Append(sbContenu) End If End Try If Me.m_bPrompt Then Me.AfficherMessage("Opération terminée.") Dim sMsg$ = "L'exploration de la source ODBC a été effectuée avec succès !" If Me.m_bCopierDonneesPressePapier Then sMsg &= " (cf. presse-papier)" MsgBox(sMsg, vbExclamation, sTitreMsg) End If bExplorerSourceODBC = True End Function Public Function bLireSourceODBC( _ Optional ByVal bRenvoyerContenu As Boolean = False, _ Optional ByVal bNePasFermerConnexion As Boolean = False) As Boolean ' Extraire les données de la requête SQL via la source ODBC ' indiquée par le fichier .dsn ' Pour manipuler des grandes quantités de chaînes, ' StringBuilder est beaucoup plus rapide que String Dim sbContenu As StringBuilder = Nothing Dim sbLigne As StringBuilder = Nothing Dim bNoterResultat As Boolean = False If bRenvoyerContenu Or Me.m_bCopierDonneesPressePapier Then bNoterResultat = True sbContenu = New StringBuilder sbLigne = New StringBuilder End If Dim sListeSQL$ = "" Dim sContenuDSN$ = "" If Not bLireSQL(sListeSQL, sContenuDSN, _ bNoterResultat, sbContenu) Then Me.AfficherMessage("Erreur !") Exit Function End If ' On initialise à Nothing pour éviter les avertissements intempestifs de VB8 Dim oRq As ADODB.Recordset = Nothing Dim bConnOuverte As Boolean, bRqOuverte As Boolean Dim asSQL$() = sListeSQL.Split(CChar(";")) Dim iNbSQL% = 0 Dim sSQL$ = "" Me.m_bRemplacerSepDecRequis = False Me.m_sSepDecimal = "" If Me.m_bRemplacerSepDec Then ' Remplacer , par . dans toutes les valeurs des champs Me.m_sSepDecimal = Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator() If Me.m_sSepDecimal.Length > 0 AndAlso Me.m_sSepDecimal <> "." Then _ Me.m_bRemplacerSepDecRequis = True End If If Not Me.m_bNePasInitAnnulation Then Me.m_bAnnuler = False Me.m_bErreursLecture = False End If Try Sablier() If IsNothing(Me.m_oConn) Then Me.m_oConn = New ADODB.Connection AfficherMessage("Ouverture de la connexion ODBC en cours...") If m_bModeEcriture Then Me.m_oConn.Mode = ADODB.ConnectModeEnum.adModeReadWrite Else Me.m_oConn.Mode = ADODB.ConnectModeEnum.adModeRead 'http://www.w3schools.com/ado/prop_mode.asp 'Allows others to open a connection with any permissions. 'Me.m_oConn.Mode = ADODB.ConnectModeEnum.adModeShareDenyNone End If Dim sConnexion$ If Me.m_sChaineConnexionDirecte.Length = 0 Then sConnexion = "FILEDSN=" & Me.m_sCheminDSN & ";" Else sConnexion = Me.m_sChaineConnexionDirecte End If Me.m_oConn.Open(sConnexion) End If bConnOuverte = True oRq = New ADODB.Recordset Dim iNbRqMax% = asSQL.GetLength(0) Dim iNbChampsMax% = 0 For Each sSQL In asSQL sSQL = sSQL.Trim If sSQL.Length = 0 Then Exit For ReDim Preserve Me.m_aoMetaTableau(iNbSQL) iNbSQL += 1 Dim dDate As Date If bNoterResultat Then sbContenu.Append(vbCrLf & vbCrLf & "SQL n°" & iNbSQL & " : " & _ sSQL & vbCrLf & vbCrLf) dDate = Now AjouterTemps(sbContenu, "Heure début ouverture", dDate, dDate) End If If iNbRqMax >= 100 Then If ((iNbSQL Mod 100 = 0) Or iNbSQL = iNbRqMax) And iNbSQL > 0 Then Dim sAvancement$ = _ "Exécution des requêtes en cours... : SQL n°" & _ iNbSQL & "/" & iNbRqMax AfficherMessage(sAvancement) If Me.m_bAnnuler Then Exit For End If Else AfficherMessage("Exécution de la requête n°" & iNbSQL & " en cours...") If Me.m_bAnnuler Then Exit For End If If Me.m_bODBCArriere Then oRq.CursorType = ADODB.CursorTypeEnum.adOpenKeyset Else oRq.CursorType = ADODB.CursorTypeEnum.adOpenForwardOnly End If ' Par défaut : oRq.LockType = ADODB.LockTypeEnum.adLockReadOnly ' 10/04/2009 Tentatives de lecture, par ex. pour Excel Dim bOk As Boolean = False If m_iNbTentatives > 0 Then For iNumTentative As Integer = 1 To m_iNbTentatives - 1 Try oRq.Open(sSQL, Me.m_oConn) bRqOuverte = True bOk = True Exit For Catch 'Attendre(3000) Threading.Thread.Sleep(3000) ' iDelaiMSec End Try Next End If If Not bOk Then oRq.Open(sSQL, Me.m_oConn) bRqOuverte = True End If Dim asTableau$(,) = Nothing ' Penser à réinitialiser le tableau Dim iNumEnreg%, i%, sValChamp$, iNbEnregAllouesAct% Dim oValChamp As Object Dim iNbChamps% = oRq.Fields.Count ' Cela peut arriver pour les requêtes en écriture, par exemple : ' UPDATE [Article$] SET [Article] = [Article] & '_Test' ' Dans ce cas, pensez à mettre ReadOnly=0 dans le fichier .dsn ' Ne pas faire oRq.Close() pour une requete insertion : cela plante ! 'If iNbChamps = 0 Then GoTo RequeteSuivante If iNbChamps = 0 Then bRqOuverte = False : GoTo RequeteSuivante ' On peut noter les noms des champs systématiquement : pas couteux 'If bNoterResultat Then Dim iNumSQL% = iNbSQL - 1 ' Prendre tjrs le max du nbre de champs sur toutes les rq If iNbChamps > iNbChampsMax Then iNbChampsMax = iNbChamps If iNumSQL = 0 Then ReDim Me.m_asChamps(iNbRqMax, iNbChampsMax) Else ReDim Preserve Me.m_asChamps(iNbRqMax, iNbChampsMax) End If For i = 0 To iNbChamps - 1 Me.m_asChamps(iNumSQL, i) = oRq.Fields(i).Name Next i 'End If If oRq.EOF Then If bNoterResultat Then AjouterTemps(sbContenu, "Heure début analyse ", Now, dDate) dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) End If If Me.m_bPrompt Then _ MsgBox("La requête ne renvoie aucun enregistrement !", _ MsgBoxStyle.Exclamation) GoTo MemoriserTab_RqSuivante End If Dim iNbLignes% = -1 If Me.m_bODBCArriere Then ' Si l'ODBC ne supporte pas le retour en arrière MoveFirst, on obtient ' l'erreur -2147217884 (80040E24) avec la traduction en petit-nègre : ' L'ensemble de lignes ne prend pas en charge les récupérations arrière ' (Le jeu de données - RecordSet : l'objet requête - ' ne prend pas en charge le retour en arrière) ' Les pilotes ODBC Access et Excel le supporte, on peut donc dimensionner ' le tableau à l'avance (quoique le MoveLast ralenti au départ) : AfficherMessage("Détermination du nombre de lignes...") oRq.MoveLast() iNbLignes = oRq.RecordCount AfficherMessage("Retour au début du jeu de données...") oRq.MoveFirst() ReDim asTableau(iNbChamps - 1, iNbLignes - 1) Else iNbLignes = 0 ' Bug corrigé : attendre d'avoir au moins un enregistrement ' sinon on ne pourra pas distinguer entre 0 et 1 enregistrement 'ReDim asTableau(iNbChamps - 1, 0) End If ' On peut optimiser la lecture, mais de toute façon se sera long en ODBC ' GetString est surtout utile conjointement avec OWC ' (test réalisé : beaucoup plus rapide pour lire un fichier Excel en local, ' mais pas de gain constaté pour lire dans un PGI sur le réseau, ' et on n'a plus l'avancement en temps réel) If Me.m_bLireToutDUnBloc Or Me.m_bLireToutDUnBlocRapide Then If bNoterResultat Then 'AjouterTemps(sbContenu, "Heure début lecture ", dDate, dDate) AjouterTemps(sbContenu, "Heure début lecture ", Now, dDate) ' 08/11/2007 dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) ' 13/04/2008 End If AfficherMessage("SQL n°" & iNbSQL & _ " : Lecture des données d'un seul bloc...") If bDebug Then Threading.Thread.Sleep(500) ' Avec un délimiteur ; on peut afficher la ligne directement, ' mais on ne traite pas les champs et il ne faut pas que ' le signe ; se trouve dans le contenu d'un champ texte If Me.m_bLireToutDUnBlocRapide Then Const sDelimiteurColonnesRapide$ = ";" Const sDelimiteurLignesRapide$ = vbCrLf ' 13/04/2008 ' 13/04/2008 : m_bLireToutDUnBlocRapide incompatible avec ' multi-rq, sauf si les rq sont de même structure 'Me.m_sbLignes = New StringBuilder( _ ' oRq.GetString(, , sDelimiteurColonnesRapide)) Dim sb As New StringBuilder( _ oRq.GetString(, , _ sDelimiteurColonnesRapide, sDelimiteurLignesRapide)) If bNoterResultat Then sbContenu.Append(sb) If IsNothing(Me.m_sbLignes) Then Me.m_sbLignes = sb Else Me.m_sbLignes.Append(sb) End If ' On laisse le tableau vide, on ne renvoi que Me.m_sLignes GoTo MemoriserTab_RqSuivante End If Const sDelimiteurColonnes$ = vbTab ' ";" Dim asLignes$() = oRq.GetString(, , _ sDelimiteurColonnes).Split(CChar(vbCr)) If bNoterResultat Then AjouterTemps(sbContenu, "Heure début analyse ", Now, dDate) dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) End If AfficherMessage("SQL n°" & iNbSQL & _ " : Analyse des données en cours...") If bDebug Then Threading.Thread.Sleep(500) Dim sLigne$ iNumEnreg = 0 For Each sLigne In asLignes If sLigne.Length = 0 Then GoTo LigneSuivante Dim asChamps$() = sLigne.Split(CChar(sDelimiteurColonnes)) If iNumEnreg = 0 Then iNbLignes = asLignes.GetLength(0) iNbChamps = asChamps.GetLength(0) ReDim asTableau(iNbChamps - 1, iNbLignes - 1) End If Dim sValChamp0$ Dim iNumChamp% = 0 If bNoterResultat Then sbLigne.Length = 0 For Each sValChamp0 In asChamps If sValChamp0.Length > 0 Then TraiterValChamp(sValChamp0) End If ' 19/09/2010 Vérification du dépassement de colonnes If iNumChamp >= iNbChampsMax Then ' Le contenu du champ contient le séparateur : bug 'Debug.WriteLine("!") Else asTableau(iNumChamp, iNumEnreg) = sValChamp0 End If If bNoterResultat Then sbLigne.Append(sValChamp0) If iNumChamp < iNbChamps - 1 Then sbLigne.Append(";") End If iNumChamp += 1 Next sValChamp0 If bNoterResultat Then sbContenu.Append(sbLigne) sbContenu.Append(vbCrLf) End If iNumEnreg += 1 LigneSuivante: Next sLigne GoTo MemoriserTab_RqSuivante End If ' Autre idée : DataAdaptater.Fill(DataTable) en une instruction ' (méta-tableau de DataTable), mais on n'aura plus l'avancement ' (on peut faire une boucle seulement pour débug) If bNoterResultat Then 'AjouterTemps(sbContenu, "Heure début lecture ", dDate, dDate) AjouterTemps(sbContenu, "Heure début lecture ", Now, dDate) ' 08/11/2007 dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) End If iNumEnreg = 0 : iNbEnregAllouesAct = 0 While Not oRq.EOF If (iNumEnreg Mod 100 = 0) And iNumEnreg > 0 Then Dim sAvancement$ = _ "Lecture de la source ODBC en cours... : SQL n°" & _ iNbSQL & " : enreg. n°" & iNumEnreg + 1 If Me.m_bODBCArriere Then sAvancement &= "/" & iNbLignes AfficherMessage(sAvancement) ' Interrompre la requête en cours If Me.m_bAnnuler Then Exit While End If If bNoterResultat Then sbLigne.Length = 0 If Not Me.m_bODBCArriere Then ' Bug corrigé : attendre le premier enregistrement ' pour commencer à dimensionner le tableau : ReDim If iNumEnreg = 0 Then 'ReDim asTableau(iNbChamps - 1, iNumEnreg) ' Première allocation iNbEnregAllouesAct = Me.m_iNbEnregAlloues ReDim asTableau(iNbChamps - 1, iNbEnregAllouesAct - 1) ElseIf iNumEnreg > iNbEnregAllouesAct - 1 Then ' Redim ne peut changer que la dimension la plus à droite : iNbLignes 'ReDim Preserve asTableau(iNbChamps - 1, iNumEnreg) ' Allocations suivantes iNbEnregAllouesAct += Me.m_iNbEnregAlloues ReDim Preserve asTableau(iNbChamps - 1, iNbEnregAllouesAct - 1) End If End If For i = 0 To iNbChamps - 1 oValChamp = Nothing sValChamp = "" Try oValChamp = oRq.Fields(i).Value If Not IsDBNull(oValChamp) Then ' Attention : La conversion ToString utilise le format ' en vigueur dans les paramètres régionaux de Windows ' par exemple pour le séparateur décimal sValChamp = oValChamp.ToString End If Catch ex As Exception Me.m_bErreursLecture = True sValChamp = Me.m_sValErreur 'Dim s$ = ex.ToString ' Une date du type 30/11/1899 provoque l'erreur suivante ' pourtant IsDate("30/11/1899") est vrai ' et une table Access liée sur cette source renvoie bien ' une vrai date 30/11/1899 ' Run-Time error '-2147217887 (80040E21)' ' Multi-step OLE DB operation generated errors. ' Une opération OLE-DB en plusieurs étapes a généré des erreurs. ' Vérifiez chaque valeur d'état OLE-DB disponible. ' Aucun travail n'a été effectué. 'AfficherErreursADO(oConn) 'Exit Function End Try If sValChamp.Length > 0 Then TraiterValChamp(sValChamp) End If If bNoterResultat Then sbLigne.Append(sValChamp) If i < iNbChamps - 1 Then sbLigne.Append(";") End If asTableau(i, iNumEnreg) = sValChamp Next i If bNoterResultat Then sbContenu.Append(sbLigne) sbContenu.Append(vbCrLf) End If oRq.MoveNext() iNumEnreg += 1 End While ' Avec Me.m_bInterrompreSeulementRqEnCours = True, on peut annuler une requête ' mais poursuivre avec les autres, s'il y en a plusieurs If Me.m_bInterrompreSeulementRqEnCours Then Me.m_bAnnuler = False Else If Me.m_bAnnuler Then sbContenu.Append( _ "(interruption de l'utilisateur)").Append(vbCrLf) Exit Function End If End If MemoriserTab_RqSuivante: ' Réduire la taille allouée du tableau à la taille effective If Me.m_iNbEnregAlloues > 1 AndAlso Not IsNothing(asTableau) Then If asTableau.GetUpperBound(1) >= iNumEnreg Then ReDim Preserve asTableau(iNbChamps - 1, iNumEnreg - 1) End If End If ' Stocker le tableau dans le méta-tableau (tableau de tableaux de string) Me.m_aoMetaTableau(iNbSQL - 1) = asTableau If bNoterResultat Then AjouterTemps(sbContenu, "Heure fin analyse ", Now, dDate) dDate = Now End If RequeteSuivante: If bRqOuverte Then oRq.Close() : bRqOuverte = False Next sSQL Catch ex As Exception Sablier(bDesactiver:=True) ' Si l'erreur a lieu lors de l'ouverture de la connexion ' afficher la liste des SQL If sSQL.Length = 0 Then sSQL = sListeSQL If sSQL.Length > 80 Then sSQL = sSQL.Substring(0, 80) & "..." End If Dim sMsg$ = "SQL : " & sSQL If Me.m_sChaineConnexionDirecte.Length = 0 Then sMsg &= vbCrLf & "Dsn : " & Me.m_sCheminDSN Else sMsg &= vbCrLf & "Chaîne de connexion : " & Me.m_sChaineConnexionDirecte End If Dim sDetailMsgErr$ = "" ' Ne pas copier l'erreur dans le presse-papier maintenant ' car on va le faire dans le Finally Dim sMsgErrFinal$, sMsgErrADO$, sDetail$ If bConnOuverte Then sDetail = "Certains champs sont peut-être introuvables, ou bien :" Else sDetail = "Erreur lors de l'ouverture de la connexion " If sContenuDSN.Length > 0 Then sDetail &= "'" & sLireNomPiloteODBC(sContenuDSN) & "' :" Else sDetail &= ":" End If End If sMsgErrFinal = "" : sMsgErrADO = "" AfficherMsgErreur2(Ex, "bLireSourceODBC", sMsg, sDetail, _ bCopierMsgPressePapier:=False, sMsgErrFinal:=sMsgErrFinal) If bNoterResultat Then sbContenu.Append(vbCrLf & sMsgErrFinal & vbCrLf) AfficherErreursADO(Me.m_oConn, sMsgErrADO) If bNoterResultat Then sbContenu.Append(sMsgErrADO & vbCrLf) Me.AfficherMessage("Erreur !") Exit Function Finally Sablier(bDesactiver:=True) If bRqOuverte And Not IsNothing(oRq) Then _ oRq.Close() : bRqOuverte = False If Not bNePasFermerConnexion Then ' Connexion ADODB et non OleDb If bConnOuverte Then Me.m_oConn.Close() : bConnOuverte = False Me.m_oConn = Nothing End If ' Copier les informations dans le presse-papier (utile pour le debogage) If Me.m_bCopierDonneesPressePapier Then _ CopierPressePapier(sbContenu.ToString) ' Dans le cas de plusieurs accès ODBC, ' on peut avoir besoin de mémoriser tous les contenus successifs If bRenvoyerContenu Then ' Autre syntaxe possible (pour éviter & vbCrLf & vbCrLf) sbContenu.Append(vbCrLf).Append(vbCrLf).Append(vbCrLf) If IsNothing(Me.m_sbContenuRetour) Then _ Me.m_sbContenuRetour = New StringBuilder Me.m_sbContenuRetour.Append(sbContenu) End If End Try Me.AfficherMessage("Opération terminée.") If Me.m_bPrompt Then Dim sMsg$ = "La lecture de la source ODBC a été effectuée avec succès !" If Me.m_bCopierDonneesPressePapier Then sMsg &= " (cf. presse-papier)" MsgBox(sMsg, vbExclamation, sTitreMsg) End If bLireSourceODBC = True End Function Private Sub TraiterValChamp(ByRef sValChamp$) ' Traiter la valeur des champs au cas où If Me.m_bRemplacerSepDecRequis Then ' Quel que soit le séparateur décimal, le convertir en . ' pour pouvoir convertir les nombres en réels via Val() ' IsNumeric dépend du séparateur régional, mais il est très lent ' Voir dans la doc : Notes sur la conversion en nombre réel Dim bRemp As Boolean = True If Me.m_bRemplacerSepDecNumSeul Then If Not IsNumeric(sValChamp) Then bRemp = False End If If bRemp Then sValChamp = sValChamp.Replace(Me.m_sSepDecimal, ".") End If If Me.m_bEnleverEspacesFin Then _ sValChamp = sValChamp.TrimEnd ' = RTrim If Me.m_bRemplacerVraiFaux Then Dim sValChampMin$ = sValChamp.ToLower If sValChampMin = "faux" OrElse sValChampMin = "false" Then _ sValChamp = Me.m_sValFaux If sValChampMin = "vrai" OrElse sValChampMin = "true" Then _ sValChamp = Me.m_sValVrai End If End Sub Private Sub AjouterTemps(ByRef sbContenu As StringBuilder, _ ByVal sTexte$, ByVal dDate2 As Date, ByVal dDate1 As Date) If Not Me.m_bAjouterChronoDebug Then Exit Sub sbContenu.Append(sTexte).Append(" : ") sbContenu.Append(Now.ToLongTimeString) If dDate2 > dDate1 Then sbContenu.Append(" : ") Dim tsDelai As System.TimeSpan = dDate2.Subtract(dDate1) If tsDelai.TotalMinutes >= 1 Then _ sbContenu.Append(tsDelai.TotalMinutes.ToString("0")).Append(" mn : ") sbContenu.Append(tsDelai.TotalSeconds).Append(" sec.") End If sbContenu.Append(vbCrLf) End Sub Private Sub AjouterEntete(ByRef sbContenu As StringBuilder, _ ByVal iNumSQL%, ByVal iNbChamps%) Dim i% For i = 0 To iNbChamps - 1 sbContenu.Append(Me.m_asChamps(iNumSQL, i)) If i < iNbChamps - 1 Then sbContenu.Append(";") Next i sbContenu.Append(vbCrLf) End Sub #End Region #Region "Creation d'un fichier DSN" Private Function bCreerFichiersDsnEtSQLODBCDefaut() As Boolean ' Créer un fichier DSN ODBC par défaut en fonction des sources ' possibles trouvées, ainsi que les requêtes SQL correspondantes ' Chemins des sources ODBC possibles ' Autres fichiers DSN ODBC : www.prosygma.com/odbc-dsn.htm Dim sListeSrcPossibles$ = "" If Me.m_sCheminSrcExcel.Length > 0 Then _ sListeSrcPossibles &= Me.m_sCheminSrcExcel & vbLf If Me.m_sCheminSrcAccess.Length > 0 Then _ sListeSrcPossibles &= Me.m_sCheminSrcAccess & vbLf If Me.m_sCheminSrcOmnis.Length > 0 Then _ sListeSrcPossibles &= Me.m_sCheminSrcOmnis If Me.m_sSQLNavisionDef.Length > 0 And _ Me.m_sCompteSociete.Length > 0 And Me.m_sNomServeur.Length > 0 Then If Not bCreerFichierDsnODBC(sTypeODBCNavision, Me.m_sCheminDSN, _ Me.m_sCheminSQL, "", Me.m_sSQLNavisionDef, _ Me.m_sCompteUtilisateur, Me.m_sMotDePasse, _ Me.m_sCompteSociete, Me.m_sNomServeur) Then _ Exit Function ElseIf Me.m_sSQLDB2Def.Length > 0 And _ Me.m_sCompteSociete.Length > 0 And Me.m_sNomServeur.Length > 0 Then If Not bCreerFichierDsnODBC(sTypeODBCDB2, Me.m_sCheminDSN, _ Me.m_sCheminSQL, "", Me.m_sSQLDB2Def, _ Me.m_sCompteUtilisateur, Me.m_sMotDePasse, _ Me.m_sCompteSociete, Me.m_sNomServeur) Then _ Exit Function ElseIf Me.m_sCheminSrcExcel.Length > 0 AndAlso _ bFichierExiste(Me.m_sCheminSrcExcel) Then If Not bCreerFichierDsnODBC(sTypeODBCExcel, Me.m_sCheminDSN, _ Me.m_sCheminSQL, Me.m_sCheminSrcExcel, Me.m_sSQLExcelDef) Then _ Exit Function ElseIf Me.m_sCheminSrcAccess.Length > 0 AndAlso _ bFichierExiste(Me.m_sCheminSrcAccess) Then If Not bCreerFichierDsnODBC(sTypeODBCAccess, Me.m_sCheminDSN, _ Me.m_sCheminSQL, Me.m_sCheminSrcAccess, Me.m_sSQLAccessDef) Then _ Exit Function ElseIf Me.m_sCheminSrcOmnis.Length > 0 AndAlso _ bFichierExiste(Me.m_sCheminSrcOmnis) Then If Not bCreerFichierDsnODBC(sTypeODBCOmnis, Me.m_sCheminDSN, _ Me.m_sCheminSQL, Me.m_sCheminSrcOmnis, Me.m_sSQLOmnisDef, _ Me.m_sCompteUtilisateur, Me.m_sMotDePasse) Then _ Exit Function Else Dim sMsg$ = "Aucune source ODBC possible n'a été trouvée pour créer un fichier DSN !" If sListeSrcPossibles.Length > 0 Then _ sMsg &= vbLf & "Liste des sources possibles : " & vbLf & sListeSrcPossibles MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) Exit Function End If bCreerFichiersDsnEtSQLODBCDefaut = True End Function Private Function bCreerFichierDsnODBC(ByVal sTypeODBC$, ByVal sCheminDsn$, _ ByVal sCheminSQL$, ByVal sFichierSrc$, ByVal sSQL$, _ Optional ByVal sCompteUtilisateur$ = "", _ Optional ByVal sMotDePasse$ = "", _ Optional ByVal sCompteSociete$ = "", _ Optional ByVal sNomServeur$ = "") As Boolean ' Créer un fichier DSN ODBC par défaut en fonction des sources possibles trouvées ' ainsi que les requêtes SQL correspondantes Dim sSource$ = sFichierSrc Dim sDossierSrc$ = "" If sFichierSrc.Length > 0 Then _ sDossierSrc = IO.Path.GetDirectoryName(sFichierSrc) Dim sb As New StringBuilder ' Autres fichiers DSN ODBC : www.prosygma.com/odbc-dsn.htm Select Case sTypeODBC Case sTypeODBCExcel sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=Microsoft Excel Driver (*.xls)" & vbCrLf) sb.Append("UID=admin" & vbCrLf) sb.Append("UserCommitSync=Yes" & vbCrLf) sb.Append("Threads=3" & vbCrLf) sb.Append("SafeTransactions=0" & vbCrLf) If Me.m_bModeEcriture Then sb.Append("ReadOnly=0" & vbCrLf) Else sb.Append("ReadOnly=1" & vbCrLf) End If sb.Append("PageTimeout=5" & vbCrLf) ' En pratique MaxScanRows n'est pas utilisé dans le fichier DSN ! ' Seule la clé TypeGuessRows de la base de registre : ' HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Jet\4.0\Engines\Excel ' permet de prendre en compte un plus grand nombre de lignes ' pour déterminer automatiquement le type du champ, ' ce qui est nécessaire si les n premières occurrences ' du champs sont vides dans la feuille Excel : ' www.dicks-blog.com/archives/2004/06/03/external-data-mixed-data-types/ ' Utilisez la fonction VerifierConfigODBCExcel() pour vérifier sa valeur ' sauf si vous travaillez avec Excel 2003, qui fonctionne bien ' dans tous les cas, car il utilise une dll plus efficace : ' Microsoft Access Expression Builder : ' C:\Program Files\Microsoft Office\Office11\msaexp30.dll (11.0.6561.0) ' la dll par défaut étant : Microsoft Jet Excel Isam : ' C:\Windows\System32\msexcl40.dll (4.0.8618.0) sb.Append("MaxScanRows=8" & vbCrLf) sb.Append("MaxBufferSize=2048" & vbCrLf) sb.Append("FIL=excel 8.0" & vbCrLf) sb.Append("DriverId=790" & vbCrLf) sb.Append("DefaultDir=" & sDossierSrc & vbCrLf) sb.Append("DBQ=" & sFichierSrc & vbCrLf) ' On peut aussi indiquer un chemin relatif avec . ' Ex.: DefaultDir=.\SourcesODBC\SourceODBC_MSExcel ' DBQ=.\SourcesODBC\SourceODBC_MSExcel\XLDB.xls Case sTypeODBCAccess sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=Microsoft Access Driver (*.mdb)" & vbCrLf) sb.Append("UID=admin" & vbCrLf) sb.Append("UserCommitSync=Yes" & vbCrLf) sb.Append("Threads=3" & vbCrLf) sb.Append("SafeTransactions=0" & vbCrLf) sb.Append("PageTimeout=5" & vbCrLf) sb.Append("MaxScanRows=8" & vbCrLf) sb.Append("MaxBufferSize=2048" & vbCrLf) sb.Append("FIL=MS Access" & vbCrLf) sb.Append("DriverId=25" & vbCrLf) sb.Append("DefaultDir=" & sDossierSrc & vbCrLf) sb.Append("DBQ=" & sFichierSrc & vbCrLf) Case sTypeODBCOmnis ' Pilote : www.omnis.net/downloads/odbc/win32/Omnis%20ODBC%20Driver.exe sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=OMNIS ODBC Driver" & vbCrLf) sb.Append("UID=admin" & vbCrLf) sb.Append("Password=" & sMotDePasse & vbCrLf) sb.Append("Username=" & sCompteUtilisateur & vbCrLf) sb.Append("DataFilePath=" & sFichierSrc & vbCrLf) Case sTypeODBCNavision sSource = sCompteSociete ' Doc sur le pilote C-Odbc : ' http://www.comsolag.de/old/pdf/Handbuch/W1/w1w1codbc.pdf sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=C/ODBC 32 bit" & vbCrLf) sb.Append("UID=" & sCompteUtilisateur & vbCrLf) sb.Append("SERVER=N" & vbCrLf) ' Non documenté ! sb.Append("CN=" & sCompteSociete & vbCrLf) ' The account/company to open sb.Append("RD=No" & vbCrLf) ' Non documenté ! ' ML indique la langue utilisée : 1033 pour l'anglais (USA), ' 1036 pour le français. Les tables et les champs de la requête SQL ' doivent être dans la langue choisie. Il est apparemment impossible ' de faire passer les accents en français, donc laisser 1033. sb.Append("ML=1033" & vbCrLf) ' CD Specifies whether the connection supports closing date. sb.Append("CD=No" & vbCrLf) ' BE Specifies whether BLOB fields should be visible from ODBC. sb.Append("BE=Yes" & vbCrLf) ' CC Specifies whether the commit cache should be used. sb.Append("CC=Yes" & vbCrLf) ' RO Specifies whether access to the Microsoft Business Solutions ' database should be read-only. sb.Append("RO=No" & vbCrLf) sb.Append("QTYesNo=Yes" & vbCrLf) ' Enables or disables query time-out ' IT Specify the way identifiers are returned to an external application sb.Append("IT=All Except Space" & vbCrLf) ' OPT Specifies how the contents of a Navision option field are ' transferred to an application. sb.Append("OPT=Text" & vbCrLf) ' PPath : The name of the folder where the program files are located. Dim sLecteur$ = IO.Path.GetPathRoot(Environment.SystemDirectory) ' Ex.: C:\ sb.Append("PPath=" & sLecteur & _ "Program Files\Microsoft Business Solutions-Navision\Client" & vbCrLf) ' NType : The name of the network protocol module (tcp or netb). sb.Append("NType=tcp" & vbCrLf) sb.Append("SName=" & sNomServeur & vbCrLf) ' The name of the server host computer. ' CSF Specifies whether the driver operates as a client in a ' client/server environment or as a stand-alone. sb.Append("CSF=Yes" & vbCrLf) ' Attention : il n'est pas possible de crypter le mot de passe avec ce pilote : ' La doc recommande de créer un compte utilisateur spécifique avec les seuls ' droits requis pour l'exécution de la requête. sb.Append("PWD=" & sMotDePasse & vbCrLf) Case sTypeODBCDB2 ' DB2 = iSeries d'IBM (anciennement AS/400) sSource = sCompteSociete sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=Client Access ODBC Driver (32-bit)" & vbCrLf) sb.Append("UID=" & sCompteUtilisateur & vbCrLf) ' ou CA400 par défaut ' Pour DB2, il n'y a pas de mot de passe, il faut laisser une connexion ' ouverte et le pilote ODBC va réutiliser cette connexion. ' voir la doc avec SIGNON=1 ' (si la connexion n'est pas ouverte, le système devrait ouvrir une ' boite de dialogue pour saisir le mot de passe, mais je n'ai pas ' réussi à le faire marcher ainsi) sb.Append("DEBUG=64" & vbCrLf) sb.Append("SIGNON=1" & vbCrLf) sb.Append("LIBVIEW=1" & vbCrLf) sb.Append("TRANSLATE=1" & vbCrLf) sb.Append("NAM=1" & vbCrLf) sb.Append("DESC=Source de données ODBC iSeries Access for Windows" & vbCrLf) sb.Append("SQDIAGCODE=" & vbCrLf) sb.Append("DATABASE=" & vbCrLf) sb.Append("QAQQINILIB=" & vbCrLf) sb.Append("PKG=QGPL/DEFAULT(IBM),2,0,1,0,512" & vbCrLf) Dim sLecteur$ = IO.Path.GetPathRoot(Environment.SystemDirectory) ' Ex.: C:\ Dim sUtilisateur$ = Environment.UserName ' A vérifier : sUtilisateur = 'Utilisateur' littéralement ? sb.Append("TRACEFILENAME=" & sLecteur & _ "Documents and Settings\" & sUtilisateur & _ "\Mes documents\IBM\Client Access\Maintenance\Fichiers trace" & vbCrLf) sb.Append("SORTTABLE=" & vbCrLf) sb.Append("LANGUAGEID=ENU" & vbCrLf) sb.Append("XLATEDLL=" & vbCrLf) sb.Append("DFTPKGLIB=QGPL" & vbCrLf) ' A vérifier : ici on peut indiquer une autre librairie ' que la librairie QGPL par défaut ' ce qui évite d'avoir à préfixer les noms de table ' par la librairie dans les requêtes, le cas échéant sb.Append("DBQ=QGPL" & vbCrLf) sb.Append("SYSTEM=" & sNomServeur & vbCrLf) ' autre poss.: Adresse IP End Select If Not bEcrireFichier(sCheminDsn, sb) Then Exit Function ' On peut ne pas avoir besoin d'un fichier de requête SQL, ' si on les crée à la volée If sCheminSQL.Length > 0 And sSQL.Length > 0 Then If bFichierExiste(sCheminSQL) Then _ If Not bRenommerFichier(sCheminSQL, sCheminSQL & ".bak") Then _ Exit Function If Not bEcrireFichier(sCheminSQL, sSQL) Then Exit Function End If If Me.m_bPrompt Then _ MsgBox("Le fichier DSN pour la source ODBC " & sTypeODBC & " : " & vbLf & _ sSource & vbLf & "a été créé avec les chemins en local :" & vbLf & _ sCheminDsn, vbExclamation, sTitreMsg) bCreerFichierDsnODBC = True End Function Public Function bVerifierCheminODBC(ByVal sChampBD$, ByVal sContenuDSN$, _ Optional ByVal bDossier As Boolean = False) As Boolean ' Vérifier la présence de la source ODBC si le fichier DSN existe déjà Dim sContenuDSNMin$ = sContenuDSN.ToLower sChampBD = sChampBD.ToLower Dim iPosDeb% = sContenuDSNMin.IndexOf(sChampBD) Dim sCheminBd$ = "" If iPosDeb > -1 Then Dim iPosFin% = sContenuDSNMin.IndexOf(vbLf, iPosDeb + sChampBD.Length) If iPosFin > -1 Then sCheminBd = sContenuDSN.Substring( _ iPosDeb + sChampBD.Length, iPosFin - 1 - iPosDeb - sChampBD.Length) Else sCheminBd = sContenuDSN.Substring(iPosDeb + sChampBD.Length) End If If sCheminBd.Length = 0 Then MsgBox("Le chemin indiqué dans le fichier DSN pour " & sChampBD & _ " est vide !", MsgBoxStyle.Critical, sTitreMsg) Exit Function End If If Not bCheminFichierProbable(sCheminBd) Then ' Si le chemin ne correspond pas à un vrai chemin ' alors ne pas chercher à vérifier la présence du fichier ' poursuivre sans erreur bVerifierCheminODBC = True Exit Function End If Dim sDebutLigneChamp$ = sContenuDSNMin.Substring( _ iPosDeb - 3, sChampBD.Length) If sDebutLigneChamp.IndexOf(";") > -1 Then ' Si le chemin indiqué est en commentaire ' alors ignorer la ligne, poursuivre sans erreur bVerifierCheminODBC = True Exit Function End If End If bVerifierCheminODBC = True If sCheminBd.Length > 0 Then If bDossier Then bVerifierCheminODBC = bDossierExiste(sCheminBd, bPrompt:=True) Else bVerifierCheminODBC = bFichierExiste(sCheminBd, bPrompt:=True) End If End If End Function Public Function sLireNomPiloteODBC$(ByVal sContenuDSN$) ' Vérifier la présence de la source ODBC si le fichier DSN existe déjà Dim sContenuDSNMin$ = sContenuDSN.ToLower Dim sChampPilote$ = "driver=" Dim iPosDeb% = sContenuDSNMin.IndexOf(sChampPilote) Dim sNomPilote$ = "" If iPosDeb > -1 Then Dim iPosFin% = sContenuDSNMin.IndexOf(vbLf, iPosDeb + sChampPilote.Length) If iPosFin > -1 Then sNomPilote = sContenuDSN.Substring( _ iPosDeb + sChampPilote.Length, iPosFin - 1 - iPosDeb - sChampPilote.Length) Else sNomPilote = sContenuDSN.Substring(iPosDeb + sChampPilote.Length) End If End If sLireNomPiloteODBC = sNomPilote End Function #End Region End Class modExcel.vb ' Gestion Excel en liaison tardive Option Strict Off Option Infer On Imports System.Text ' Pour StringBuilder Module modExcel Dim oXLH As clsHebExcel = Nothing #Region "Constantes" Public Const sMsgLancementExcel$ = "Lancement d'Excel..." Public Const sMsgPbExcel$ = "Excel n'est pas installé !" Private Const iIdxCouleurAuto% = -4105 ' xlAutomatic Private Const iIdxCoulGrise% = 56 ' Gris très clair (couleur perso) Private Const xlNone% = -4142 '(&HFFFFEFD2) Private Const iBordGauche% = 7 ' xlEdgeLeft Private Const iBordHaut% = 8 ' xlEdgeTop Private Const iBordBas% = 9 ' xlEdgeBottom Private Const iBordDroite% = 10 ' xlEdgeRight Private Const sErrExcelManip$ = "0x800A01A8" 'Private Const sMsgErr$ = "Impossible d'exporter le document sous Excel !" 'Private Const sMsgErrExcel$ = "Impossible de créer le document sous Excel !" Public Const sMsgErrCausePoss$ = _ "Cause possible : Excel est actuellement en cours d'édition d'un document" #End Region #Region "XL2Csv" 'Excel.xlCVErr Range.Value Coerced to .NET '------------- ----------- --------------- ' 2000 00 #NULL! -2146826288 ' 2007 07 #DIV/0! -2146826281 ' 2015 0F #VALUE! -2146826273 ' 2023 17 #REF! -2146826265 ' 2029 1D #NAME? -2146826259 ' 2036 24 #NUM! -2146826252 ' 2042 2A #N/A! -2146826246 Private Const sValErrNULL$ = "-2146826288" Private Const sValErrDIV0$ = "-2146826281" Private Const sValErrVALUE$ = "-2146826273" Private Const sValErrREF$ = "-2146826265" Private Const sValErrNAME$ = "-2146826259" Private Const sValErrNUM$ = "-2146826252" Private Const sValErrNA$ = "-2146826246" Private Const sErrNULL$ = "#NULL!" Private Const sErrDIV0$ = "#DIV/0!" Private Const sErrVALUE$ = "#VALUE!" Private Const sErrREF$ = "#REF!" Private Const sErrNAME$ = "#NAME?" Private Const sErrNUM$ = "#NUM!" Private Const sErrNA$ = "#N/A" ' Pas de ! pour celui-là ! Public Function bConvertirXLAutomation(ByVal sCheminFichierXL$, _ ByVal msgDelegue As clsMsgDelegue) As Boolean ' Convertir un classeur Excel en fichiers csv de manière sécurisée ' (cellule par cellule, ce qui est plus lent que par ODBC) If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Exit Function Dim sCheminDossierXL$ = IO.Path.GetDirectoryName(sCheminFichierXL) ' Optimisation : conserver la précédante instance d'Excel 'Dim oXLH As clsHebExcel Dim oWkb As Object = Nothing Dim oSht As Object = Nothing msgDelegue.m_bAnnuler = False Try Sablier() msgDelegue.AfficherMsg(sMsgLancementExcel) If IsNothing(oXLH) Then oXLH = New clsHebExcel(bInterdireAppliAvant:=False) If IsNothing(oXLH.oXL) Then msgDelegue.AfficherMsg(sMsgPbExcel) GoTo Fin End If 'oXLH.oXL.Visible = True ' Mode Debug oXLH.oXL.Visible = False msgDelegue.AfficherMsg(sMsgOuvertureClasseur) oWkb = oXLH.oXL.Workbooks.Open(sCheminFichierXL) Dim iFeuille% = 0 Dim iNbFeuilles% = oWkb.Worksheets.Count For Each oSht In oWkb.Worksheets iFeuille += 1 'Dim sPlageUt$ = oSht.UsedRange.Address.ToString 'Debug.WriteLine(oSht.Name & " : " & sPlageUt) Dim sFeuille$ = oSht.Name Dim sFeuilleDos$ = sConvNomDos(sFeuille) Dim sb As New StringBuilder Dim sbTmp2 As New StringBuilder Dim iLongUtile2% = -1 Dim iLigne% = 1 Dim iNbCol2% = oSht.UsedRange.Columns.Count Dim iNbLignes2% = oSht.UsedRange.Rows.Count ' Il faut plutot rechercher l'indice max. ' car si la 1ère ligne est vide on va manquer une ligne à la fin ' (pour les colonnes, pas de pb à priori) Dim sPlage$ = oSht.UsedRange.Address.ToString.Replace("$", "") 'Dim iColMin% = iColPlage(sPlage) 'Dim iLigneMin% = iLignePlage(sPlage) 'iNbCol += iColMin - 1 'iNbLignes += iLigneMin - 1 Dim iNbCol% = iColFinPlage(sPlage) Dim iNbLignes% = iLigneFinPlage(sPlage) ' Mais parfois, la plage n'indique pas les colonnes, seulement les lignes ! ' on prend le max. dans ce cas If iNbCol < iNbCol2 Then iNbCol = iNbCol2 If iNbLignes < iNbLignes2 Then iNbLignes = iNbLignes2 ' N'existent pas : 'Dim iNbCol2% = oSht.Cells.LastColIndex + 1 'Dim iNbLignes2% = oSht.Cells.LastRowIndex + 1 Dim bAuMoinsUneVal As Boolean = False 'For Each oRow As Object In oSht.UsedRange.Rows ' Toujours partir de 0, et non depuis le début utilisé (+ stable) For i As Integer = 0 To iNbLignes - 1 If iLigne = 1 Or iLigne = iNbLignes Or iLigne Mod 10 = 0 Then msgDelegue.AfficherMsg( _ "Feuille n°" & iFeuille & "/" & iNbFeuilles & _ " : Ligne n°" & iLigne & "/" & iNbLignes & _ " : Lecture en cours...") If msgDelegue.m_bAnnuler Then Exit Function End If Dim sbTmp As New StringBuilder Dim bAuMoinsUneValLigne As Boolean = False Dim iLongUtile% = -1 Dim iCol% = 1 'For Each oCol As Object In oSht.UsedRange.Columns For j As Integer = 0 To iNbCol - 1 Dim oVal As Object = oSht.Cells(iLigne, iCol).Value Dim sVal$ = "" If IsNothing(oVal) Then GoTo ColonneSuivante ' Note : Si la cellule est au format monétaire, ' alors la précision lue ici est tronquée à 4 décimales ' (ce qui n'est pas le cas via ExcelLibrary : ' le format monétaire ne peut être détecté qu'en analysant ' le format d'affichage, car le type est System.Double) ' Note : La méthode "Enregistrer sous csv" d'Excel ' tient compte du format : pas ici sVal = oVal.ToString Dim bVal As Boolean = False If sVal.Length > 0 Then bAuMoinsUneValLigne = True : bAuMoinsUneVal = True bVal = True If String.Compare(sVal, sValErrNULL) = 0 Then sVal = sErrNULL ElseIf String.Compare(sVal, sValErrDIV0) = 0 Then sVal = sErrDIV0 ElseIf String.Compare(sVal, sValErrVALUE) = 0 Then sVal = sErrVALUE ElseIf String.Compare(sVal, sValErrREF) = 0 Then sVal = sErrREF ElseIf String.Compare(sVal, sValErrNAME) = 0 Then sVal = sErrNAME ElseIf String.Compare(sVal, sValErrNUM) = 0 Then sVal = sErrNUM ElseIf String.Compare(sVal, sValErrNA) = 0 Then sVal = sErrNA Else Dim sType = oVal.GetType().Name If sType = "Decimal" Then Dim oDec As System.Decimal = CDec(oVal) sVal = sFormaterNumeriqueDec(oDec, _ iNbDecimales:=iNbDecimalesDef, _ sSeparateurMilliers:=sSeparateurMilliersDef) 'Dim oDbl As Double = CDbl(oDec) 'sVal = sFormaterNumeriqueDble(oDbl, sSeparateurMilliers:="") ElseIf sType = "Double" Then Dim oDbl As Double = CDbl(oVal) sVal = sFormaterNumeriqueDble(oDbl, _ iNbDecimales:=iNbDecimalesDef, _ sSeparateurMilliers:=sSeparateurMilliersDef) ElseIf sType = "DateTime" Then If sVal.EndsWith(sHeureVide) Then sVal = Left$(sVal, sVal.Length - sHeureVide.Length) End If End If ' Si réel alors appliquer le format 'oSht.Cells(iLigne, iCol).Select() 'Dim sFormat$ = oXLH.oXL.Selection.NumberFormat() 'Dim sAddresse$ = oSht.Cells(iLigne, iCol).Address 'Dim sFormat$ = oXLH.oXL.Range(sAddresse).NumberFormat() 'Dim oDec As System.Decimal = CDec(oVal) 'sVal = oDec.ToString(sFormat) 'Dim oDbl As Double = CDbl(oDec) 'sVal = sFormaterNumeriqueDble(oDbl) End If End If sbTmp.Append(sVal) If bVal Then iLongUtile = sbTmp.Length ColonneSuivante: 'Debug.WriteLine("L" & iLigne & "C" & iCol & " : " & sVal) If iCol < iNbCol Then sbTmp.Append(";") iCol += 1 Next If bAuMoinsUneValLigne Then ' Retirer les ; à la fin sbTmp.Length = iLongUtile sbTmp2.Append(sbTmp) iLongUtile2 = sbTmp2.Length End If sbTmp2.Append(vbCrLf) iLigne += 1 Next If Not bAuMoinsUneVal Then Continue For Dim sChemin$ = sCheminDossierXL & "\" & sFeuilleDos & ".csv" ' Limiter le sb à la taille utile (supprimer les lignes vides à la fin) sb.Append(sbTmp2) sb.Length = iLongUtile2 + 2 ' +2 pour vbCrLf If Not bEcrireFichier(sChemin, sb) Then Exit Function Next bConvertirXLAutomation = True Dim sInfo$ = "Le classeur :" & vbCrLf & sCheminFichierXL & vbCrLf & _ "a été converti en fichiers csv avec succès ! (via automation)" MsgBox(sInfo, MsgBoxStyle.Information, sTitreMsg) Catch ex As Exception AfficherMsgErreur2(ex, "bConvertirXLAutomation", _ "Impossible de lire le document :" & vbLf & _ sCheminFichierXL, sMsgErrCausePoss) Finally msgDelegue.AfficherMsg(sMsgFermetureClasseur) ' Option : Ne pas libérer l'instance, si elle n'appartient pas à cette fct 'oXLH.Fermer(oSht, oWkb, bQuitter:=False, bLibererXLSiResteOuvert:=False) 'oXLH.Quitter() oXLH.Fermer(oSht, oWkb, bQuitter:=True) msgDelegue.AfficherMsg("") Sablier(bDesactiver:=True) End Try msgDelegue.AfficherMsg(sMsgLectureTerminee) Fin: 'Sablier(bDesactiver:=True) End Function #End Region #Region "Utilitaires" ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Function bFeuilleExiste(ByVal sFeuille$, ByVal oWkb As Object) As Boolean On Error Resume Next bFeuilleExiste = CBool(Len(oWkb.Worksheets(sFeuille).Name) > 0) End Function Public Function bLireCellulesXLAutomation(ByVal sCheminFichierXL$, _ ByVal sListeCellules$, ByRef aoValeurs() As Object, _ ByVal msgDelegue As clsMsgDelegue, _ Optional ByVal bQuitter As Boolean = True) As Boolean ' Lire des cellules dans un classeur Excel de manière sécurisée (non ODBC) ' et retourner un tableau de valeurs If Not bFichierExiste(sCheminFichierXL, bPrompt:=True) Then Exit Function If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Exit Function Dim sCheminDossierXL$ = IO.Path.GetDirectoryName(sCheminFichierXL) ' Optimisation : conserver la précédante instance d'Excel 'Dim oXLH As clsHebExcel Dim oWkb As Object = Nothing Dim oSht As Object = Nothing msgDelegue.m_bAnnuler = False Try Sablier() msgDelegue.AfficherMsg(sMsgLancementExcel) If IsNothing(oXLH) Then oXLH = New clsHebExcel(bInterdireAppliAvant:=False) If IsNothing(oXLH.oXL) Then msgDelegue.AfficherMsg(sMsgPbExcel) GoTo Fin End If 'oXLH.oXL.Visible = True ' Mode Debug oXLH.oXL.Visible = False msgDelegue.AfficherMsg("Ouverture du classeur...") oWkb = oXLH.oXL.Workbooks.Open(sCheminFichierXL) Dim asPlages$() = sListeCellules.Split(";"c) Dim iNbValeurs% = asPlages.GetUpperBound(0) ReDim aoValeurs(0 To iNbValeurs) Dim iNumValeur% = 0 For Each sFeuillePlage As String In asPlages If String.IsNullOrEmpty(sFeuillePlage) Then Exit For Dim asChamps$() = sFeuillePlage.Split("!"c) Dim sFeuille$ = asChamps(0) Dim sPlage$ = asChamps(1) Dim iCol% = iColPlage(sPlage) Dim iLigne% = iLignePlage(sPlage) Dim oVal As Object = oWkb.Worksheets(sFeuille).Cells(iLigne, iCol).Value aoValeurs(iNumValeur) = oVal iNumValeur += 1 Next bLireCellulesXLAutomation = True Catch ex As Exception AfficherMsgErreur2(ex, "bLireCellulesXLAutomation", _ "Impossible de lire le classeur :" & vbLf & _ sCheminFichierXL, sMsgErrCausePoss) Finally msgDelegue.AfficherMsg(sMsgFermetureClasseur) ' Option : Ne pas libérer l'instance, si elle n'appartient pas à cette fct 'oXLH.Fermer(oSht, oWkb, bQuitter:=False, bLibererXLSiResteOuvert:=False) 'oXLH.Quitter() oXLH.Fermer(oSht, oWkb, bQuitter, bLibererXLSiResteOuvert:=bQuitter) If bQuitter Then oXLH = Nothing : LibererRessourceDotNet() msgDelegue.AfficherMsg("") End Try msgDelegue.AfficherMsg("Lecture terminée.") Fin: Sablier(bDesactiver:=True) End Function Public Function bLireCellulesXLCouleurs(ByVal sCheminFichierXL$, _ ByVal sListeCellules$, ByRef aiIdxCouleurs%(), _ ByVal msgDelegue As clsMsgDelegue, _ Optional ByVal bQuitter As Boolean = True) As Boolean ' Lire la couleur des cellules dans un classeur Excel ' et retourner un tableau de valeurs If Not bFichierExiste(sCheminFichierXL, bPrompt:=True) Then Exit Function If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Exit Function Dim sCheminDossierXL$ = IO.Path.GetDirectoryName(sCheminFichierXL) ' Optimisation : conserver la précédante instance d'Excel 'Dim oXLH As clsHebExcel Dim oWkb As Object = Nothing Dim oSht As Object = Nothing msgDelegue.m_bAnnuler = False Try Sablier() msgDelegue.AfficherMsg(sMsgLancementExcel) If IsNothing(oXLH) Then oXLH = New clsHebExcel(bInterdireAppliAvant:=False) If IsNothing(oXLH.oXL) Then msgDelegue.AfficherMsg(sMsgPbExcel) GoTo Fin End If 'oXLH.oXL.Visible = True ' Mode Debug oXLH.oXL.Visible = False msgDelegue.AfficherMsg("Ouverture du classeur...") oWkb = oXLH.oXL.Workbooks.Open(sCheminFichierXL) Dim asPlages$() = sListeCellules.Split(";"c) Dim iNbValeurs% = asPlages.GetUpperBound(0) ReDim aiIdxCouleurs(0 To iNbValeurs) Dim iNumValeur% = 0 For Each sFeuillePlage As String In asPlages If String.IsNullOrEmpty(sFeuillePlage) Then Exit For Dim asChamps$() = sFeuillePlage.Split("!"c) Dim sFeuille$ = asChamps(0) Dim sPlage$ = asChamps(1) Dim iCol% = iColPlage(sPlage) Dim iLigne% = iLignePlage(sPlage) aiIdxCouleurs(iNumValeur) = oWkb.Worksheets(sFeuille). _ Cells(iLigne, iCol).Interior.ColorIndex iNumValeur += 1 Next bLireCellulesXLCouleurs = True Catch ex As Exception AfficherMsgErreur2(ex, "bLireCellulesXLCouleurs", _ "Impossible de lire le classeur :" & vbLf & _ sCheminFichierXL, sMsgErrCausePoss) Finally msgDelegue.AfficherMsg(sMsgFermetureClasseur) ' Option : Ne pas libérer l'instance, si elle n'appartient pas à cette fct 'oXLH.Fermer(oSht, oWkb, bQuitter:=False, bLibererXLSiResteOuvert:=False) 'oXLH.Quitter() oXLH.Fermer(oSht, oWkb, bQuitter, bLibererXLSiResteOuvert:=bQuitter) If bQuitter Then oXLH = Nothing : LibererRessourceDotNet() msgDelegue.AfficherMsg("") End Try msgDelegue.AfficherMsg("Lecture terminée.") Fin: Sablier(bDesactiver:=True) End Function Public Function iColPlage%(ByVal sPlage$, Optional ByVal iNumChamp% = 0) ' Renvoyer la première colonne d'une plage ' Voir aussi : iConvLettresEnNum If sPlage.Length = 0 Then Exit Function Dim asTab$() = sPlage.Split(":"c) Dim sDeb$ = "" If iNumChamp > asTab.GetUpperBound(0) Then ' Si la plage est par exemple A1 alors C=1 et L=1 sDeb = asTab(0) GoTo Suite End If sDeb = asTab(iNumChamp) Suite: Dim iValA% = Asc("A") ' 65 ' Si la plage ne définie que les colonnes, il n'y a qu'un caractère If sDeb.Length = 1 Then Dim sCol$ = sDeb.Chars(0) iColPlage = 1 + Asc(sCol.Chars(0)) - iValA Exit Function End If iColPlage = 1 'Dim sCar2Deb$ = sDeb.Chars(1) 'If IsNumeric(sCar2Deb) Then If Char.IsNumber(sDeb.Chars(1)) Then ' Soit le début de la plage est du type A9 ou A99 Dim sCol$ = sDeb.Chars(0) iColPlage = 1 + Asc(sCol.Chars(0)) - iValA Else ' Soit le début de la plage est du type AA9 ou AA99 Dim sCol$ = sDeb.Substring(0, 2) iColPlage = 26 * (1 + Asc(sCol.Chars(0)) - iValA) + 1 + Asc(sCol.Chars(1)) - iValA End If End Function Public Function iLignePlage%(ByVal sPlage$, Optional ByVal iNumChamp% = 0) ' Renvoyer la première ligne d'une plage If sPlage.Length = 0 Then Exit Function Dim asTab$() = sPlage.Split(":"c) Dim sDeb$ = "" If iNumChamp > asTab.GetUpperBound(0) Then ' Si la plage est par exemple A1 alors C=1 et L=1 sDeb = asTab(0) GoTo Suite End If sDeb = asTab(iNumChamp) ' Si la plage ne définie que les colonnes, il n'y a qu'un caractère If sDeb.Length = 1 Then If iNumChamp = 0 Then iLignePlage = 1 ' La première ligne est donc 1 ElseIf iNumChamp = 1 Then iLignePlage = 65535 ' Renvoyer la dernière ligne dans ce cas End If Exit Function End If Suite: iLignePlage = 1 'Dim sCar2Deb$ = sDeb.Chars(1) 'If IsNumeric(sCar2Deb) Then If Char.IsNumber(sDeb.Chars(1)) Then ' Soit le début de la plage est du type A9 ou A99 Dim sLigne$ = sDeb.Substring(1) iLignePlage = CInt(sLigne) Else ' Soit le début de la plage est du type AA9 ou AA99 Dim sLigne$ = sDeb.Substring(2) iLignePlage = CInt(sLigne) End If End Function Public Function iColFinPlage%(ByVal sPlage$) ' Renvoyer la dernière colonne d'une plage iColFinPlage = iColPlage(sPlage, iNumChamp:=1) End Function Public Function iLigneFinPlage%(ByVal sPlage$) ' Renvoyer la dernière ligne d'une plage iLigneFinPlage = iLignePlage(sPlage, iNumChamp:=1) End Function Public Function sConvNumEnLettres$(ByVal iCol%) Dim iValA% = Asc("A") ' 65 If iCol <= 26 Then sConvNumEnLettres = Chr(iValA + iCol - 1) Else ' Corrigé le 23/06/2010 Dim iMult26% = (iCol - 1) \ 26 ' CInt(iCol / 26) Dim iReste% = (iCol - 1) Mod 26 ' iCol - iMult26 * 26 sConvNumEnLettres = Chr(iValA + iMult26 - 1) & Chr(iValA + iReste) End If End Function #End Region End Module modExcelRapide.vb ' Gestion Excel via ExcelLibrary ' http://code.google.com/p/excellibrary/ ' http://www.codeproject.com/KB/office/ExcelReader.aspx ' La dll ExcelLibrary.dll a été modifiée ' pour la correction de #N/A au lieu de #N/A! : ' AddErrorCode(0x2A, "#N/A"); // Pas de ! pour celui-là ! Imports ExcelLibrary ' Pour BinaryFileFormat 'Imports ExcelLibrary.BinaryDrawingFormat Imports ExcelLibrary.BinaryFileFormat ' Pour WorkbookDecoder Imports ExcelLibrary.CompoundDocumentFormat ' Pour CompoundDocument Imports ExcelLibrary.SpreadSheet ' Pour Workbook 'Imports QiHe.CodeLib Imports System.IO ' Pour MemoryStream Imports System.Text ' Pour StringBuilder Module modExcelRapide Public Const dDateNulle As Date = #12:00:00 AM# #Region "XL2Csv" Public Function bConvertirXLRapide(ByVal sCheminFichierXL$, _ ByVal msgDelegue As clsMsgDelegue) As Boolean ' Convertir un classeur Excel en fichiers csv de manière sécurisée (non ODBC) ' (cellule par cellule) et rapide, sans Excel, via ExcelLibrary If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Exit Function Dim sCheminDossierXL$ = IO.Path.GetDirectoryName(sCheminFichierXL) Dim doc As CompoundDocument = Nothing Dim iNbFichiersCsvGeneres% = 0 Dim sDernierCheminCsv$ = "" Try Sablier() msgDelegue.AfficherMsg(sMsgOuvertureClasseur) doc = CompoundDocument.Open(sCheminFichierXL) Dim streamData As Byte() = doc.GetStreamData("Workbook") If IsNothing(streamData) Then Exit Function Dim workbook0 As Workbook = WorkbookDecoder.Decode(New MemoryStream(streamData)) Dim iFeuille% = 0 Dim iNbFeuilles% = workbook0.Worksheets.Count Dim worksheet0 As Worksheet For Each worksheet0 In workbook0.Worksheets iFeuille += 1 Dim bAuMoinsUneVal As Boolean = False Dim sb As New StringBuilder Dim sbTmp2 As New StringBuilder Dim iLongUtile2% = -1 Dim sFeuille$ = worksheet0.Name Dim sFeuilleDos$ = sConvNomDos(sFeuille) ' Excel en csv ignore la 1ère ligne, mais ici on va la garder : + stable Dim i% = 0 'worksheet.Cells.FirstRowIndex Dim iNbCol% = worksheet0.Cells.LastColIndex + 1 Dim iNbLignes% = worksheet0.Cells.LastRowIndex Dim j% Do While (i <= iNbLignes) If i = 1 Or i = iNbLignes Or i Mod 1000 = 0 Then msgDelegue.AfficherMsg( _ "Feuille n°" & iFeuille & "/" & iNbFeuilles & _ " : Ligne n°" & i & "/" & iNbLignes & _ " : Lecture en cours...") If msgDelegue.m_bAnnuler Then Exit Function End If Dim row0 As ExcelLibrary.SpreadSheet.Row = worksheet0.Cells.GetRow(i) Dim iColMin% = row0.FirstColIndex If iColMin = Integer.MaxValue Then GoTo FinLigne Dim iColMax% = row0.LastColIndex ' Inférieur à 0 signifie ligne vide : Integer.MinValue If iColMax < 0 Then GoTo FinLigne ' D'abord trouver la dernière cellule existante de la ligne Dim bLigneVide As Boolean = True Dim iColMaxLigne% = iColMax For j = iNbCol - 1 To iColMin Step -1 Dim cell0 As Cell = row0.GetCell(j) If IsNothing(cell0) Then Continue For iColMaxLigne = j bLigneVide = False Exit For Next ' Si la ligne est vide, ne rien mettre If bLigneVide Then GoTo FinLigne Dim bAuMoinsUneValLigne As Boolean = False Dim iLongUtile% = -1 Dim sbTmp As New StringBuilder j = 0 Do While j <= iColMaxLigne If j < iColMin Then GoTo Suite Dim cell0 As Cell = row0.GetCell(j) If IsNothing(cell0) Then GoTo Suite If IsNothing(cell0.Value) Then GoTo Suite Dim sVal$ = sLireValCelluleExcelLibrary(cell0) sbTmp.Append(sVal) If sVal.Length > 0 Then bAuMoinsUneVal = True bAuMoinsUneValLigne = True iLongUtile = sbTmp.Length End If Suite: If j < iNbCol - 1 Then sbTmp.Append(";") j += 1 Loop If bAuMoinsUneValLigne Then ' Retirer les ; à la fin sbTmp.Length = iLongUtile sbTmp2.Append(sbTmp) iLongUtile2 = sbTmp2.Length End If FinLigne: i += 1 sbTmp2.Append(vbCrLf) Loop If Not bAuMoinsUneVal Then Continue For Dim sChemin$ = sCheminDossierXL & "\" & sFeuilleDos & ".csv" ' Limiter le sb à la taille utile (supprimer les lignes vides à la fin) sb.Append(sbTmp2) sb.Length = iLongUtile2 + 2 ' +2 pour vbCrLf If Not bEcrireFichier(sChemin, sb) Then Exit Function iNbFichiersCsvGeneres += 1 sDernierCheminCsv = sChemin Next bConvertirXLRapide = True 'msgDelegue.AfficherMsg(sMsgLectureTerminee) msgDelegue.AfficherMsg(sMsgOperationTerminee) If iNbFichiersCsvGeneres = 1 Then Dim sInfo$ = "(via le composant ExcelLibrary)" ProposerOuvrirFichier(sDernierCheminCsv, sInfo) Else Dim sInfo$ = "Le classeur :" & vbCrLf & sCheminFichierXL & vbCrLf & _ "a été converti en fichiers csv avec succès !" & vbCrLf & _ "(via le composant ExcelLibrary)" MsgBox(sInfo, MsgBoxStyle.Information, sTitreMsg) End If Catch ex As Exception AfficherMsgErreur2(ex, "bConvertirXLRapide", _ "Impossible de lire le document :" & vbLf & _ sCheminFichierXL) Finally If Not IsNothing(doc) Then doc.Close() Sablier(bDesactiver:=True) End Try msgDelegue.AfficherMsg(sMsgOperationTerminee) End Function Public Function bConvertirXL2Txt(ByVal sCheminFichierXL$, _ ByVal msgDelegue As clsMsgDelegue) As Boolean ' Convertir un classeur Excel en un fichier texte de manière sécurisée (non ODBC) ' (cellule par cellule) et rapide, sans Excel, via ExcelLibrary ' En fait on n'a pas besoin de préfixer par le nom de la feuille ' car on peut utiliser le chapitrage dans VBTextFinder ' pour rappeler où on se trouve dans le classeur ' (si on l'active ce préfixage, reste à supprimer les lignes vides à la fin) Const bPrefixerParNomFeuille As Boolean = False If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Exit Function Dim sCheminDossierXL$ = IO.Path.GetDirectoryName(sCheminFichierXL) Dim doc As CompoundDocument = Nothing Try Sablier() msgDelegue.AfficherMsg(sMsgOuvertureClasseur) doc = CompoundDocument.Open(sCheminFichierXL) Dim streamData As Byte() = doc.GetStreamData("Workbook") If IsNothing(streamData) Then Exit Function Dim workbook0 As Workbook = WorkbookDecoder.Decode(New MemoryStream(streamData)) Dim iFeuille% = 0 Dim iNbFeuilles% = workbook0.Worksheets.Count Dim worksheet0 As Worksheet Dim sb As New StringBuilder 'Dim sbInfo As New StringBuilder sb.Append("Fichier source : " & sCheminFichierXL & vbCrLf) Dim fi As New IO.FileInfo(sCheminFichierXL) Dim lTailleFichier& = fi.Length Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier) Dim sTailleFichierDetail$ = sFormaterTailleOctets(lTailleFichier, bDetail:=True) ' Attention à l'heure de la date : l'explorateur de Windows XP ' enlève 1 heure si l'on est passé à l'heure d'hiver depuis la date à afficher ' c'est n'importe quoi ! ' Heureusement fi.LastWriteTime affiche toujours la bonne heure (et la même heure) sb.Append("Taille : " & sTailleFichierDetail & _ ", Date : " & fi.LastWriteTime & vbCrLf) ' & vbCrLf) Dim bAuMoinsUneValClasseur As Boolean = False For Each worksheet0 In workbook0.Worksheets iFeuille += 1 Dim bAuMoinsUneVal As Boolean = False Dim sbTmp2 As New StringBuilder Dim iLongUtile2% = -1 Dim sFeuille$ = worksheet0.Name 'Dim sFeuilleDos$ = sConvNomDos(sFeuille) ' Excel en csv ignore la 1ère ligne, mais ici on va la garder : + stable Dim i% = 0 'worksheet.Cells.FirstRowIndex Dim iNbCol% = worksheet0.Cells.LastColIndex + 1 Dim iNbLignes% = worksheet0.Cells.LastRowIndex 'Dim sNomTable$ = sFeuille sb.Append(vbCrLf & vbCrLf & _ "Feuille Excel n°" & iFeuille & " : " & sFeuille & vbCrLf & _ "-------------" & vbCrLf) Dim j% Do While (i <= iNbLignes) If i = 1 Or i = iNbLignes Or i Mod 1000 = 0 Then msgDelegue.AfficherMsg( _ "Feuille n°" & iFeuille & "/" & iNbFeuilles & _ " : Ligne n°" & i & "/" & iNbLignes & _ " : Lecture en cours...") If msgDelegue.m_bAnnuler Then Exit Function End If Dim row0 As ExcelLibrary.SpreadSheet.Row = worksheet0.Cells.GetRow(i) Dim iColMin% = row0.FirstColIndex If iColMin = Integer.MaxValue Then GoTo LigneVide Dim iColMax% = row0.LastColIndex ' Inférieur à 0 signifie ligne vide : Integer.MinValue If iColMax < 0 Then GoTo LigneVide ' D'abord trouver la dernière cellule existante de la ligne Dim bLigneVide As Boolean = True Dim iColMaxLigne% = iColMax For j = iNbCol - 1 To iColMin Step -1 Dim cell0 As Cell = row0.GetCell(j) If IsNothing(cell0) Then Continue For iColMaxLigne = j bLigneVide = False Exit For Next ' Si la ligne est vide, ne rien mettre If bLigneVide Then GoTo LigneVide Dim bAuMoinsUneValLigne As Boolean = False Dim iLongUtile% = -1 Dim sbTmp As New StringBuilder If bPrefixerParNomFeuille Then sbTmp.Append(sFeuille & ";") j = 0 Do While j <= iColMaxLigne If j < iColMin Then GoTo Suite Dim cell0 As Cell = row0.GetCell(j) If IsNothing(cell0) Then GoTo Suite If IsNothing(cell0.Value) Then GoTo Suite Dim sVal$ = sLireValCelluleExcelLibrary(cell0) sbTmp.Append(sVal) If sVal.Length > 0 Then bAuMoinsUneVal = True bAuMoinsUneValLigne = True iLongUtile = sbTmp.Length End If Suite: If j < iNbCol - 1 Then sbTmp.Append(";") j += 1 Loop If bAuMoinsUneValLigne Then ' Retirer les ; à la fin sbTmp.Length = iLongUtile sbTmp2.Append(sbTmp) iLongUtile2 = sbTmp2.Length Else GoTo LigneVide End If sbTmp2.Append(vbCrLf) GoTo LigneSuivante LigneVide: ' Afficher seulement le nom de la feuille Excel If bPrefixerParNomFeuille Then sbTmp2.Append(sFeuille) iLongUtile2 = sbTmp2.Length End If sbTmp2.Append(vbCrLf) LigneSuivante: i += 1 Loop If Not bAuMoinsUneVal Then Continue For 'Dim sChemin$ = sCheminDossierXL & "\" & sFeuilleDos & ".csv" ' Limiter le sb à la taille utile (supprimer les lignes vides à la fin) sbTmp2.Length = iLongUtile2 + 2 ' +2 pour vbCrLf sb.Append(sbTmp2) 'sb.Length = iLongUtile2 + 2 ' +2 pour vbCrLf 'If Not bEcrireFichier(sChemin, sb) Then Exit Function bAuMoinsUneValClasseur = True Next 'msgDelegue.AfficherMsg(sMsgLectureTerminee) msgDelegue.AfficherMsg(sMsgOperationTerminee) If Not bAuMoinsUneValClasseur Then Dim sInfo$ = "Le classeur est vide !" & vbCrLf & sCheminFichierXL MsgBox(sInfo, MsgBoxStyle.Information, sTitreMsg) Else Dim sChemin$ = sCheminDossierXL & "\" & _ IO.Path.GetFileNameWithoutExtension(sCheminFichierXL) & ".txt" If Not bEcrireFichier(sChemin, sb) Then Exit Function 'Dim sInfo$ = "Le classeur :" & vbCrLf & sCheminFichierXL & vbCrLf & _ ' "a été converti en fichier texte avec succès !" & vbCrLf & _ ' "(via le composant ExcelLibrary)" Dim sInfo$ = "(via le composant ExcelLibrary)" ProposerOuvrirFichier(sChemin, sInfo) End If bConvertirXL2Txt = True Catch ex As Exception AfficherMsgErreur2(ex, "bConvertirXL2Txt", _ "Impossible de lire le document :" & vbLf & _ sCheminFichierXL) Finally If Not IsNothing(doc) Then doc.Close() Sablier(bDesactiver:=True) End Try msgDelegue.AfficherMsg(sMsgOperationTerminee) End Function #End Region End Module modUtil.vb ' Fichier modUtil.vb ' ------------------ 'Imports System.Text ' Pour StringBuilder Module modUtil 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 Sablier(Optional ByRef bDesactiver As Boolean = False) If bDesactiver Then Cursor.Current = Cursors.Default Else Cursor.Current = Cursors.WaitCursor End If 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 Public Sub LibererRessourceDotNet() ' 19/01/2011 Il faut appeler 2x : ' cf. All-In-One Code Framework\Visual Studio 2008\VBAutomateWord ' Clean up the unmanaged Word COM resources by forcing a garbage ' collection as soon as the calling function is off the stack (at ' which point these objects are no longer rooted). GC.Collect() GC.WaitForPendingFinalizers() ' GC needs to be called twice in order to get the Finalizers called ' - the first time in, it simply makes a list of what is to be ' finalized, the second time in, it actually the finalizing. Only ' then will the object do its automatic ReleaseComObject. GC.Collect() GC.WaitForPendingFinalizers() TraiterMsgSysteme_DoEvents() End Sub Public Function bFichierAccessibleMultiTest(ByVal sChemin$, _ ByVal msgDelegue As clsMsgDelegue, _ Optional ByVal iDelaiMSec% = 2000, _ Optional ByVal iNbTentatives% = 3, _ Optional ByVal bEcriture As Boolean = True) As Boolean ' Voir si un fichier est accessible (en simple lecture) avec plusieurs tentatives ' dans le cas de partage multi-utilisateur (on suppose que le vérrouillage ' ne dure pas lontemps) ' 1ère tentative sans message Retenter: If Not bFichierAccessible(sChemin, bInexistOk:=True, bEcriture:=bEcriture) Then Dim bOk As Boolean = False ' Tentatives suivantes avec message For i As Integer = 1 To iNbTentatives msgDelegue.AfficherMsg("Tentative n°" & i & _ " de lecture du fichier : " & sChemin) Attendre(iDelaiMSec) bOk = bFichierAccessible(sChemin) If bOk Then Exit For Next If Not bOk Then Dim sMsg$ = "Le fichier n'est pas accessible en lecture :" If bEcriture Then sMsg = "Le fichier n'est accessible en écriture :" msgDelegue.AfficherMsg(sMsg & " " & sChemin) Dim sInfo$ = "" If IO.Path.GetExtension(sChemin).ToLower = ".xls" Then sInfo = "(le classeur est probablement ouvert avec Excel)" & vbCrLf End If If MsgBoxResult.Retry = MsgBox(sMsg & vbCrLf & sChemin & vbCrLf & sInfo & _ "Voulez-vous réessayer ?", _ MsgBoxStyle.Exclamation Or MsgBoxStyle.RetryCancel, sTitreMsg) Then GoTo Retenter End If Exit Function End If End If bFichierAccessibleMultiTest = True End Function Public Sub Attendre(ByVal iDelaiMSec%) 'TraiterMsgSysteme_DoEvents() Threading.Thread.Sleep(iDelaiMSec) End Sub 'Public Sub CompteARebours(ByVal iDelaiSec%, ByVal sMsg$, _ ' ByVal msgDelegue As clsMsgDelegue) ' For i As Integer = iDelaiSec To 1 Step -1 ' msgDelegue.AfficherMsg(sMsg & " : " & i & "...") ' 'Attendre(1000) ' For j As Integer = 1 To 10 ' Attendre(100) ' TraiterMsgSysteme_DoEvents() ' If glb.bAnnuler Then Exit For ' Next ' If glb.bAnnuler Then Exit For ' Next ' msgDelegue.AfficherMsg(sMsg & " : " & 0 & ".") 'End Sub 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 iConv%(ByVal sVal$, Optional ByVal iValDef% = 0) If sVal.Length = 0 Then iConv = iValDef : Exit Function Try iConv = CInt(sVal) Catch iConv = iValDef End Try End Function 'Public Function lConv&(ByVal sVal$, Optional ByVal lValDef& = 0) ' If sVal.Length = 0 Then lConv = lValDef : Exit Function ' Try ' lConv = CLng(sVal) ' Catch ' lConv = lValDef ' End Try 'End Function End Module modUtilExcel.vb Imports System.Text ' Pour StringBuilder Module modUtilExcel 'Public Const sMsgOuvertureModele$ = "Ouverture du fichier modèle..." Public Const sMsgOuvertureClasseur$ = "Ouverture du classeur..." Public Const sMsgFermetureClasseur$ = "Fermeture du classeur..." Public Const sMsgLectureTerminee$ = "Lecture terminée." Public Const sMsgOperationTerminee$ = "Opération terminée." ' Créer des fichiers csv stables : fixer le format des dates Public Const sFormatDateFixe$ = "dd\/MM\/yyyy" ' Afficher toujours l'heure : si elle est vide, on la supprimera ' (\/ pour fixer le / et \: pour fixer le :, sinon dépend du format régional) Public Const sFormatDateHeureFixe$ = "dd\/MM\/yyyy HH\:mm\:ss" Public Const sHeureVide$ = " 00:00:00" Public Const sSeparateurMilliersDef$ = "" ' Ne pas séparer les milliers dans les csv Public Const iNbDecimalesMax% = -1 ' Précision maximale, par convention Public Const iNbDecimalesDef% = iNbDecimalesMax ' Précision maximale, par convention Public Function sFormaterNumeriqueDble$(ByVal rVal As Double, _ Optional ByVal bSupprimerPt0 As Boolean = True, _ Optional ByVal iNbDecimales% = 1, _ Optional ByVal sSeparateurMilliers$ = " ") ' 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 = sSeparateurMilliers ' 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} If iNbDecimales >= 0 Then nfi.NumberDecimalDigits = iNbDecimales ' 1 décimale de précision ElseIf iNbDecimales = iNbDecimalesMax Then ' Même si 17 chiffres maximum sont gérés en interne, la précision de la valeur ' Double ne comporte par défaut que 15 chiffres décimaux. ' http://msdn.microsoft.com/fr-fr/library/system.double.aspx nfi.NumberDecimalDigits = 15 End If sFormaterNumeriqueDble = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = iNbDecimalesMax Then ' Précision maximale If sSeparateurMilliers.Length = 0 Then ' S'il n'y a pas de séparateur de millier, juste forcer . décimal Dim sVal$ = rVal.ToString ' Le .0 est déjà automatiquement supprimé dans ce cas sVal = sValeurPtDecimal(sVal) ' Il reste juste à forcer le . décimal sFormaterNumeriqueDble = sVal Else ' Sinon reprendre le format séparé et traiter les chiffres Dim sVal$ = sFormaterNumeriqueDble 'Dim sValOrig$ = sVal ' Déjà pris en charge par le format "n" 'sVal = sValeurPtDecimal(sVal) ' Forcer le . décimal Dim iPosPt% = sVal.IndexOf(".") If iPosPt > -1 Then Dim iLong% = sVal.Length Dim i% ' Enlever les 0 à la fin seulement (non significatifs) For i = iLong To iPosPt Step -1 Dim cChiffre As Char = sVal.Chars(i - 1) If cChiffre <> "0" Then Exit For Next If i < iLong Then If i = iPosPt + 1 Then i = iPosPt sVal = sVal.Substring(0, i) sFormaterNumeriqueDble = sVal End If End If 'Debug.WriteLine(sValOrig & " -> " & sVal) End If ElseIf iNbDecimales = 1 Then sFormaterNumeriqueDble = sFormaterNumeriqueDble.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormaterNumeriqueDble = sFormaterNumeriqueDble.Replace(sb.ToString, "") End If End If End Function Public Function sFormaterNumeriqueDec$(ByVal rVal As Decimal, _ Optional ByVal bSupprimerPt0 As Boolean = True, _ Optional ByVal iNbDecimales% = 1, _ Optional ByVal sSeparateurMilliers$ = " ") ' Formater un numérique avec une précision d'une décimale ' Dble -> Dec n'est pas autorisé ' Dec -> Dble est autorisé : donc dble est le + général Dim oDbl As Double = CDbl(rVal) sFormaterNumeriqueDec = sFormaterNumeriqueDble(oDbl, _ bSupprimerPt0, iNbDecimales, sSeparateurMilliers) ' 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 = sSeparateurMilliers ' 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 = iNbDecimales ' 1 décimale de précision 'sFormaterNumeriqueDec = rVal.ToString("n", nfi) ' n : numérique général '' Enlever la décimale si 0 'If bSupprimerPt0 Then ' If iNbDecimales = 1 Then ' sFormaterNumeriqueDec = sFormaterNumeriqueDec.Replace(".0", "") ' ElseIf iNbDecimales > 1 Then ' Dim i% ' Dim sb As New StringBuilder(".") ' For i = 1 To iNbDecimales : sb.Append("0") : Next ' sFormaterNumeriqueDec = sFormaterNumeriqueDec.Replace(sb.ToString, "") ' End If 'End If End Function End Module modUtilExcelRapide.vb Imports ExcelLibrary ' Pour BinaryFileFormat Imports ExcelLibrary.BinaryFileFormat ' Pour WorkbookDecoder Imports ExcelLibrary.CompoundDocumentFormat ' Pour CompoundDocument Imports ExcelLibrary.SpreadSheet ' Pour Workbook Imports System.IO ' Pour MemoryStream Imports System.Text ' Pour StringBuilder Module modUtilExcelRapide Public Const sTypeErrorCode$ = "ExcelLibrary.BinaryFileFormat.ErrorCode" Private Const iAnneeNulleExcel% = 1899 Private Const iAnneeMinExcel% = 1945 #Region "Lecture de cellules spécifiques" Private m_doc As CompoundDocument = Nothing Private m_workbook As Workbook = Nothing Private m_sMemCheminClasseur$ = "" Public Function bLireCellulesXLRapide(ByVal sCheminFichierXL$, _ ByVal sListeCellules$, ByRef aoValeurs() As Object, _ ByVal msgDelegue As clsMsgDelegue, _ Optional ByVal bQuitter As Boolean = True, _ Optional ByRef aoValeursDates() As Object = Nothing, _ Optional ByVal bForcerRelecture As Boolean = False) As Boolean ' Lire des cellules dans un classeur Excel de manière sécurisée ' et retourner un tableau de valeurs Dim bSucces As Boolean = False If Not bFichierExiste(sCheminFichierXL, bPrompt:=True) Then GoTo InitDoc If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ GoTo InitDoc Dim sCheminDossierXL$ = IO.Path.GetDirectoryName(sCheminFichierXL) Try ' Lire le document s'il n'est pas ouvert, ou s'il s'agit d'un autre document If bForcerRelecture OrElse IsNothing(m_doc) OrElse _ sCheminFichierXL <> m_sMemCheminClasseur Then m_sMemCheminClasseur = "" m_doc = CompoundDocument.Open(sCheminFichierXL) Dim streamData As Byte() = m_doc.GetStreamData("Workbook") If IsNothing(streamData) Then GoTo InitDoc m_workbook = WorkbookDecoder.Decode(New MemoryStream(streamData)) m_sMemCheminClasseur = sCheminFichierXL End If Dim asPlages$() = sListeCellules.Split(";"c) Dim iNbValeurs% = asPlages.GetUpperBound(0) ReDim aoValeurs(0 To iNbValeurs) ReDim aoValeursDates(0 To iNbValeurs) Dim iNumValeur% = 0 For Each sFeuillePlage As String In asPlages If String.IsNullOrEmpty(sFeuillePlage) Then Exit For Dim asChamps$() = sFeuillePlage.Split("!"c) Dim sFeuille$ = asChamps(0) Dim sPlage$ = asChamps(1) Dim iCol% = iColPlage(sPlage) Dim iLigne% = iLignePlage(sPlage) Dim worksheet0 As Worksheet = Nothing ' Pour utiliser la fct Find d'une liste générique, ' il faut une expression Lambda worksheet0 = m_workbook.Worksheets.Find(Function(wsheet) wsheet.Name = sFeuille) ' Non : Contains porte sur un objet 'If Not m_workbook.Worksheets.Contains(worksheet0) Then GoTo ValeurNulle 'Dim iIdx% = 0 'For Each worksheet0 In m_workbook.Worksheets ' If worksheet0.Name = sFeuille Then Exit For ' iIdx += 1 'Next ' Vérifier si le nom de la feuille existe If IsNothing(worksheet0) Then GoTo ValeurNulle ' Vérifier si la ligne demandée existe If iLigne - 1 < worksheet0.Cells.FirstRowIndex Or _ iLigne - 1 > worksheet0.Cells.LastRowIndex Then GoTo ValeurNulle Dim row0 As ExcelLibrary.SpreadSheet.Row = worksheet0.Cells.GetRow(iLigne - 1) ' Vérifier si la colonne demandée existe If IsNothing(row0) Then GoTo ValeurNulle If iCol - 1 < row0.FirstColIndex Or _ iCol - 1 > row0.LastColIndex Then GoTo ValeurNulle Dim cell0 As Cell = row0.GetCell(iCol - 1) If IsNothing(cell0) Then GoTo ValeurNulle If IsNothing(cell0.Value) Then GoTo ValeurNulle ' On ne peut pas simplement prendre la valeur ' car elle peut contenir des objets de type ErrorCode (voir ci-dessous) 'aoValeurs(iNumValeur) = cell0.Value Dim oVal As Object = Nothing Dim sVal$ = "" Dim sFormat$ = cell0.Format.FormatString Dim sType$ = cell0.Value.GetType.ToString If sType = sTypeErrorCode Then Dim errCode As BinaryFileFormat.ErrorCode = _ DirectCast(cell0.Value, BinaryFileFormat.ErrorCode) sVal = errCode.Value.ToString() oVal = sVal Else oVal = cell0.Value End If aoValeurs(iNumValeur) = oVal ' En parallèle de la valeur String, renvoyer systématiquement les dates : ' seul l'appelant peut savoir si c'est une date pour le moment ' (Excel y arrive pourtant, mais je n'ai pas encore trouvé ' comment faire pareil via NumberFormat) If cell0.Format.FormatType = CellFormatType.Date OrElse _ cell0.Format.FormatType = CellFormatType.DateTime OrElse _ cell0.Format.FormatType = CellFormatType.Time OrElse _ cell0.Format.FormatType = CellFormatType.Custom Then aoValeursDates(iNumValeur) = dLireDate(cell0) End If ' Méthode automation 'Dim oVal As Object = oWkb.Worksheets(sFeuille).Cells(iLigne, iCol).Value 'aoValeurs(iNumValeur) = oVal ValeurNulle: iNumValeur += 1 Next bSucces = True bLireCellulesXLRapide = True Catch ex As Exception AfficherMsgErreur2(ex, "bLireCellulesXLRapide", _ "Impossible de lire le classeur :" & vbLf & _ sCheminFichierXL, sMsgErrCausePoss) Finally ' Toujours fermer le document If Not IsNothing(m_doc) Then m_doc.Close() ' mais si on quitte ou si erreur alors tout réinitialiser If bQuitter Or Not bSucces Then m_doc = Nothing : m_workbook = Nothing m_sMemCheminClasseur = "" End If msgDelegue.AfficherMsg("") End Try msgDelegue.AfficherMsg(sMsgOperationTerminee) Exit Function InitDoc: m_doc = Nothing : m_workbook = Nothing m_sMemCheminClasseur = "" End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Private Function dLireDate(ByVal cell0 As Cell) As Date Try dLireDate = cell0.DateTimeValue Catch 'ex As Exception dLireDate = dDateNulle End Try End Function #End Region #Region "Fonction utilitaires ExcelLibrary" Public Function sLireValCelluleExcelLibrary$(ByVal cell0 As Cell) Dim sVal$ = "" Dim sFormat$ = cell0.Format.FormatString Dim sType$ = cell0.Value.GetType.ToString If sType = sTypeErrorCode Then Dim errCode As BinaryFileFormat.ErrorCode = _ DirectCast(cell0.Value, BinaryFileFormat.ErrorCode) sVal = errCode.Value.ToString() ElseIf cell0.Format.FormatType = CellFormatType.Date OrElse _ cell0.Format.FormatType = CellFormatType.DateTime OrElse _ cell0.Format.FormatType = CellFormatType.Time OrElse _ cell0.Format.FormatType = CellFormatType.Custom Then sVal = sLireDate(cell0) Else sVal = sLireVal(cell0) End If sLireValCelluleExcelLibrary = sVal End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception '<System.Diagnostics.DebuggerStepThrough()> _ Private Function sLireDate$(ByVal cell0 As Cell, _ Optional ByVal bSupprimerHeureVide As Boolean = True) Try Dim dDate As Date = cell0.DateTimeValue If dDate.Year = iAnneeNulleExcel OrElse _ dDate.Year < iAnneeMinExcel Then ' Il n'y a aucun moyen de savoir si une valeur est une date ou pas sous Excel ' en particulier pour le format personnalisé ' Solution : si l'année est 1899, il ne s'agit probablement pas d'une date ' et aussi si < 1945 : rare 'sLireDate = cell0.Value.ToString() sLireDate = sLireVal(cell0) Exit Function End If ' On impose un format 'Dim sFormat$ = "" Dim sFormat$ = sFormatDateHeureFixe 'If cell0.Format.FormatType = CellFormatType.Date Then sFormat = sFormatDateFixe If String.Compare(cell0.Format.FormatType.ToString, _ CellFormatType.Date.ToString) = 0 Then _ sFormat = sFormatDateFixe 'cell0.Format.FormatType = CellFormatType.DateTime 'cell0.Format.FormatType = CellFormatType.Time 'cell0.Format.FormatType = CellFormatType.Custom sLireDate = dDate.ToString(sFormat) Catch 'ex As Exception ' Il peut y avoir un format date appliqué à du texte sLireDate = cell0.Value.ToString() End Try If Not bSupprimerHeureVide Then Exit Function If Not sLireDate.EndsWith(sHeureVide) Then Exit Function sLireDate = Left$(sLireDate, sLireDate.Length - sHeureVide.Length) End Function Private Function sLireVal$(ByVal cell0 As Cell) Dim sType$ = cell0.Value.GetType.ToString Dim bDbl As Boolean = (String.Compare(sType, "System.Double") = 0) Dim bDec As Boolean = (String.Compare(sType, "System.Decimal") = 0) ' Si réel alors appliquer le format 'sLireVal = dVal.ToString(sFormat) 'Dim sFormat$ = cell0.Format.FormatString If bDbl Then ' Dble -> Dec n'est pas autorisé ' Dec -> Dble est autorisé : donc dble est le + général Dim dVal As Double = CDbl(cell0.Value) sLireVal = sFormaterNumeriqueDble(dVal, iNbDecimales:=iNbDecimalesDef, _ sSeparateurMilliers:=sSeparateurMilliersDef) ElseIf bDec Then Dim dVal As Decimal = CDec(cell0.Value) sLireVal = sFormaterNumeriqueDec(dVal, iNbDecimales:=iNbDecimalesDef, _ sSeparateurMilliers:=sSeparateurMilliersDef) Else sLireVal = cell0.Value.ToString() End If End Function #End Region End Module 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" ' 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 ' L'encodage UTF-8 est le meilleur compromis encombrement/capacité ' il permet l'encodage par exemple du grec, sans doubler la taille du texte '(mais le décodage est plus complexe en interne et les caractères ne s'affichent ' pas bien dans les certains logiciels utilitaires comme WinDiff, ' ni par exemple en csv pour Excel) ' http://fr.wikipedia.org/wiki/Unicode ' 65001 = Unicode UTF-8, 65000 = Unicode UTF-7 Public Const iEncodageUnicodeUTF8% = 65001 Public Const sEncodageISO_8859_1$ = "ISO-8859-1" #Region "Gestion des fichiers" Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _ ByVal sTitre$, Optional ByVal sInitDir$ = "", _ Optional ByVal bDoitExister As Boolean = True, _ Optional ByVal bMultiselect As Boolean = False) 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 Not String.IsNullOrEmpty(sCheminFichier) Then .FileName = sCheminFichier .CheckFileExists = bDoitExister ' 14/10/2007 .DefaultExt = sExtDef .Filter = sFiltre .Multiselect = bMultiselect .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) If Not di.Exists Then bFichierExisteFiltre = False : GoTo Fin Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre = (iNbFichiers > 0) Fin: 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 bFichierExisteFiltre2(ByVal sCheminFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre est trouvé ' Exemple de filtre : C:\Tmp\*.txt If sCheminFiltre.Length = 0 Then Exit Function 'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre) Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre) bFichierExisteFiltre2 = bFichierExisteFiltre(sDossier, sFiltre, bPrompt) 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, bPromptErr:=True) Then Exit Function bRenommerFichier = True Exit Function End If Else If Not bSupprimerFichier(sDest, bPromptErr:=True) 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 aFi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = aFi.GetLength(0) Dim i% For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileName(aFi(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, _ Optional ByVal bLectureSeule As Boolean = False, _ Optional ByVal bEcriture As Boolean = True) As Boolean ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple) ' bEcriture = True par défaut (pour la rétrocompatibilité de la fct bFichierAccessible) ' Nouveau : Simple lecture : Mettre bEcriture = False ' On conserve l'option bLectureSeule pour alerter qu'un fichier doit être fermé ' par l'utilisateur (par exemple un classeur Excel ouvert) bFichierAccessible = False 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, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If Not bEcriture Then access = IO.FileAccess.Read Using fs As New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() End Using bFichierAccessible = True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", _ "Impossible d'accéder au fichier :" & vbLf & _ sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ If bLectureSeule Then ' Le verrouillage Excel peut ralentir une lecture ODBC, ' mais sinon la lecture directe n'est pas possible, même avec ' IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read ? ' (sauf si le fichier a l'attribut lecture seule) ' En fait si, à condition de préciser IO.FileShare.ReadWrite reponse = MsgBox( _ "Veuillez fermer S.V.P. le fichier :" & vbLf & _ sCheminFichier & sQuestion, msgbs, sTitreMsg) Else reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & _ sCheminFichier & vbLf & _ "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & _ "ses attributs de protection, ou alors les droits d'accès." & _ sQuestion, msgbs, sTitreMsg) End If End If End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Sub 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) ' Il faut indiquer le chemin de l'exe si on n'utilise pas le shell 'p.StartInfo.UseShellExecute = False If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Sub Public Function sFormaterTailleOctets$(ByVal lTailleOctets&, _ Optional ByVal bDetail As Boolean = False, _ Optional ByVal bSupprimerPt0 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) & " Go" ElseIf rNbMo >= 1 Then sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0) & " Mo" ElseIf rNbKo >= 1 Then sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0) & " 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, _ Optional ByVal iNbDecimales% = 1) ' 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 = iNbDecimales ' 1 décimale de précision sFormaterNumerique = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = 1 Then sFormaterNumerique = sFormaterNumerique.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormaterNumerique = sFormaterNumerique.Replace(sb.ToString, "") End If End If 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 ' Vérifier , et . : sFormaterNumerique2 = rVal.ToString("n").Replace(",00", "").Replace(".00", "") ' n : numérique général End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(ByVal sCheminDossier$, _ Optional ByVal bPrompt As Boolean = True) 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 Try di.Create() di = New IO.DirectoryInfo(sCheminDossier) If di.Exists Then bVerifierCreerDossier = True : Exit Function Catch ex As Exception If bPrompt Then _ MsgBox("Impossible de créer le dossier :" & vbCrLf & _ sCheminDossier & vbCrLf & ex.Message, _ MsgBoxStyle.Critical, sTitreMsg) 'MsgBox("Impossible de créer le dossier :" & vbCrLf & sCheminDossier, _ ' MsgBoxStyle.Critical, sTitreMsg) End Try 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() Application.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 ?) ' Ex. avec un chemin de fichier ' C:\Tmp\MonFichier.txt -> C:\Tmp ' Ex. avec un chemin de fichier avec filtre ' C:\Tmp\*.txt -> C:\Tmp 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 ' en retournant 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) ' Voir aussi : Zeta Folder XCOPY By Uwe Keim ' A small class to perform basic XCOPY like operations from within C# ' http://www.codeproject.com/KB/recipes/ZetaFolderXCopy.aspx 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 Dim aElements$() = IO.Directory.GetFileSystemEntries(sSrc) For Each sCheminElements As String In aElements Dim sNomElements$ = IO.Path.GetFileName(sCheminElements) If IO.Directory.Exists(sCheminElements) Then ' L'élement est un sous-dossier : le copier bCopierArbo(sCheminElements, sDest & sNomElements, bStatut, _ sListeErr, sListeErrExcep) Else ' Sinon copier le fichier Try IO.File.Copy(sCheminElements, sDest & sNomElements, True) Catch ex As Exception If sListeErrExcep.IndexOf(" " & sNomElements & " ") = -1 Then ' Noter le chemin du fichier imposs. à copier ssi pas exception If sListeErr.Length < 200 Then If sListeErr.Length = 0 Then sListeErr = sDest & sNomElements Else sListeErr &= vbLf & sDest & sNomElements 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" Public Function sLireFichier$(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) ' Lire et renvoyer le contenu d'un fichier sLireFichier = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As 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 End Using : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sLireFichier") Exit Function End Try sLireFichier = sbContenu.ToString End Function Public Function sbLireFichier(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier sbLireFichier = New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim bDebut As Boolean = False Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As 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 End Using : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") End Try End Function Public Function asLireFichier(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) As String() ' Lire et renvoyer le contenu d'un fichier asLireFichier = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Try If bLectureSeule Then Using fs As New IO.FileStream(sCheminFichier, _ IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, Encoding.GetEncoding(iCodePageWindowsLatin1252)) Dim lst As New Collections.Generic.List(Of String) While Not sr.EndOfStream lst.Add(sr.ReadLine()) End While asLireFichier = lst.ToArray End Using : End Using Else asLireFichier = IO.File.ReadAllLines(sCheminFichier, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) End If Catch ex As Exception AfficherMsgErreur2(ex, "asLireFichier") End Try End Function Public Function bEcrireFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder, _ Optional ByVal bEncodageDefaut As Boolean = False, _ Optional ByVal bEncodageISO_8859_1 As Boolean = False, _ Optional ByVal bEncodageUFT8 As Boolean = False, _ Optional ByVal iEncodage% = 0, Optional ByVal sEncodage$ = "", _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") 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 ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUFT8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sbContenu.ToString()) sw.Close() bEcrireFichier = True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) 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, _ Optional ByVal bEncodageUFT8 As Boolean = False, _ Optional ByVal iEncodage% = 0, Optional ByVal sEncodage$ = "", _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") 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 ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUFT8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sContenu) sw.Close() bEcrireFichier = True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Exit Function 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sContenu) End Using 'sw.Close() bAjouterFichier = True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bAjouterFichier", sMsg) 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder) As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Exit Function 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) End Using '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 sLigneCmd$, _ Optional ByVal bSupprimerEspaces As Boolean = True) As String() ' Retourner les arguments de la ligne de commande Dim asArgs$() = Nothing If String.IsNullOrEmpty(sLigneCmd) Then ReDim asArgs(0) asArgs(0) = "" asArgLigneCmd = asArgs Exit Function End If '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 = sLigneCmd 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)) sFichier = Mid$(sCmd, iDeb2, iFin - iDeb2) If bSupprimerEspaces Then sFichier = Trim$(sFichier) 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) 'If bSupprimerEspaces Then ' asArgs(iNumArg) = Trim$(asArgs(iNumArg)) 'Else ' asArgs(iNumArg) = asArgs(iNumArg) 'End If 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 correct 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 modUtilLT.vb ' Utilitaires en liaison tardive Option Strict Off ' Pour oObjetQcq.Version Module modUtilLT 'Public Function bVerifierInstallObjet(ByVal sClasse$, _ ' Optional ByRef sVersion$ = "", _ ' Optional ByVal bClassID As Boolean = False, _ ' Optional ByVal bLireVersion As Boolean = True) As Boolean ' 'Optional ByRef sMajorVersion$ = "", _ ' 'Optional ByRef sMinorVersion$ = "" ' ' Vérifier si le composant est bien installé ' ' Pour les serveurs com/ActiveX mono-instance comme Outlook ' ' il faut utiliser une autre version qui teste GetObject avant ' ' CreateObject (sinon cette fonction risque de provoquer ' ' la fermeture du composant s'il est déjà ouvert) ' If bClassID Then ' ' Si c'est une ClassID au lieu d'un ProgID ' ' on lit simplement la clé ' If bCleRegistreCRExiste("TypeLib", sClasse) Then ' bVerifierInstallObjet = True ' End If ' Exit Function ' End If ' Dim oObjetQcq As Object = Nothing ' Try ' oObjetQcq = CreateObject(sClasse) ' sClasse = ProgID ' bVerifierInstallObjet = True ' Catch 'ex As Exception ' bVerifierInstallObjet = False ' End Try ' If bVerifierInstallObjet And bLireVersion Then ' Try ' sVersion = oObjetQcq.Version.ToString ' 'sVersion = CStr(oObjetQcq.Version) ' 'sMajorVersion = oObjetQcq.MajorVersion ' 'sMinorVersion = oObjetQcq.MinorVersion ' Catch ' End Try ' End If ' oObjetQcq = Nothing 'End Function '#Region "Fonction d'export d'ucTableur" 'Public Function bExporterExcel(ByVal sCheminFichierXLModele$, ByVal sFichierModele$, _ ' ByVal sPlageDonneesXL$, ByVal msgDelegue As clsMsgDelegue, _ ' Optional ByVal bAjusterAuContenu As Boolean = False, _ ' Optional ByVal sFichierXl$ = sFichierExportXL, _ ' Optional ByVal bRelancerExcel As Boolean = True, _ ' Optional ByVal bActualiserTCD As Boolean = True) As Boolean ' Dim bSuccesExportExcel As Boolean ' ' Sauver le fichier XL modèle modifié ' Dim sCheminFichierXL$ = Application.StartupPath & "\" & _ ' sDossierExportExcel & "\" & sFichierXl ' ' Quand le nom changera, il faudra supprimer le fichier ' If Not bVerifierCreerDossier(Application.StartupPath & "\" & _ ' sDossierExportExcel) Then GoTo Erreur ' If Not bFichierExiste(sCheminFichierXLModele, bPrompt:=True) Then GoTo Erreur ' If Not bFichierAccessible(sCheminFichierXLModele, bPromptFermer:=True) Then GoTo Erreur ' If bFichierExiste(sCheminFichierXL) Then ' ' On passe bLectureSeule pour afficher "Fermez le fichier" : pas très logique ! ' If Not bFichierAccessible(sCheminFichierXL, bPromptFermer:=True, _ ' bLectureSeule:=True) Then GoTo Erreur ' If sCheminFichierXL <> sCheminFichierXLModele Then ' If Not bSupprimerFichier(sCheminFichierXL) Then GoTo Erreur ' End If ' End If ' ' Liaison tardive ' Dim oXLH As clsHebExcel = Nothing ' Dim oWkb As Object = Nothing ' Dim oSht As Object = Nothing ' ' Liaison précoce : avantage : mise au point, ' ' inconv. : Excel doit être installé à la bonne version ' 'Dim oXL As Excel.Application, oWkb As Excel.Workbook, oSht As Excel.Worksheet ' 'Set oXL = New Excel.Application ' Création d'une instance d'Excel ' Try ' Sablier() ' msgDelegue.AfficherMsg("Lancement d'Excel...") ' ' On n'interdit pas qu'Excel soit ouvert au préalable, ' ' mais on ferme le classeur à la fin, et on le réouvre dans ' ' une autre instance : + sûr ainsi ' oXLH = New clsHebExcel(bInterdireAppliAvant:=False) ' 05/11/2008 ' If IsNothing(oXLH.oXL) Then ' msgDelegue.AfficherMsg("Excel n'est pas installé !") ' GoTo Fin ' End If ' 'oXLH.oXl.Visible = True ' Mode Debug ' oXLH.oXL.Visible = False ' msgDelegue.AfficherMsg("Ouverture du fichier modèle...") ' oWkb = oXLH.oXL.Workbooks.Open(sCheminFichierXLModele) ' msgDelegue.AfficherMsg("Copie des données...") ' oSht = oWkb.Worksheets(1) ' oSht.Activate() ' Activer la feuille XL ' oSht.Unprotect() ' oSht.Range(sPlageDonneesXL).Select() ' oXLH.oXL.DisplayAlerts = False ' Désactiver l'alerte plage <> ' oSht.Paste() ' oXLH.oXL.DisplayAlerts = True ' If bAjusterAuContenu Then oSht.Cells.EntireColumn.AutoFit() ' oSht.Cells(1, 1).Select() ' oSht.Activate() ' msgDelegue.AfficherMsg("Mise à jour des graphes...") ' If bActualiserTCD Then oWkb.RefreshAll() ' Mettre à jour tous les graphes, tcd... ' oWkb.Worksheets(1).Activate() ' Activer le premier classeur avant de sauver ' oXLH.oXL.DisplayAlerts = False ' Désactiver les messages ' msgDelegue.AfficherMsg("Sauvegarde du fichier...") ' oXLH.oXL.ActiveWorkbook.SaveAs(sCheminFichierXL) ' Sauver le fichier XL ' oXLH.oXL.DisplayAlerts = True ' msgDelegue.AfficherMsg("Le fichier suivant a été créé avec succès : " & sFichierXl) ' bSuccesExportExcel = True ' bExporterExcel = True ' Catch ex As Exception ' AfficherMsgErreur2(ex, "ExporterExcel", _ ' "Impossible d'exporter le document sous Excel !", _ ' "Cause possible : Excel est actuellement en cours d'édition d'un document") ' Finally ' 'msgDelegue.AfficherMsg("Fermeture du classeur...") ' 'oXLH.Fermer(oSht, oWkb, bQuitter:=True) ' 'msgDelegue.AfficherMsg("") ' ' 12/05/2009 Quitter ou sinon seulement liberer ' Dim bQuitter As Boolean = False ' If Not bRelancerExcel Then bQuitter = True ' If bQuitter Then ' msgDelegue.AfficherMsg("Fermeture du classeur...") ' oXLH.Fermer(oSht, oWkb, bQuitter:=True) ' msgDelegue.AfficherMsg("") ' Else ' Liberer ' ' Penser à rendre l'instance visible ' oXLH.oXL.Visible = True ' LibererObjetCom(oSht) ' LibererObjetCom(oWkb) ' LibererObjetCom(oXLH.oXL) ' LibererObjetCom(oXLH.m_oApp) '15/05/2009 ' ' Ne pas oublier car sinon ne quitte Excel que lorsqu'on quitte l'appli : ' oXLH = Nothing ' ' Ne pas attendre le recyclage pour fermer Excel, maintenant ' msgDelegue.AfficherMsg("Libération des ressources allouées...") ' LibererRessourceDotNet() ' msgDelegue.AfficherMsg("") ' End If ' End Try ' ' 12/05/2009 ' 'If bSuccesExportExcel And bRelancerExcel Then ' ' msgDelegue.AfficherMsg("Relancement d'Excel...") ' ' OuvrirAppliAssociee(sCheminFichierXL) ' 'End If ' msgDelegue.AfficherMsg("Export terminé.") 'Fin: ' Sablier(bDesactiver:=True) ' Exit Function 'Erreur: ' msgDelegue.AfficherMsg("Erreur lors de l'export Excel !") 'End Function 'Public Function bResauverFichierExcel(ByVal sCheminFichierXL$, _ ' ByVal msgDelegue As clsMsgDelegue, _ ' Optional ByVal bRelancerExcel As Boolean = True) As Boolean ' Dim bSuccesExportExcel As Boolean ' ' Resauver le fichier XL sous Excel cette fois ' ' (à cause du problème de l'export Spreadsheet Gear s'il y a des formules : ' ' "Microsoft Office Excel recalcule les formules à l'ouverture des fichiers ' ' dont le dernier enregistrement a été effectué sur une version antérieure ' ' de Microsoft Office Excel") ' ' Liaison tardive ' Dim oXLH As clsHebExcel = Nothing ' Dim oWkb As Object = Nothing ' Dim oSht As Object = Nothing ' Try ' Sablier() ' msgDelegue.AfficherMsg("Lancement d'Excel...") ' ' On n'interdit pas qu'Excel soit ouvert au préalable, ' ' mais on ferme le classeur à la fin, et on le réouvre dans ' ' une autre instance : + sûr ainsi ' oXLH = New clsHebExcel(bInterdireAppliAvant:=False) ' 05/11/2008 ' If IsNothing(oXLH.oXL) Then ' msgDelegue.AfficherMsg("Excel n'est pas installé !") ' GoTo Fin ' End If ' oXLH.oXL.Visible = False ' msgDelegue.AfficherMsg("Ouverture du fichier...") ' oWkb = oXLH.oXL.Workbooks.Open(sCheminFichierXL) ' oXLH.oXL.DisplayAlerts = False ' Désactiver les messages ' msgDelegue.AfficherMsg("Sauvegarde du fichier...") ' oXLH.oXL.ActiveWorkbook.SaveAs(sCheminFichierXL) ' Sauver le fichier XL ' oXLH.oXL.DisplayAlerts = True ' msgDelegue.AfficherMsg("Le fichier suivant a été créé avec succès : " & _ ' IO.Path.GetFileName(sCheminFichierXL)) ' bSuccesExportExcel = True ' bResauverFichierExcel = True ' Catch ex As Exception ' AfficherMsgErreur2(ex, "bResauverFichierExcel", _ ' "Impossible d'exporter le document sous Excel !", _ ' "Cause possible : Excel est actuellement en cours d'édition d'un document") ' Finally ' 'msgDelegue.AfficherMsg("Fermeture du classeur...") ' 'oXLH.Fermer(oSht, oWkb, bQuitter:=True) ' 'msgDelegue.AfficherMsg("") ' ' 12/05/2009 Quitter ou sinon seulement liberer ' Dim bQuitter As Boolean = False ' If Not bRelancerExcel Then bQuitter = True ' If bQuitter Then ' msgDelegue.AfficherMsg("Fermeture du classeur...") ' oXLH.Fermer(oSht, oWkb, bQuitter:=True) ' msgDelegue.AfficherMsg("") ' Else ' Liberer ' ' Penser à rendre l'instance visible ' oXLH.oXL.Visible = True ' LibererObjetCom(oSht) ' LibererObjetCom(oWkb) ' LibererObjetCom(oXLH.oXL) ' LibererObjetCom(oXLH.m_oApp) '15/05/2009 ' ' Ne pas oublier car sinon ne quitte Excel que lorsqu'on quitte l'appli : ' oXLH = Nothing ' ' Ne pas attendre le recyclage pour fermer Excel, maintenant ' msgDelegue.AfficherMsg("Libération des ressources allouées...") ' LibererRessourceDotNet() ' msgDelegue.AfficherMsg("") ' End If ' End Try ' ' 12/05/2009 ' 'If bSuccesExportExcel And bRelancerExcel Then ' ' msgDelegue.AfficherMsg("Relancement d'Excel...") ' ' OuvrirAppliAssociee(sCheminFichierXL) ' 'End If ' msgDelegue.AfficherMsg("Export terminé.") 'Fin: ' Sablier(bDesactiver:=True) 'End Function '#End Region Public Sub LibererObjetCom(ByRef oCom As Object) ' 15/05/2009 ByRef ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing ' Pour Excel : ' Quit Excel and clean up. ' oBook.Close(false, oMissing, oMissing); ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBook); ' oBook = null; ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBooks); ' oBooks = null; ' oExcel.Quit(); ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oExcel); ' oExcel = null; If IsNothing(oCom) Then Exit Sub Try Runtime.InteropServices.Marshal.ReleaseComObject(oCom) Catch Finally oCom = Nothing End Try End Sub End Module modUtilReg.vb ' Fichier modUtilReg.vb : Module de gestion de la base de registre ' --------------------- Imports Microsoft.Win32 Module modUtilReg ' Microsoft Win32 to Microsoft .NET Framework API Map : Registry Functions ' http://msdn.microsoft.com/en-us/library/aa302340.aspx#win32map_registryfunctions Public Function bAjouterTypeFichier(ByVal sExtension$, ByVal sTypeFichier$, _ Optional ByVal sDescriptionExtension$ = "", _ Optional ByVal bEnlever As Boolean = False) As Boolean ' Ajouter(/Enlever) dans la base de registre un type de fichier ClassesRoot ' pour associer une extension de ficier à une application par défaut ' (via le double-clic ou bien le menu contextuel Ouvrir) ' Exemple : associer .dat à mon application.exe Try If bEnlever Then If bCleRegistreCRExiste(sExtension) Then Registry.ClassesRoot.DeleteSubKeyTree(sExtension) End If Else If Not bCleRegistreCRExiste(sExtension) Then Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sExtension) rk.SetValue("", sTypeFichier) If sDescriptionExtension.Length > 0 Then rk.SetValue("Content Type", sDescriptionExtension) End If End Using 'rk.Close() End If End If bAjouterTypeFichier = True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterTypeFichier") End Try End Function Public Function bAjouterMenuContextuel(ByVal sTypeFichier$, ByVal sCmd$, _ Optional ByVal bPrompt As Boolean = True, _ Optional ByVal bEnlever As Boolean = False, _ Optional ByVal sDescriptionCmd$ = "", _ Optional ByVal sCheminExe$ = "", _ Optional ByVal sCmdDef$ = """%1""", _ Optional ByVal sDescriptionTypeFichier$ = "", _ Optional ByVal bEnleverTypeFichier As Boolean = False) As Boolean ' Ajouter un menu contextuel dans la base de registre ' de type ClassesRoot : fichier associé à une application standard ' Exemple : ajouter le menu contextuel "Convertir en Html" sur les fichiers projet VB6 ' sTypeFichier = "VisualBasic.Project" ' sCmd = "ConvertirEnHtml" ' sDescriptionCmd = "Convertir en Html" ' sCheminExe = "C:\Program Files\VB2Html\VB2Html.exe" Try ' D'abord vérifier si la clé principale existe If Not bCleRegistreCRExiste(sTypeFichier) Then If bEnlever Then bAjouterMenuContextuel = True : Exit Function Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sTypeFichier) If sDescriptionTypeFichier.Length > 0 Then rk.SetValue("", sDescriptionTypeFichier) End If End Using End If Dim sCleDescriptionCmd$ = sTypeFichier & "\shell\" & sCmd If bEnlever Then If bEnleverTypeFichier Then ' Si c'est un type de fichier créé à l'occasion ' il faut aussi le supprimer (mais seulement dans ce cas) If bCleRegistreCRExiste(sTypeFichier) Then Registry.ClassesRoot.DeleteSubKeyTree(sTypeFichier) If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "a été enlevé avec succès dans la base de registre", _ MsgBoxStyle.Information, sTitreMsg) Else If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "est introuvable dans la base de registre", _ MsgBoxStyle.Information, sTitreMsg) End If Else 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 End If bAjouterMenuContextuel = True Exit Function End If Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleDescriptionCmd) rk.SetValue("", sDescriptionCmd) End Using 'rk.Close() Dim sCleCmd$ = sTypeFichier & "\shell\" & sCmd & "\command" Using rk As RegistryKey = Registry.ClassesRoot.CreateSubKey(sCleCmd) ' Ajouter automatiquement des guillemets " si le chemin contient au moins un espace If sCheminExe.IndexOf(" ") > -1 Then _ sCheminExe = """" & sCheminExe & """" rk.SetValue("", sCheminExe & " " & sCmdDef) End Using 'rk.Close() If bPrompt Then _ MsgBox("Le menu contextuel [" & sDescriptionCmd & "]" & vbLf & _ "a été ajouté avec succès dans la base de registre pour les fichiers du type :" & vbLf & _ "[" & sTypeFichier & "]", MsgBoxStyle.Information, sTitreMsg) bAjouterMenuContextuel = True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterMenuContextuel") End Try End Function Public Function bCleRegistreCRExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "") As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre ' Note : la sous-clé est ici un "sous-dossier" (et non un "fichier") Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey( _ sCle & "\" & sSousCle) ' Liste des sous-clés (sous forme de "sous-dossier") 'Dim asListeSousClesCR$() = rkCRCle.GetSubKeyNames If IsNothing(rkCRCle) Then Exit Function End Using ' rkCRCle.Close() est automatiquement appelé bCleRegistreCRExiste = True Catch End Try End Function Public Function bCleRegistreCRExiste(ByVal sCle$, _ ByVal sSousCle$, ByRef sValSousCle$) As Boolean ' Vérifier si une clé ClassesRoot existe dans la base de registre ' et si elle est trouvée, alors lire la valeur de la sous-clé ' Renvoyer True si la valeur de la sous-clé a pu être lue ' Note : la sous-clé est ici un "fichier" (et non un "sous-dossier") sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCRCle As RegistryKey = Registry.ClassesRoot.OpenSubKey(sCle) If IsNothing(rkCRCle) Then Exit Function ' Pour lire la valeur par défaut d'un "dossier", laisser "" Dim oVal As Object = rkCRCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Exit Function Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Exit Function sValSousCle = sValSousCle0 End Using ' rkCRCle.Close() est automatiquement appelé bCleRegistreCRExiste = True Catch End Try End Function Public Function bCleRegistreLMExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "", _ Optional ByRef sValSousCle$ = "", _ Optional ByVal sNouvValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé LocalMachine existe dans la base de registre sValSousCle = "" Try Dim bEcriture As Boolean = False If sNouvValSousCle.Length > 0 Then bEcriture = True ' Si la clé n'existe pas, on passe dans le Catch Using rkLMCle As RegistryKey = Registry.LocalMachine.OpenSubKey(sCle, _ writable:=bEcriture) ' Lecture de la valeur de la sous-clé (sous forme de "fichier") Dim oVal As Object = rkLMCle.GetValue(sSousCle) ' Liste des sous-clés (sous forme de "sous-dossier") 'Dim asListeSousClesLM$() = rkLMCle.GetSubKeyNames ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Exit Function Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Exit Function sValSousCle = sValSousCle0 If bEcriture Then oVal = CInt(sNouvValSousCle) rkLMCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord) End If End Using ' rkLMCle.Close() est automatiquement appelé bCleRegistreLMExiste = True ' On peut lire cette clé, donc elle existe Catch End Try End Function Public Function bCleRegistreCUExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "", _ Optional ByRef sValSousCle$ = "") As Boolean ' Vérifier si une clé/sous-clé CurrentUser existe dans la base de registre ' et si oui renvoyer la valeur de la sous-clé sValSousCle = "" Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) Dim oVal As Object = rkCUCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Exit Function Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Exit Function sValSousCle = sValSousCle0 End Using ' rkCUCle.Close() est automatiquement appelé bCleRegistreCUExiste = True ' On peut lire cette clé, donc elle existe Catch End Try End Function Public Function asListeSousClesCU(ByVal sCle$) As String() ' Renvoyer la liste des sous-clés de type CurrentUser asListeSousClesCU = Nothing Try ' Si la clé n'existe pas, on passe dans le Catch Using rkCUCle As RegistryKey = Registry.CurrentUser.OpenSubKey(sCle) If IsNothing(rkCUCle) Then Exit Function asListeSousClesCU = rkCUCle.GetSubKeyNames End Using ' rkCUCle.Close() est automatiquement appelé Catch End Try End Function End Module