XL2Csv v1.1.2.*Table des procédures 1 - _modDepart.vb 1.1 - Public Sub Depart 1.2 - Public Sub Main 2 - AssemblyInfo.vb 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 AjouterMenuCtx 3.7 - Private Sub chkODBC_CheckedChanged 3.8 - Private Sub cmdAjouterMenuCtx_Click 3.9 - Private Sub cmdAnnuler_Click 3.10 - Private Sub cmdConv_Click 3.11 - Private Sub cmdEnleverMenuCtx_Click 3.12 - Private Sub EnleverMenuCtx 3.13 - Private Sub frmXL2Csv_Shown 3.14 - Private Sub m_oODBC_EvAfficherMessage 3.15 - Private Sub VerifierMenuCtx 4 - modExcel.vb 4.1 - FunctionbFeuilleExiste 4.2 - Public Function bConvertirXLAutomation 4.3 - Public Function bLireCellulesXLAutomation 4.4 - Public Function bLireCellulesXLCouleurs 4.5 - Public Function iColFinPlage% 4.6 - Public Function iColPlage% 4.7 - Public Function iLigneFinPlage% 4.8 - Public Function iLignePlage% 4.9 - Public Function sConvNumEnLettres$ 5 - modExcelLibrary.vb 5.1 - Private Function sLireVal$ 5.2 - Private FunctionsLireDate$ 5.3 - Public Function bConvertirXL2Txt 5.4 - Public Function bConvertirXLRapide 5.5 - Public Function sLireValCelluleExcelLibrary$ 6 - modExcelNPOI.vb 6.1 - Private Function GetValue 6.2 - Private Function sLireValeur$ 6.3 - Public Function bConvertirXLRapideNPOI 7 - modExcelSSG.vb 7.1 - Public Function bConvertirXLRapideSSG 7.2 - Public Function bConvertirXLRapideSSG 8 - modUtil.vb 8.1 - Public Function bFichierAccessibleMultiTest 8.2 - Public Function iConv% 8.3 - Public Function sValeurPtDecimal$ 8.4 - Public Sub AfficherMsgErreur2 8.5 - Public Sub Attendre 8.6 - Public Sub CopierPressePapier 8.7 - Public Sub LibererRessourceDotNet 8.8 - Public Sub Sablier 8.9 - Public Sub TraiterMsgSysteme_DoEvents 9 - modUtilExcel.vb 9.1 - Public Function sFormaterNumeriqueDble$ 9.2 - Public Function sFormaterNumeriqueDec$ 10 - modUtilLT.vb 10.1 - Public Sub LibererObjetCom 11 - clsAfficherMsg.vb 11.1 - Public Delegate Sub GestEvTick 11.2 - Public ReadOnly Property bDesactiver 11.3 - Public ReadOnly Property fsi 11.4 - Public ReadOnly Property iNumFichierEnCours% 11.5 - Public ReadOnly Property lAvancement 11.6 - Public ReadOnly Property sMessage$ 11.7 - Public ReadOnly Property sMessage$ 11.8 - Public Sub AfficherAvancement 11.9 - Public Sub AfficherFichierEnCours 11.10 - Public Sub AfficherFSIEnCours 11.11 - Public Sub AfficherMsg 11.12 - Public Sub New 11.13 - Public Sub New 11.14 - Public Sub New 11.15 - Public Sub New 11.16 - Public Sub New 11.17 - Public Sub New 11.18 - Public Sub New 11.19 - Public Sub New 11.20 - Public Sub Sablier 11.21 - Public Sub Tick 12 - clsHebOffice.vb 12.1 - Public Function bMonInstanceOuverte 12.2 - Public Function bOuvert 12.3 - Public Overloads Shared Function bOuvert 12.4 - Public Overloads Shared Function bOuvert 12.5 - Public Shared Function bOuvert 12.6 - Public Shared Sub LibererObjetCom 12.7 - Public Shared Sub LibererObjetCom 12.8 - Public Sub Fermer 12.9 - Public Sub New 12.10 - Public Sub New 12.11 - Public Sub New 12.12 - Public Sub New 12.13 - Public Sub Quitter 12.14 - Public Sub Quitter 13 - clsODBC.vb 13.1 - Private Function bCheminFichierProbable 13.2 - Private Function bCreerFichierDsnODBC 13.3 - Private Function bCreerFichiersDsnEtSQLODBCDefaut 13.4 - Private Sub AfficherErreursADO 13.5 - Private Sub AfficherMessage 13.6 - Private Sub AjouterEntete 13.7 - Private Sub AjouterTemps 13.8 - Private Sub TraiterValChamp 13.9 - Public Delegate Sub GestEvAfficherMessage 13.10 - Public Function bExplorerSourceODBC 13.11 - Public Function bLireSourceODBC 13.12 - Public Function bLireSQL 13.13 - Public Function bVerifierCheminODBC 13.14 - Public Function sLireNomPiloteODBC$ 13.15 - Public Shared Sub VerifierConfigODBCExcel 13.16 - Public Sub Annuler 13.17 - Public Sub LibererRessources 13.18 - Public Sub New 13.19 - Public Sub ViderContenuResultat 14 - modUtilFichier.vb 14.1 - Public Function asArgLigneCmd 14.2 - Public Function asLignes 14.3 - Public Function asLireFichier 14.4 - Public Function bAjouterFichier 14.5 - Public Function bAjouterFichier 14.6 - Public Function bCopierArbo 14.7 - Public Function bCopierFichier 14.8 - Public Function bCopierFichiers 14.9 - Public Function bDeplacerDossier 14.10 - Public Function bDeplacerFichiers2 14.11 - Public Function bDeplacerFichiers3 14.12 - Public Function bDossierExiste 14.13 - Public Function bEcrireFichier 14.14 - Public Function bEcrireFichier 14.15 - Public Function bFichierExiste 14.16 - Public Function bFichierExisteFiltre 14.17 - Public Function bFichierExisteFiltre2 14.18 - Public Function bReencoder 14.19 - Public Function bRenommerDossier 14.20 - Public Function bRenommerFichier 14.21 - Public Function bSupprimerDossier 14.22 - Public Function bSupprimerFichier 14.23 - Public Function bSupprimerFichiersFiltres 14.24 - Public Function bTrouverFichier 14.25 - Public Function bVerifierCreerDossier 14.26 - Public Function iNbFichiersFiltres% 14.27 - Public Function sbLireFichier 14.28 - Public Function sCheminRelatif$ 14.29 - Public Function sConvNomDos$ 14.30 - Public Function sDossierParent$ 14.31 - Public Function sEnleverSlashFinal$ 14.32 - Public Function sEnleverSlashInitial$ 14.33 - Public Function sExtraireChemin$ 14.34 - Public Function sFormaterNumerique$ 14.35 - Public Function sFormaterNumerique2$ 14.36 - Public Function sFormaterTailleKOctets$ 14.37 - Public Function sFormaterTailleOctets$ 14.38 - Public Function sLecteurDossier$ 14.39 - Public Function sLireFichier$ 14.40 - Public Function sNomDossierFinal$ 14.41 - Public Function sNomDossierParent$ 14.42 - Public Function StringReadLine$ 14.43 - Public FunctionbFichierAccessible 14.44 - Public Sub New 14.45 - Public SubOuvrirAppliAssociee 14.46 - Public SubOuvrirDossier 14.47 - Public SubProposerOuvrirFichier 15 - modUtilReg.vb 15.1 - Public Function asListeSousClesCU 15.2 - Public Function bAjouterMenuContextuel 15.3 - Public Function bAjouterTypeFichier 15.4 - Public Function bCleRegistreCRExiste 15.5 - Public Function bCleRegistreCRExiste 15.6 - Public Function bCleRegistreCUExiste 15.7 - Public Function bCleRegistreLMExiste _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.12 du 24/09/2017 Menus contextuels : * au lieu de .xls et .xlsx qui ne marchent plus ' Version 1.11 du 15/09/2013 ' Version 1.10 du 08/08/2012 ' Version 1.09 du 11/03/2012 ' 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 m_sTitreMsg$ = sNomAppli 'Public Const sTitreMsg$ = "XL2Csv" Public Const sTitreMsgDescription$ = " : Convertir un fichier Excel en fichiers Csv" Private Const sDateVersionXL2Csv$ = "24/09/2017" '1.11:15/09/2013 1.10:12/08/2012 1.09:04/03/2012 1.08: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 bExcel2007SupportNPOI As Boolean = False ' Prochainement : NPOI V3.1 Public Const bExcel2007SupportSSG As Boolean = True Public Const dDateNulle As Date = #12:00:00 AM# Public Const sExtXlsx$ = ".xlsx" '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() If bDebug Then Depart() : Exit Sub Try Depart() Catch ex As Exception AfficherMsgErreur2(ex, "Main " & m_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 ' S'il n'y a qu'un seul argument et que l'extension du fichier est .xlsx alors SSG If sCheminFichier.ToLower.EndsWith(sExtXlsx) Then 'iTypeConv = frmXL2Csv.TypeConv.XL2CsvNPOI Pas encore implémenté If bSpreadSheetGear Then iTypeConv = frmXL2Csv.TypeConv.XL2CsvSSG ' 09/08/2012 End If GoTo Suite End If Dim sCmd$ = asArgs(1) 'If bDebug Then MsgBox("Commande : " & sCmd, MsgBoxStyle.Information, m_sTitreMsg) If sCmd = frmXL2Csv.sXL2Csv Then iTypeConv = frmXL2Csv.TypeConv.XL2Csv ElseIf sCmd = frmXL2Csv.sXL2CsvNPOI Then iTypeConv = frmXL2Csv.TypeConv.XL2CsvNPOI ElseIf sCmd = frmXL2Csv.sXL2CsvSSG Then iTypeConv = frmXL2Csv.TypeConv.XL2CsvSSG ' 09/08/2012 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, m_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 Dim sTxt$ = _ "Syntaxe : Chemin du fichier Excel à convertir" & vbCrLf & _ "en autant de fichiers Csv qu'il y a de feuille Excel" & vbCrLf & _ "Options possibles :" & vbCrLf & _ "XL2CsvNPOI : utiliser la librairie NPOI au lieu d'ExcelLibrary" & vbCrLf If bSpreadSheetGear Then sTxt &= _ "XL2CsvSSG : utiliser la librairie SpreadSheetGear au lieu d'ExcelLibrary" & vbCrLf sTxt &= _ "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 XL2CsvNPOI" & vbCrLf If bSpreadSheetGear Then sTxt &= _ "XL2Csv.exe C:\Tmp\MonFichierExcel XL2CsvSSG" & vbCrLf sTxt &= _ "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, en mode admin.)" MsgBox(sTxt, MsgBoxStyle.Information, m_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 'Or iTypeConv = frmXL2Csv.TypeConv.XL2Txt If iTypeConv = frmXL2Csv.TypeConv.XL2CsvNPOI Then If Not bFichierExiste(Application.StartupPath & "\NPOI.dll", _ bPrompt:=True) Then Exit Sub End If If iTypeConv = frmXL2Csv.TypeConv.XL2CsvSSG Then ' 09/08/2012 If Not bFichierExiste(Application.StartupPath & "\SpreadSheetGear.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 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 © 2017 ORS Production")> <Assembly: AssemblyTrademark("XL2Csv")> '<Assembly: AssemblyCulture("")> <Assembly: AssemblyVersion("1.1.2.*")> 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) XL2CsvNPOI ' Méthode rapide via NPOI XL2CsvSSG ' Méthode rapide via SpreadSheetGear 09/08/2012 ' 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 ' Autant de fichiers csv que de feuilles Excel : ' -------------------------------------------- Public Const sXL2Csv$ = "XL2Csv" ' Option par défaut : XL2Csv via ExcelLibrary Public Const sXL2CsvNPOI$ = "XL2CsvNPOI" ' XL2Csv via NPOI Public Const sXL2CsvSSG$ = "XL2CsvSSG" ' XL2Csv via SpreadSheetGear 09/08/2012 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 ' 17/09/2017 Excel.Sheet.8 -> *, car sinon ne fonctionne plus ? Private Const sMenuCtx_TypeFichierExcel$ = "Excel.Sheet.8" Private Const sMenuCtx_TypeFichierTous$ = "*" ' Tous les fichiers 'Private Const sMenuCtx_TypeFichierSelect$ = sMenuCtx_TypeFichierExcel 'Private Const sMenuCtx_TypeFichierSelect$ = sMenuCtx_TypeFichierExcel2007 Private Const sMenuCtx_TypeFichierSelect$ = sMenuCtx_TypeFichierTous Private Const sMenuCtx_TypeFichierExcel2007$ = "Excel.Sheet.12" ' 03/09/2017 ConvertirEnCsv -> XL2Csv.ConvertirEnCsv (et pour les suivants aussi) Private Const sMenuCtx_CleCmdConvertirEnCsv$ = "XL2Csv.ConvertirEnCsv" Private Const sMenuCtx_CleCmdConvertirEnCsvDescription$ = _ "Convertir en fichiers Csv (via XLLib.)" Private Const sMenuCtx_CleCmdConvertirEnCsvNPOI$ = "XL2Csv.ConvertirEnCsvNPOI" Private Const sMenuCtx_CleCmdConvertirEnCsvNPOIDescription$ = _ "Convertir en fichiers Csv (via NPOI)" Private Const sMenuCtx_CleCmdConvertirEnCsvSSG$ = "XL2Csv.ConvertirEnCsvSSG" ' 09/08/2012 Private Const sMenuCtx_CleCmdConvertirEnCsvSSGDescription$ = _ "Convertir en fichiers Csv (via SSG)" Private Const sMenuCtx_CleCmdConvertirEn1Csv$ = "XL2Csv.ConvertirEn1Csv" ' XL2CsvGroup Private Const sMenuCtx_CleCmdConvertirEn1CsvDescription$ = "Convertir en fichier Csv fusionné" Private Const sMenuCtx_CleCmdConvertirEnTxt$ = "XL2Csv.ConvertirEnTxt" Private Const sMenuCtx_CleCmdConvertirEnTxtDescription$ = "Convertir en fichier Texte" Private Const sMenuCtx_CleCmdConvertirEnCsvAutomation$ = "XL2Csv.ConvertirEnCsvAutomation" Private Const sMenuCtx_CleCmdConvertirEnCsvAutomationDescription$ = _ "Convertir en fichiers Csv (automation)" Private Const sMenuCtx_CleCmdConvertirEnCsvODBC$ = "XL2Csv.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 ' 17/09/2017 On ne peut plus associer un menu avec .xls ni .xlsx ?! ' On associe tous les fichiers (*) avec XL2Csv alors Dim sType$ = sMenuCtx_TypeFichierSelect VerifierMenuCtx(sType) 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.chkXL2CsvNPOI.Visible = True If bSpreadSheetGear Then Me.chkXL2CsvSSG.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 via ExcelLibrary") Me.ToolTip1.SetToolTip(Me.chkXL2CsvNPOI, _ sCmd & "XL2CsvNPOI : Convertir un fichier Excel en fichiers Csv via NPOI") Me.ToolTip1.SetToolTip(Me.chkXL2CsvSSG, _ sCmd & "XL2CsvSSG : Convertir un fichier Excel en fichiers Csv via SpreadSheetGear") ' 09/08/2012 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 via ExcelLibrary" Case TypeConv.XL2CsvNPOI : Me.Text = _ "XL2Csv" & sVersion & " : Convertir un fichier Excel en fichiers Csv via NPOI" Case TypeConv.XL2CsvSSG : Me.Text = _ "XL2Csv" & sVersion & " : Convertir un fichier Excel en fichiers Csv via SpreaSheetGear" ' 09/08/2012 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) ElseIf Me.m_iTypeConv = TypeConv.XL2CsvNPOI Then bOk = bConvertirXLRapideNPOI(Me.m_sCheminFichierXL, Me.m_msgDelegue) ElseIf Me.m_iTypeConv = TypeConv.XL2CsvSSG Then bOk = bConvertirXLRapideSSG(Me.m_sCheminFichierXL, Me.m_msgDelegue) ' 09/08/2012 ElseIf Me.m_iTypeConv = TypeConv.XL2CsvAutomation Then bOk = bConvertirXLAutomation(Me.m_sCheminFichierXL, Me.m_msgDelegue) 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 ' CA1009 'Private Sub m_oODBC_EvAfficherMessage(ByVal sMsg$) _ ' Handles m_oODBC.EvAfficherMessage ' AfficherMessage(sMsg) 'End Sub Private Sub m_oODBC_EvAfficherMessage(ByVal sender As Object, ByVal e As clsMsgEventArgs) _ Handles m_oODBC.EvAfficherMessage AfficherMessage(e.sMessage) End Sub Private Sub chkODBC_CheckedChanged(ByVal sender As Object, ByVal e As EventArgs) _ Handles chkODBC.CheckedChanged If Me.chkODBC.Checked Then clsODBC.VerifierConfigODBCExcel() End If 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.XL2CsvNPOI Then bConvertirXLRapideNPOI(Me.m_sCheminFichierXL, Me.m_msgDelegue) ElseIf Me.m_iTypeConv = TypeConv.XL2CsvSSG Then bConvertirXLRapideSSG(Me.m_sCheminFichierXL, Me.m_msgDelegue) ' 09/08/2012 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 ! ' 11/03/2012 bEcriture:=False : Non ! si on veut aller vite ' ne pas permettre qu'Excel soit ouvert, même ici If Not bFichierAccessibleMultiTest(Me.m_sCheminFichierXL, Me.m_msgDelegue) Then _ Return False 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 Return False 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 champs afin d'avoir toutes les entetes ' 08/08/2012 Ssi 2 passes ! (XL2CsvGroup) Dim iNbPasses% = 1 Dim b2Passes As Boolean = False If Me.m_iTypeConv = TypeConv.XL2CsvGroup Then b2Passes = True : iNbPasses = 2 Dim sCheminFichier$ = "" Dim iNbTables% = Me.m_oODBC.m_alTables.Count Dim iPasse% For iPasse = 0 To iNbPasses - 1 ' 2 Passes iNumTable = 0 For Each sTable In Me.m_oODBC.m_alTables If b2Passes Then Dim bTableMax As Boolean = False If Me.m_oODBC.m_aiNbChamps(iNumTable) = iNbChpsMax Then bTableMax = True If iPasse = 0 And Not bTableMax Then GoTo TableSuivante If iPasse = 1 And bTableMax Then GoTo TableSuivante End If 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 Return False ' 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" ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sCheminFichier0, sbContenu, bEncodageUTF8:=True) 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" ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sCheminFichier0, sbContenu, bEncodageUTF8:=True) 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 Return False 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 ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sCheminFichier, sbContenu, bEncodageUTF8:=True) 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, m_sTitreMsg) Else If sCheminFichier.Length = 0 Then ' 21/02/2009 Dim sInfo$ = "Le classeur est vide !" & vbCrLf & Me.m_sCheminFichierXL MsgBox(sInfo, MsgBoxStyle.Information, m_sTitreMsg) Else ProposerOuvrirFichier(sCheminFichier) End If End If Exit Function Erreur: AfficherMessage("Erreur !") Return False 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 ' On ne peut plus associer un menu avec .xls ni .xlsx ?! ' On associe tous les fichiers (*) avec XL2Csv alors Dim sType$ = sMenuCtx_TypeFichierSelect AjouterMenuCtx(sType) If sType <> sMenuCtx_TypeFichierTous Then 'If bExcel2007SupportNPOI Then _ If bExcel2007SupportSSG AndAlso Me.chkXL2CsvSSG.Checked Then _ AjouterMenuCtx(sMenuCtx_TypeFichierExcel2007) End If End Sub Private Sub cmdEnleverMenuCtx_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdEnleverMenuCtx.Click Dim sType$ = sMenuCtx_TypeFichierSelect EnleverMenuCtx(sType) If sType <> sMenuCtx_TypeFichierTous Then 'If bExcel2007SupportNPOI Then _ If bExcel2007SupportSSG AndAlso Me.chkXL2CsvSSG.Checked Then _ EnleverMenuCtx(sMenuCtx_TypeFichierExcel2007) End If End Sub Private Sub AjouterMenuCtx(ByVal sTypeFichierExcel$) 'Optional ByVal bExcel2007 As Boolean = False) Dim sCheminExe$ = Application.ExecutablePath Const bPrompt As Boolean = False Const sChemin$ = """%1""" ' Ajouter un pointeur HKCR\.xls vers HKCR\XL2Csv 'bAjouterTypeFichier(sMenuCtx_ExtFichierIdx, sMenuCtx_TypeFichierIdx, _ ' sMenuCtx_ExtFichierIdxDescription) If Me.chkXL2CsvSSG.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvSSG, _ bPrompt, , sMenuCtx_CleCmdConvertirEnCsvSSGDescription, sCheminExe, _ sChemin & " " & sXL2CsvSSG) 'If bExcel2007 Then Exit Sub If Me.chkXL2CsvNPOI.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvNPOI, _ bPrompt, , sMenuCtx_CleCmdConvertirEnCsvNPOIDescription, sCheminExe, _ sChemin & " " & sXL2CsvNPOI) If Me.chkXL2Csv.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsv, _ bPrompt, , sMenuCtx_CleCmdConvertirEnCsvDescription, sCheminExe, _ sChemin) ' & " " & sXL2Csv : Par défaut If Me.chkFusionCsv.Checked Then If bAjouterMenuContextuel(sTypeFichierExcel, 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(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnTxt, _ bPrompt, , sMenuCtx_CleCmdConvertirEnTxtDescription, sCheminExe, _ sChemin & " " & sXL2Txt) If Me.chkODBC.Checked Then If bAjouterMenuContextuel(sTypeFichierExcel, 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(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvAutomation, _ bPrompt, , sMenuCtx_CleCmdConvertirEnCsvAutomationDescription, sCheminExe, _ sChemin & " " & sXL2CsvAutomation) VerifierMenuCtx(sTypeFichierExcel) End Sub Private Sub EnleverMenuCtx(ByVal sTypeFichierExcel$) 'Optional ByVal bExcel2007 As Boolean = False) If Me.chkXL2CsvSSG.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvSSG, _ bEnlever:=True, bPrompt:=False) 'If bExcel2007 Then Exit Sub If Me.chkXL2CsvNPOI.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvNPOI, _ bEnlever:=True, bPrompt:=False) If Me.chkXL2Csv.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsv, _ bEnlever:=True, bPrompt:=False) If Me.chkFusionCsv.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEn1Csv, _ bEnlever:=True, bPrompt:=False) If Me.chkTexte.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnTxt, _ bEnlever:=True, bPrompt:=False) If Me.chkODBC.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvODBC, _ bEnlever:=True, bPrompt:=False) If Me.chkAutomation.Checked Then _ bAjouterMenuContextuel(sTypeFichierExcel, sMenuCtx_CleCmdConvertirEnCsvAutomation, _ bEnlever:=True, bPrompt:=False) VerifierMenuCtx(sTypeFichierExcel) End Sub Private Sub VerifierMenuCtx(sTypeFichierExcel$) Const sShell$ = "\shell\" Dim sCleDescriptionCmd$ = sTypeFichierExcel & sShell & _ sMenuCtx_CleCmdConvertirEnCsv Dim bCleXL2Csv As Boolean = bCleRegistreCRExiste(sCleDescriptionCmd) Dim sCleDescriptionCmdNPOI$ = sTypeFichierExcel & sShell & _ sMenuCtx_CleCmdConvertirEnCsvNPOI Dim bCleXL2CsvNPOI As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdNPOI) Dim sCleDescriptionCmdSSG$ = sTypeFichierExcel & sShell & _ sMenuCtx_CleCmdConvertirEnCsvSSG Dim bCleXL2CsvSSG As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdSSG) Dim sCleDescriptionCmdFusion$ = sTypeFichierExcel & sShell & _ sMenuCtx_CleCmdConvertirEn1Csv Dim bCleFusion As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdFusion) Dim sCleDescriptionCmdAutomation$ = sTypeFichierExcel & sShell & _ sMenuCtx_CleCmdConvertirEnCsvAutomation Dim bCleAutom As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdAutomation) Dim sCleDescriptionCmdODBC$ = sTypeFichierExcel & sShell & _ sMenuCtx_CleCmdConvertirEnCsvODBC Dim bCleODBC As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdODBC) Dim sCleDescriptionCmdTxt$ = sTypeFichierExcel & sShell & _ sMenuCtx_CleCmdConvertirEnTxt Dim bCleTxt As Boolean = bCleRegistreCRExiste(sCleDescriptionCmdTxt) If bCleXL2Csv OrElse bCleXL2CsvNPOI OrElse bCleXL2CsvSSG OrElse _ bCleFusion OrElse bCleAutom OrElse bCleODBC OrElse bCleTxt Then Me.cmdAjouterMenuCtx.Enabled = False Me.cmdEnleverMenuCtx.Enabled = True Me.chkXL2Csv.Checked = bCleXL2Csv Me.chkXL2CsvNPOI.Checked = bCleXL2CsvNPOI Me.chkXL2CsvSSG.Checked = bCleXL2CsvSSG 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.chkXL2CsvNPOI.Enabled = False Me.chkXL2CsvSSG.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.chkXL2CsvNPOI.Enabled = True Me.chkXL2CsvSSG.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 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) bConvertirXLAutomation = False If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Return False 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 Return False 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 ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sChemin, sb, bEncodageUTF8:=True) Then Return False 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, m_sTitreMsg) Catch ex As Exception AfficherMsgErreur2(ex, "bConvertirXLAutomation", _ "Impossible de lire le document :" & vbLf & _ sCheminFichierXL, sMsgErrCausePoss) bConvertirXLAutomation = False 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 '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) 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 bLireCellulesXLAutomation = False If Not bFichierExiste(sCheminFichierXL, bPrompt:=True) Then Return False If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Return False 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) Return False 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 bLireCellulesXLCouleurs = False 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 iColPlage = 0 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 iLignePlage = 0 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 modExcelLibrary.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 modExcelLibrary #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 bConvertirXLRapide = False ' 11/03/2012 bEcriture:=False : Non ne marche pas ! 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 For Each sheet As Worksheet 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$ = sheet.Name Dim sFeuilleDos$ = sConvNomDos(sFeuille) ' Excel en csv ignore la 1ère ligne, mais ici on va la garder : + stable Dim iNumLigne% = 0 'worksheet.Cells.FirstRowIndex Dim iNbCol% = sheet.Cells.LastColIndex + 1 Dim iNbLignes% = sheet.Cells.LastRowIndex Do While iNumLigne <= iNbLignes If iNumLigne = 1 Or iNumLigne = iNbLignes Or iNumLigne Mod 1000 = 0 Then msgDelegue.AfficherMsg( _ "Feuille n°" & iFeuille & "/" & iNbFeuilles & _ " : Ligne n°" & iNumLigne & "/" & iNbLignes & _ " : Lecture en cours...") If msgDelegue.m_bAnnuler Then Exit Function End If Dim row0 As ExcelLibrary.SpreadSheet.Row = sheet.Cells.GetRow(iNumLigne) 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 Dim j% 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 ' Colonnes If bAuMoinsUneValLigne Then ' Retirer les ; à la fin sbTmp.Length = iLongUtile sbTmp2.Append(sbTmp) iLongUtile2 = sbTmp2.Length End If FinLigne: iNumLigne += 1 sbTmp2.Append(vbCrLf) Loop ' Lignes 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 ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sChemin, sb, bEncodageUTF8:=True) Then Exit Function iNbFichiersCsvGeneres += 1 sDernierCheminCsv = sChemin Next sheet '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, m_sTitreMsg) End If bConvertirXLRapide = True 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 bConvertirXL2Txt = False ' 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 ' 11/03/2012 bEcriture:=False : Non ne marche pas ! 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, m_sTitreMsg) Else Dim sChemin$ = sCheminDossierXL & "\" & _ IO.Path.GetFileNameWithoutExtension(sCheminFichierXL) & ".txt" ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sChemin, sb, bEncodageUTF8:=True) 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 #Region "Fonction utilitaires ExcelLibrary" Private Const sTypeErrorCode$ = "ExcelLibrary.BinaryFileFormat.ErrorCode" Private Const iAnneeNulleExcel% = 1899 Private Const iAnneeMinExcel% = 1945 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 modExcelNPOI.vb ' NPOI : the .Net port of Apache POI : POIFS ('Poor Obfuscation Implementation' File System) ' Librairie pour lire les fichiers MS-Office <= 2003 et ' prochainement Office 2007 (version 1.3 pour Excel 2007) ' http://npoi.codeplex.com 1.2.4 02/11/2011 ' Version pré-release 1.2.5 21/02/2012 svn r309 donnée dans : ' http://www.codeproject.com/Articles/322469/Extract-Excel-2003-Workbooks-using-NPOI-or-COMInte ' http://code.google.com/p/npoi 1.2.4 02/11/2011 (ne marche pas avec cette src !) ' http://poi.apache.org 3.7 29/10/2010 ' Le bug SecID d'ExcelLibrary n'existe pas ici ' Le commentaire des cellules peut être extrait aussi : Dim sComment$ = GetComment(cell) ' Le format de la cellule est respecté : Avantage par rapport à ExcelLib. ' mais si on ne peut pas désactiver cette possibilité, alors comment ' faire pour récupérer le max. de précision sur les cellules ? ' (en ignorant le format d'affichage) Imports NPOI.HSSF.UserModel Imports NPOI.POIFS.FileSystem ' Pour POIFSFileSystem Imports NPOI.SS.UserModel Imports System.Text ' Pour StringBuilder Module modExcelNPOI #Region "XL2Csv" Public Function bConvertirXLRapideNPOI(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 NPOI bConvertirXLRapideNPOI = False Const bSupprimerPtVirgALaFinDesLignes As Boolean = True ' 11/03/2012 bEcriture:=False : Non ne marche pas ! If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Exit Function Dim sCheminDossierXL$ = IO.Path.GetDirectoryName(sCheminFichierXL) Dim iNbFichiersCsvGeneres% = 0 Dim sDernierCheminCsv$ = "" Try Sablier() msgDelegue.AfficherMsg(sMsgOuvertureClasseur) Using inp As New System.IO.StreamReader(sCheminFichierXL) Dim workbook As New HSSFWorkbook(New POIFSFileSystem(inp.BaseStream)) If IsNothing(workbook) Then msgDelegue.AfficherMsg(String.Format( _ "Impossible d'ouvrir le classeur Excel '{0}' !", sCheminFichierXL)) '"Excel Workbook '{0}' could not be opened.", sCheminFichierXL)) Exit Function End If Dim formulaEvaluator As New HSSFFormulaEvaluator(workbook) 'Const sCulture$ = "fr-FR" '"en-US" 'Dim sCulture$ = System.Globalization.CultureInfo.CurrentCulture.Name Dim dataFormatter As New HSSFDataFormatter( _ System.Globalization.CultureInfo.CurrentCulture) 'New System.Globalization.CultureInfo(System.Threading.Thread.CurrentCulture.)) Dim iFeuille% = 0 Dim iNbFeuilles% = workbook.NumberOfSheets For Each sheet As ISheet In workbook iFeuille += 1 Dim bAuMoinsUneVal As Boolean = False If IsNothing(sheet) Then Continue For Dim sb As New StringBuilder Dim sbTmp2 As New StringBuilder Dim iLongUtile2% = -1 Dim sFeuille$ = sheet.SheetName Dim sFeuilleDos$ = sConvNomDos(sFeuille) 'Dim iNbCol% = sheet.PhysicalNumberOfRows ' Pas fiable 'Dim iColMaxFeuille% = iTrouverColMaxFeuille(sheet) ' 09/08/2012 0 au lieu de 1, sinon on peut rater la 1ère ligne Dim iNumLigneDep% = 0 'sheet.FirstRowNum Dim iNumLigne% = iNumLigneDep ' i Dim iNbLignes% = sheet.LastRowNum + 1 Do While iNumLigne < iNbLignes '<= iNbLignes If iNumLigne = iNumLigneDep Or iNumLigne = iNbLignes - 1 Or _ iNumLigne Mod 1000 = 0 Then msgDelegue.AfficherMsg( _ "Feuille n°" & iFeuille & "/" & iNbFeuilles & _ " : Ligne n°" & iNumLigne + 1 & "/" & iNbLignes & _ " : Lecture en cours...") If msgDelegue.m_bAnnuler Then Exit Function End If Dim row As IRow = sheet.GetRow(iNumLigne) If IsNothing(row) Then GoTo FinLigne ' 09/08/2012 Const iColMin% = 0 'Dim iColMin% = row.FirstColIndex 'If iColMin = Integer.MaxValue Then GoTo FinLigne Dim iColMax% = row.LastCellNum ' 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 Dim j% 'For j = iNbCol - 1 To iColMin Step -1 For j = iColMax To iColMin Step -1 Dim cell0 As ICell = row.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 ICell = row.GetCell(j) If IsNothing(cell0) Then GoTo Suite 'If iFeuille = 1 And j = 0 And iNumLigne = 4 Then ' Debug.WriteLine("!") 'End If ' GetValue perd les formules avec heure ' Date au format anglais ! (même avec culture FR) Dim sVal$ = GetValue(cell0, dataFormatter, formulaEvaluator) 'Dim sVal$ = sLireValeur(cell0) ' Ne lit pas les dates 'Dim sVal$ = If(IsNullOrWhiteSpace(sValue), "", sValue) 'Debug.WriteLine(sVal) 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(";") If j < iColMax Then sbTmp.Append(";") j += 1 Loop ' Colonnes If bAuMoinsUneValLigne Then ' Retirer les ; à la fin If bSupprimerPtVirgALaFinDesLignes Then sbTmp.Length = iLongUtile End If sbTmp2.Append(sbTmp) iLongUtile2 = sbTmp2.Length End If FinLigne: sbTmp2.Append(vbCrLf) iNumLigne += 1 Loop ' Lignes 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) If bSupprimerPtVirgALaFinDesLignes Then sb.Length = iLongUtile2 + 2 ' +2 pour vbCrLf End If ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sChemin, sb, bEncodageUTF8:=True) Then Exit Function iNbFichiersCsvGeneres += 1 sDernierCheminCsv = sChemin Next sheet End Using msgDelegue.AfficherMsg(sMsgOperationTerminee) If iNbFichiersCsvGeneres = 1 Then Dim sInfo$ = "(via le composant NPOI)" ProposerOuvrirFichier(sDernierCheminCsv, sInfo) Else Dim sInfo$ = "Le classeur :" & vbCrLf & sCheminFichierXL & vbCrLf & _ "a été converti en fichiers csv avec succès !" & vbCrLf & _ "(via le composant NPOI)" MsgBox(sInfo, MsgBoxStyle.Information, m_sTitreMsg) End If bConvertirXLRapideNPOI = True Catch ex As NPOI.POIFS.FileSystem.OfficeXmlFileException Dim ex2 As Exception = ex ' "POI only supports OLE2 Office documents" AfficherMsgErreur2(ex2, "bConvertirXLRapideNPOI", _ "Impossible de lire le document :" & vbLf & sCheminFichierXL, _ "Le support d'Excel 2007 est prévu dans la version 1.3 de NPOI (actuellement 1.2.5)") Catch ex As Exception AfficherMsgErreur2(ex, "bConvertirXLRapideNPOI", _ "Impossible de lire le document :" & vbLf & _ sCheminFichierXL) Finally Sablier(bDesactiver:=True) End Try msgDelegue.AfficherMsg(sMsgOperationTerminee) End Function #End Region Private Function sLireValeur$(ByVal cell As ICell) ' Ok, mais ne lit pas les dates ! (affiche un numérique à la place) If IsNothing(cell) Then Return String.Empty If cell.CellType = CellType.NUMERIC OrElse _ (cell.CellType = CellType.FORMULA AndAlso _ cell.CachedFormulaResultType = CellType.NUMERIC) Then Dim sVal1$ = cell.NumericCellValue.ToString Return sVal1 Else Dim sVal1$ = cell.StringCellValue Return sVal1 End If End Function Private Function GetValue(ByVal cell As ICell, _ ByVal dataFormatter As DataFormatter, _ ByVal formulaEvaluator As IFormulaEvaluator) As String Dim sRet$ = String.Empty If IsNothing(cell) Then Return sRet Try Dim sVal1$ = dataFormatter.FormatCellValue(cell, formulaEvaluator) Const cEsp As Char = " "c 'Const sEsp$ = " " Dim sVal2$ = sVal1.Replace(Microsoft.VisualBasic.ChrW(10), cEsp) Return sVal2 Catch ex As Exception Return sRet End Try End Function 'Private Function iTrouverColMaxFeuille(ByVal sheet As ISheet) As Integer ' Dim iColMax As Integer = 0 ' Dim rowNumber As Integer = sheet.FirstRowNum ' Do While rowNumber <= sheet.LastRowNum ' Dim row As IRow = sheet.GetRow(rowNumber) ' If Not IsNothing(row) AndAlso row.LastCellNum > iColMax Then ' iColMax = row.LastCellNum ' End If ' rowNumber += 1 ' Loop ' 'Do While (sheet.LastRowNum > rowNumber) ' ' Dim row As IRow = sheet.GetRow(rowNumber) ' ' If ((Not Nothing Is row) AndAlso (row.LastCellNum > lastCellNum)) Then ' ' lastCellNum = row.LastCellNum ' ' End If ' ' rowNumber += 1 ' 'Loop ' Return iColMax 'End Function 'Private Function IsNullOrWhiteSpace(ByVal value As String) As Boolean ' If (Not value Is Nothing) Then ' Dim i As Integer ' For i = 0 To value.Length - 1 ' If Not Char.IsWhiteSpace(value.Chars(i)) Then ' Return False ' End If ' Next i ' End If ' Return True 'End Function End Module modExcelSSG.vb ' Pour compiler ce code, ajouter la dll SpreadsheetGear.dll dans le projet ' et mettre cette constant à True ' On peut redistribuer la dll SpreadSheetGear à un client final, mais pas à un site ' de développeurs (donc pas VBFrance/Comment-ça-marche) #Const bSpreadSheetGearRedist = False #If Not bSpreadSheetGearRedist Then Module modExcelSSG Public Const bSpreadSheetGear As Boolean = False Public Function bConvertirXLRapideSSG(ByVal sCheminFichierXL$, _ ByVal msgDelegue As clsMsgDelegue) As Boolean MsgBox("La conversion selon SpreadSheetGear n'est pas activée dans cette version !", _ MsgBoxStyle.Exclamation, m_sTitreMsg) Return False End Function End Module #Else Imports System.Text ' Pour StringBuilder Imports SpreadsheetGear Imports SpreadsheetGear.Advanced.Cells Module modExcelSSG Public const bSpreadSheetGear as boolean = True Public Enum DataTypeValue VideOuErr String_ Date_ Numeric_ Bool_ End Enum Public Function bConvertirXLRapideSSG(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 SpreadSheetGear bConvertirXLRapideSSG = False Const bSupprimerPtVirgALaFinDesLignes As Boolean = True If Not bFichierAccessibleMultiTest(sCheminFichierXL, msgDelegue) Then _ Exit Function Dim sCheminDossierXL$ = System.IO.Path.GetDirectoryName(sCheminFichierXL) Dim iNbFichiersCsvGeneres% = 0 Dim sDernierCheminCsv$ = "" Try Sablier() msgDelegue.AfficherMsg(sMsgOuvertureClasseur) ' Open a workbook into a new workbook set which uses the current culture. Dim workbookSSG As SpreadsheetGear.IWorkbook = _ SpreadsheetGear.Factory.GetWorkbook(sCheminFichierXL, _ Globalization.CultureInfo.CurrentCulture) If IsNothing(workbookSSG) Then msgDelegue.AfficherMsg(String.Format( _ "Impossible d'ouvrir le classeur Excel '{0}' !", sCheminFichierXL)) Exit Function End If Dim iFeuille% = 0 Dim iNbFeuilles% = workbookSSG.Sheets.Count For Each sheet As SpreadsheetGear.IWorksheet In workbookSSG.Worksheets iFeuille += 1 Dim bAuMoinsUneVal As Boolean = False If IsNothing(sheet) Then Continue For Dim sFeuille$ = sheet.Name Dim sFeuilleDos$ = sConvNomDos(sFeuille) ' Limiter le sb à la taille utile (supprimer les lignes vides à la fin) Dim sb As New StringBuilder Dim sbTmp2 As New StringBuilder Dim iLongUtile2% = -1 Dim iNumLigneDep% = 0 ' NPOI : sheet.FirstRowNum Dim iNumLigne% = iNumLigneDep 'Dim iNbLignes% = sheet.LastRowNum + 1 ' NPOI 'Dim iNbLignes0% = sheet.UsedRange.Rows.Count + 1 Dim iNbLignes% = sheet.UsedRange.RowCount + 1 'Dim iNbCol0% = sheet.UsedRange.Columns.Count + 1 Dim iNbCol% = sheet.UsedRange.ColumnCount + 1 'Dim range As IRange = sheet.UsedRange Dim values As IValues = CType(sheet, IValues) Dim range As IRange = sheet.Cells Do While iNumLigne < iNbLignes If iNumLigne = iNumLigneDep Or iNumLigne = iNbLignes - 1 Or _ iNumLigne Mod 1000 = 0 Then msgDelegue.AfficherMsg( _ "Feuille n°" & iFeuille & "/" & iNbFeuilles & _ " : Ligne n°" & iNumLigne + 1 & "/" & iNbLignes & _ " : Lecture en cours...") If msgDelegue.m_bAnnuler Then Exit Function End If Const iColMin% = 0 Dim iColMax% = iNbCol ' Inférieur à 0 signifie ligne vide : Integer.MinValue NPOI '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 Dim j% For j = iNbCol - 1 To iColMin Step -1 Dim cell0 As IValue = values(iNumLigne, j) If IsNothing(cell0) Then Continue For 'Dim cell0 As ICell = row.GetCell(j) ' NPOI 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 IValue = values(iNumLigne, j) If IsNothing(cell0) Then GoTo Suite 'If iFeuille = 1 And j = 0 And iNumLigne = 2 Then ' Debug.WriteLine("!") 'End If ' get the formatted value of a cell Dim sVal$ = range(iNumLigne, j).Text If String.IsNullOrEmpty(sVal) Then GoTo Suite 'Dim typeCell As DataTypeValue = GetValueType(range, iNumLigne, j) 'Dim sVal$ = "" ''If typeCell = DataTypeValue.VideOuErr Then GoTo Suite 'Select Case typeCell 'Case DataTypeValue.VideOuErr : GoTo Suite 'Case DataTypeValue.String_ : sVal = cell0.Text 'Case DataTypeValue.Numeric_ : sVal = cell0.Number.ToString 'Case DataTypeValue.Date_ ' Dim dDate As Date = workbookSSG.NumberToDateTime(cell0.Number) ' sVal = dDate.ToString(sFormatDateFixe) 'Case DataTypeValue.Bool_ : sVal = cell0.Text 'End Select 'Dim sVal$ = cell0.Text 'If String.IsNullOrEmpty(sVal) Then ' sVal = cell0.Number.ToString ' If String.IsNullOrEmpty(sVal) Then GoTo Suite 'End If ' NPOI 'Dim cell0 As ICell = row.GetCell(j) 'If IsNothing(cell0) Then GoTo Suite 'Dim sValue$ = GetValue(cell0, dataFormatter, formulaEvaluator) 'Dim sVal$ = If(IsNullOrWhiteSpace(sValue), "", sValue) 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 ' Colonnes If bAuMoinsUneValLigne Then ' Retirer les ; à la fin If bSupprimerPtVirgALaFinDesLignes Then sbTmp.Length = iLongUtile End If sbTmp2.Append(sbTmp) iLongUtile2 = sbTmp2.Length End If FinLigne: 'Debug.WriteLine(sbTmp2.ToString) sbTmp2.Append(vbCrLf) iNumLigne += 1 Loop ' Lignes 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) If bSupprimerPtVirgALaFinDesLignes Then sb.Length = iLongUtile2 + 2 ' +2 pour vbCrLf End If ' 03/09/2017 Encodage UTF8 If Not bEcrireFichier(sChemin, sb, bEncodageUTF8:=True) Then Exit Function iNbFichiersCsvGeneres += 1 sDernierCheminCsv = sChemin Next msgDelegue.AfficherMsg(sMsgOperationTerminee) If iNbFichiersCsvGeneres = 1 Then Dim sInfo$ = "(via le composant SpreadSheetGear)" ProposerOuvrirFichier(sDernierCheminCsv, sInfo) Else Dim sInfo$ = "Le classeur :" & vbCrLf & sCheminFichierXL & vbCrLf & _ "a été converti en fichiers csv avec succès !" & vbCrLf & _ "(via le composant SpreadSheetGear)" MsgBox(sInfo, MsgBoxStyle.Information, m_sTitreMsg) End If bConvertirXLRapideSSG = True Catch ex As Exception AfficherMsgErreur2(ex, "bConvertirXLRapideSSG", _ "Impossible de lire le document :" & vbLf & _ sCheminFichierXL) Finally Sablier(bDesactiver:=True) End Try msgDelegue.AfficherMsg(sMsgOperationTerminee) End Function 'Private Function sGetFormattedValue$(ByVal range As IRange, ByVal iLigne%, ByVal iCol%) ' Return range(iLigne, iCol).Text 'End Function 'Private Function GetValueType(ByVal range As IRange, ByVal iLigne%, ByVal iCol%) As DataTypeValue ' Select Case range(iLigne, iCol).ValueType ' Case SpreadsheetGear.ValueType.Text ' Return DataTypeValue.String_ ' Exit Select ' Case SpreadsheetGear.ValueType.Number ' If range(iLigne, iCol).NumberFormatType = NumberFormatType.[Date] OrElse _ ' range(iLigne, iCol).NumberFormatType = NumberFormatType.DateTime Then ' Return DataTypeValue.Date_ ' Else ' Return DataTypeValue.Numeric_ ' End If ' Exit Select ' Case SpreadsheetGear.ValueType.Logical ' Return DataTypeValue.Bool_ ' Exit Select ' Case Else ' Return DataTypeValue.VideOuErr ' End Select 'End Function '#Region "Ecritures cellule SSG" 'Private Const rValNull! = -9999 'Private Const rValNullDouble# = -9999 'Private Const iValNull% = -9999 'Private Const lValNull& = -9999 'Private Sub EcrireCelluleSSG(ByVal sheet As SpreadsheetGear.IWorksheet, _ ' ByVal iLigne%, ByVal iCol%, ByVal sVal$) ' sheet.Cells(iLigne - 1, iCol - 1).Value = sVal 'End Sub 'Private Sub EcrireCelluleSSG(ByVal sheet As SpreadsheetGear.IWorksheet, _ ' ByVal iLigne%, ByVal iCol%, ByVal iVal%) ' If iVal = iValNull Then EffacerCelluleSSG(sheet, iLigne, iCol) : Exit Sub ' sheet.Cells(iLigne - 1, iCol - 1).Value = iVal 'End Sub 'Private Sub EcrireCelluleSSG(ByVal sheet As SpreadsheetGear.IWorksheet, _ ' ByVal iLigne%, ByVal iCol%, ByVal rVal As Double, _ ' Optional ByVal bEffacerSiNul As Boolean = True) ' If rVal = rValNullDouble Then ' If bEffacerSiNul Then EffacerCelluleSSG(sheet, iLigne, iCol) ' Exit Sub ' End If ' sheet.Cells(iLigne - 1, iCol - 1).Value = rVal 'End Sub 'Private Sub EcrireCelluleSSG(ByVal sheet As SpreadsheetGear.IWorksheet, _ ' ByVal iLigne%, ByVal iCol%, ByVal dDate As Date) ' If dDate = dDateNulle Then EffacerCelluleSSG(sheet, iLigne, iCol) : Exit Sub ' sheet.Cells(iLigne - 1, iCol - 1).Value = dDate 'End Sub 'Private Sub EffacerCelluleSSG(ByVal sheet As SpreadsheetGear.IWorksheet, _ ' ByVal iLigne%, ByVal iCol%) ' 'sheet.Cells(iLigne - 1, iCol - 1).ClearContents() 'End Sub '#End Region End Module #End If 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) bFichierAccessibleMultiTest = False ' 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, m_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 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 clsAfficherMsg.vb ' Fichier clsAfficherMsg.vb : Classes de gestion des messages via des délégués ' ------------------------- Imports System.IO 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(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(iNumFichierEnCours%) Me.m_iNumFichierEnCours = iNumFichierEnCours End Sub Public ReadOnly Property iNumFichierEnCours%() Get Return Me.m_iNumFichierEnCours End Get End Property End Class Public Class clsFSIEventArgs : Inherits EventArgs ' Classe pour l'événement FileSystemInfo Private m_fsi As FileSystemInfo Public ReadOnly Property fsi() As FileSystemInfo Get Return Me.m_fsi End Get End Property Public Sub New(fsi As FileSystemInfo) Me.m_fsi = fsi End Sub End Class Public Class clsAvancementEventArgs : Inherits EventArgs ' Classe pour l'événement Avancement Private m_sMsg$ = "" Private m_lAvancement& = 0 Public Sub New(sMsg$) If sMsg Is Nothing Then sMsg = "" Me.m_sMsg = sMsg End Sub Public Sub New(lAvancement&) Me.m_lAvancement = lAvancement End Sub Public Sub New(lAvancement&, 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(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(sender As Object, e As clsTickEventArgs) Public Event EvTick As GestEvTick Public Delegate Sub GestEvAfficherMessage(sender As Object, e As clsMsgEventArgs) Public Event EvAfficherMessage As GestEvAfficherMessage Public Delegate Sub GestEvAfficherFEC(sender As Object, e As clsFECEventArgs) Public Event EvAfficherNumFichierEnCours As GestEvAfficherFEC Public Delegate Sub GestEvAfficherFSI(sender As Object, e As clsFSIEventArgs) Public Event EvAfficherFSIEnCours As GestEvAfficherFSI Public Delegate Sub GestEvAfficherAvancement(sender As Object, e As clsAvancementEventArgs) Public Event EvAfficherAvancement As GestEvAfficherAvancement Public Delegate Sub GestEvSablier(sender As Object, e As clsSablierEventArgs) Public Event EvSablier As GestEvSablier Public m_bAnnuler As Boolean Public Sub New() End Sub Public Sub AfficherMsg(sMsg$) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvAfficherMessage(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFichierEnCours(iNumFichierEnCours%) Dim e As New clsFECEventArgs(iNumFichierEnCours) RaiseEvent EvAfficherNumFichierEnCours(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherFSIEnCours(fsi As FileSystemInfo) Dim e As New clsFSIEventArgs(fsi) RaiseEvent EvAfficherFSIEnCours(Me, e) TraiterMsgSysteme_DoEvents() End Sub Public Sub AfficherAvancement(lAvancement&, 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 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 Return False ' 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 Return False 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é." Return False 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 Return Not monProc.HasExited() Catch 'ex As Exception ' On vient juste de fermer Return False 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 Return True Next j Return False 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 Return False Try Return Not Process.GetProcessById(Me.m_iIdProcess).HasExited() Catch 'ex As Exception ' On vient juste de fermer Return False 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$) ' CA1009 Public Delegate Sub GestEvAfficherMessage(sender As Object, e As clsMsgEventArgs) Public Event EvAfficherMessage As GestEvAfficherMessage ' 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 ' CA1009 'RaiseEvent EvAfficherMessage(sMsg) Dim e As New clsMsgEventArgs(sMsg) RaiseEvent EvAfficherMessage(Me, e) 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, m_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, m_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, m_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, m_sTitreMsg) Else MsgBox(sMsg, MsgBoxStyle.Critical, m_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 Return False 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 Return False If Not bVerifierCheminODBC("DBQ=", sContenuDSN) Then Return False If Not bVerifierCheminODBC("Database=", sContenuDSN) Then Return False If Not bVerifierCheminODBC("Dbf=", sContenuDSN) Then Return False If Not bVerifierCheminODBC("SourceDB=", sContenuDSN) Then Return False ' Vérification des dossiers aussi If Not bVerifierCheminODBC("DefaultDir=", sContenuDSN, _ bDossier:=True) Then Return False If Not bVerifierCheminODBC("PPath=", sContenuDSN, _ bDossier:=True) Then Return False 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, m_sTitreMsg) : Return False ' 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 _ Return False 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 Return True Return False 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 !") Return False 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 !") Return False 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, m_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 !") Return False 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) Return False 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 !") Return False 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, m_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 _ Return False 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 _ Return False 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 _ Return False 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 _ Return False 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 _ Return False 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, m_sTitreMsg) Return False End If Return 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 Return False ' 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 Return False If Not bEcrireFichier(sCheminSQL, sSQL) Then Return False 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, m_sTitreMsg) Return 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, m_sTitreMsg) Return False 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 Return True 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 Return True End If End If bVerifierCheminODBC = True If sCheminBd.Length > 0 Then If bDossier Then Return bDossierExiste(sCheminBd, bPrompt:=True) Else Return 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 modUtilFichier.vb ' Fichier modUtilFichier.vb : Module de gestion des fichiers ' ------------------------- Imports System.Text ' Pour StringBuilder 'Imports System.IO ' Pour Path, File, Directory... Public 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$, sFiltre$, sExtDef$, _ ' sTitre$, Optional sInitDir$ = "", _ ' Optional bDoitExister As Boolean = True, _ ' Optional 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 sCheminFichier = .FileName : Return True ' Return False ' End With 'End Function Public Function bFichierExiste(sCheminFichier$, _ Optional 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 Dim bFichierExiste0 As Boolean = IO.File.Exists(sCheminFichier) If Not bFichierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Fichier introuvable") Return bFichierExiste0 End Function Public Function bFichierExisteFiltre(sCheminFiltre$, sFiltre$, _ Optional 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 bFichierExisteFiltre0 As Boolean Dim di As New IO.DirectoryInfo(sCheminFiltre) If Not di.Exists Then bFichierExisteFiltre0 = False : GoTo Fin Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre0 = (iNbFichiers > 0) Fin: If Not bFichierExisteFiltre0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Fichiers introuvables") Return bFichierExisteFiltre0 End Function Public Function bFichierExisteFiltre2(sCheminFiltre$, _ Optional 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 Return False 'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre) Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre) Return bFichierExisteFiltre(sDossier, sFiltre, bPrompt) End Function Public Function iNbFichiersFiltres%(sCheminDossier$, 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 Return 0 Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo Return fi.GetLength(0) End Function Public Function bTrouverFichier(sChemin$, sFiltre$, ByRef sCheminFichierTrouve$, _ Optional bPromptErr As Boolean = True) As Boolean ' Renvoyer le premier fichier correspondant au filtre sCheminFichierTrouve = "" If Not bDossierExiste(sChemin, bPromptErr) Then Return False Dim di As New IO.DirectoryInfo(sChemin) For Each fi As IO.FileInfo In di.GetFiles(sFiltre) sCheminFichierTrouve = sChemin & "\" & fi.Name Return True Next Return False End Function Public Function bCopierFichier(sCheminSrc$, sCheminDest$, _ Optional bPromptErr As Boolean = True, _ Optional bVerifierDate As Boolean = False) As Boolean If bVerifierDate Then If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then Return False 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 Return True ' Sinon supprimer le fichier de destination If Not bSupprimerFichier(sCheminDest) Then Return False End If End If If Not bFichierExiste(sCheminSrc, bPromptErr) Then Return False 'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Return False 'End If Try ' Cette fonction vient du kernel32.dll : rien à optimiser IO.File.Copy(sCheminSrc, sCheminDest) Return 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) Return False End Try End Function Public Function bCopierFichiers(sCheminSrc$, sFiltre$, sCheminDest$, _ Optional bPromptErr As Boolean = True) As Boolean ' Copier tous les fichiers correspondants au filtre dans le répertoire de destination If Not bDossierExiste(sCheminSrc, bPromptErr) Then Return False If Not bDossierExiste(sCheminDest, bPromptErr) Then Return False Dim di As New IO.DirectoryInfo(sCheminSrc) For Each fi As IO.FileInfo In di.GetFiles(sFiltre) Dim sFichier$ = fi.Name Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier If Not bCopierFichier(sSrc, sDest, bPromptErr) Then Return False Next Return True End Function Public Function bSupprimerFichier(sCheminFichier$, _ Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then Return True If Not bFichierAccessible(sCheminFichier, _ bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then Return False ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "Impossible de supprimer le fichier :" & vbLf & sCheminFichier, sCauseErrPoss) 'If bPromptErr Then _ ' MsgBox("Impossible de supprimer le fichier :" & vbLf & _ ' sCheminFichier & vbLf & _ ' sCauseErrPoss, MsgBoxStyle.Critical, m_sTitreMsg) Return False End Try End Function Public Function bSupprimerFichiersFiltres(sCheminDossier$, sFiltre$, _ Optional 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 Return True Dim asFichier$() = IO.Directory.GetFileSystemEntries(sCheminDossier, sFiltre) For Each sFichier As String In asFichier If Not bSupprimerFichier(sFichier, bPromptErr) Then Return False Next sFichier Return True End Function Public Function bRenommerFichier(sSrc$, sDest$, _ Optional bConserverDest As Boolean = False) As Boolean ' Renommer ou déplacer un et un seul fichier If Not bFichierExiste(sSrc, bPrompt:=True) Then Return False 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 Return False Return True End If Else If Not bSupprimerFichier(sDest, bPromptErr:=True) Then Return False End If Try IO.File.Move(sSrc, sDest) Return 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) Return False End Try End Function Public Function bDeplacerFichiers2(sSrc$, 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 Return False Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc) If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Return False Return True End Function Public Function bDeplacerFichiers3(sCheminSrc$, sFiltre$, sCheminDest$, _ Optional bConserverDest As Boolean = True, _ Optional sExtDest$ = "", Optional 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 Return False 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 Return False Next i Return True End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Public Function bFichierAccessible(sCheminFichier$, _ Optional bPrompt As Boolean = False, _ Optional bPromptFermer As Boolean = False, _ Optional bInexistOk As Boolean = False, _ Optional bPromptRetenter As Boolean = False, _ Optional bLectureSeule As Boolean = False, _ Optional 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) Retenter: If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas ' Et ne pas alerter non plus If Not bFichierExiste(sCheminFichier) Then Return True Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Return False End If 'Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Dim fs As IO.FileStream = Nothing 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 fs = New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() fs = Nothing Return 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, m_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, m_sTitreMsg) End If End If Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try If reponse = MsgBoxResult.Retry Then GoTo Retenter Return False End Function ' CA2122 <Security.Permissions.SecurityPermission(Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub ProposerOuvrirFichier(sCheminFichier$, _ Optional sInfo$ = "") If String.IsNullOrEmpty(sCheminFichier) Then Exit Sub 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, m_sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub ' CA2122 <Security.Permissions.SecurityPermission(Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub OuvrirAppliAssociee(sCheminFichier$, _ Optional bMax As Boolean = False, _ Optional bVerifierFichier As Boolean = True, _ Optional sArguments$ = "") 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) p.StartInfo.Arguments = sArguments ' 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$(lTailleOctets&, _ Optional bDetail As Boolean = False, _ Optional 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 sFormaterTailleKOctets$(lTailleOctets&, _ Optional bSupprimerPt0 As Boolean = False) ' Renvoyer une taille de fichier en Ko bien formatée dans une chaîne de caractère ' La méthode d'arrondie est la même que celle de l'explorateur de fichiers de Windows Dim rNbKo! = CSng(Math.Ceiling(lTailleOctets / 1024)) sFormaterTailleKOctets = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko" End Function Public Function sFormaterNumerique$(rVal!, _ Optional bSupprimerPt0 As Boolean = True, _ Optional 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 ' NumberGroupSeparator : Séparateur des milliers, millions... ' NumberDecimalSeparator : Séparateur décimal ' NumberGroupSizes : 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) ' NumberDecimalDigits : 1 décimale de précision Dim nfi As New Globalization.NumberFormatInfo With { .NumberGroupSeparator = " ", .NumberDecimalSeparator = ".", .NumberGroupSizes = New Integer() {3, 3, 3}, .NumberDecimalDigits = iNbDecimales } Dim sFormatage$ = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = 1 Then sFormatage = sFormatage.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormatage = sFormatage.Replace(sb.ToString, "") End If End If Return sFormatage End Function Public Function sFormaterNumerique2$(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(sCheminDossier$, _ Optional 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 Return True Try di.Create() di = New IO.DirectoryInfo(sCheminDossier) Dim bExiste As Boolean = di.Exists Return bExiste Catch ex As Exception 'If bPrompt Then _ ' MsgBox("Impossible de créer le dossier :" & vbCrLf & _ ' sCheminDossier & vbCrLf & ex.Message, _ ' MsgBoxStyle.Critical, m_sTitreMsg) If bPrompt Then _ AfficherMsgErreur2(ex, "bVerifierCreerDossier", _ "Impossible de créer le dossier :" & vbCrLf & sCheminDossier) Return False End Try End Function Public Function bDossierExiste(sCheminDossier$, _ Optional 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() Dim bDossierExiste0 As Boolean = IO.Directory.Exists(sCheminDossier) If Not bDossierExiste0 AndAlso bPrompt Then _ MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, _ MsgBoxStyle.Critical, m_sTitreMsg & " - Dossier introuvable") Return bDossierExiste0 End Function Public Function bRenommerDossier(sCheminDossierSrc$, sCheminDossierDest$) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bDeplacerDossier If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Return False If Not bSupprimerDossier(sCheminDossierDest, bPromptErr:=True) Then Return False Try IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) Return 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) Return False End Try End Function Public Function bDeplacerDossier(sCheminDossierSrc$, sCheminDossierDest$, _ Optional 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 Return False If Not bSupprimerDossier(sCheminDossierDest, bPromptErr) Then Return False Try 'Dim di As New IO.DirectoryInfo(sCheminDossierSrc) 'di.MoveTo(sCheminDossierDest) IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) Return 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) Return False End Try End Function Public Function bSupprimerDossier(sCheminDossier$, _ Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le dossier existe If Not bDossierExiste(sCheminDossier) Then Return True 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, m_sTitreMsg) Return False End If Return True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bSupprimerDossier", _ "Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, sCauseErrPossDossier) Return False End Try End Function Public Function sDossierParent$(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$(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$(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$(sCheminDossierOuFichier$, _ Optional 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$(sCheminFichier$, 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$(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$(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(sSrc$, sDest$, _ ByRef bStatut As Boolean, _ ByRef sListeErr$, Optional 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) Return False 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 Return bStatut End Function Public Function sLecteurDossier$(sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function ' CA2122 <System.Security.Permissions.SecurityPermissionAttribute( _ Security.Permissions.SecurityAction.LinkDemand)> _ Public Sub OuvrirDossier(sCheminDossier$) ' Ouvrir un dossier via l'explorateur de fichiers Dim p As New Process ' Ne marche pas : 'Dim sArg$ = ", /e" ' Explorer le dossier 'p.StartInfo = New ProcessStartInfo(sCheminDossier, sArg) Dim startInfo As New ProcessStartInfo Dim sSysDir$ = Environment.GetFolderPath(Environment.SpecialFolder.System) Dim sWinDir$ = IO.Path.GetDirectoryName(sSysDir) startInfo.FileName = sWinDir & "\explorer.exe" startInfo.Arguments = sCheminDossier & ", /e" p.StartInfo = startInfo p.Start() End Sub #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" Public Function sLireFichier$(sCheminFichier$, _ Optional bLectureSeule As Boolean = False, Optional bUnicodeUTF8 As Boolean = False) ' Lire et renvoyer le contenu d'un fichier Dim s$ = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return s Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Dim fs As IO.FileStream = Nothing Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If ' 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 fs = 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, encodage) fs = Nothing 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 Return sbContenu.ToString Catch ex As Exception AfficherMsgErreur2(ex, "sLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function sbLireFichier(sCheminFichier$, _ Optional bLectureSeule As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier Dim sb As New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return sb Dim bDebut As Boolean = False Dim fs As IO.FileStream = Nothing 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 fs = 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)) fs = Nothing Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sb.Append(vbCrLf) bDebut = True sb.Append(sLigne) Loop While True End Using Return sb Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function asLireFichier(sCheminFichier$, _ Optional bLectureSeule As Boolean = False, _ Optional bVerifierCrCrLf As Boolean = False, _ Optional bUnicodeUTF8 As Boolean = False) As String() ' Lire et renvoyer le contenu d'un fichier Dim astr$() = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Return astr Dim fs As IO.FileStream = Nothing Try Dim encodage As Encoding If bUnicodeUTF8 Then encodage = Encoding.UTF8 Else encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If If bLectureSeule Then fs = New IO.FileStream(sCheminFichier, _ IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, encodage) fs = Nothing ' 23/04/2013 Optimisation du mode bLectureSeule ' On doit enlever les lignes vides dues au double séparateur CrLf 'Return sr.ReadToEnd.Split(vbCrLf.ToCharArray, StringSplitOptions.RemoveEmptyEntries) ' 24/04/2013 Conserver strictement le même comportement de sr.ReadLine() ' en RAM Dim fluxChaine As New clsFluxChaine(sr.ReadToEnd) Return fluxChaine.asLignes(bVerifierCrCrLf) 'Dim lst As New Collections.Generic.List(Of String) 'While Not sr.EndOfStream ' ' A line is defined as a sequence of characters followed by ' ' a line feed ("\n"), a carriage return ("\r"), or ' ' a carriage return immediately followed by a line feed ("\r\n"). ' ' http://msdn.microsoft.com/en-us/library/system.io.streamreader.readline.aspx ' lst.Add(sr.ReadLine()) 'End While 'Return lst.ToArray End Using Else Return IO.File.ReadAllLines(sCheminFichier, encodage) End If Catch ex As Exception AfficherMsgErreur2(ex, "asLireFichier") Return Nothing Finally If fs IsNot Nothing Then fs.Dispose() ' CA2000 End Try End Function Public Function bEcrireFichier(sCheminFichier$, _ sbContenu As StringBuilder, _ Optional bEncodageDefaut As Boolean = False, _ Optional bEncodageISO_8859_1 As Boolean = False, _ Optional bEncodageUTF8 As Boolean = False, _ Optional bEncodageUTF16 As Boolean = False, _ Optional iEncodage% = 0, Optional sEncodage$ = "", _ Optional bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then Return False 'Dim sw As IO.StreamWriter = Nothing Try ' 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 ø Dim encodage As Encoding = Encoding.Default If Not bEncodageDefaut Then If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUTF8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf bEncodageUTF16 Then ' 28/01/2013 encodage = Encoding.Unicode ' = UTF16 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 End If Using sw As New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) sw.Write(sbContenu.ToString()) End Using 'sw.Close() Return 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) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bEcrireFichier(sCheminFichier$, sContenu$, _ Optional bEncodageDefaut As Boolean = False, _ Optional bEncodageISO_8859_1 As Boolean = False, _ Optional bEncodageUFT8 As Boolean = False, _ Optional iEncodage% = 0, Optional sEncodage$ = "", _ Optional bPromptErr As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean If Not bSupprimerFichier(sCheminFichier, bPromptErr:=bPromptErr) Then Return False 'Dim sw As IO.StreamWriter = Nothing Try ' 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 ø Dim encodage As Encoding = Encoding.Default If Not bEncodageDefaut Then 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 End If Using sw As New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) sw.Write(sContenu) End Using 'sw.Close() Return 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 bPromptErr Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(sCheminFichier$, sContenu$, _ Optional 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 Return False '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() Return 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) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(sCheminFichier$, _ sbContenu As StringBuilder) As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Return False '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() Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterFichier", _ "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier) Return False 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bReencoder(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 Return False Dim sb As StringBuilder = sbLireFichier(sCheminFichier) If sb.Length = 0 Then Return False Return bEcrireFichier(sCheminFichier, sb.Append(vbCrLf)) End Function #End Region #Region "Divers" Public Function asArgLigneCmd(sLigneCmd$, _ Optional bSupprimerEspaces As Boolean = True) As String() ' Retourner les arguments de la ligne de commande ' 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 ' Réutilisation de cette fonction pour parser les "" : ' -------------------------------------------------- ' Cette fonction ne respecte pas le nombre de colonne, elle parse seulement les "" correctement ' (on pourrait cependant faire une option pour conserver les colonnes vides) ' Cette fonction ne sait pas non plus parser correctement une seconde ouverture de "" entre ; ' tel que : xxx;"x""x";xxx ou "xxx";"x""x";"xxx" ' En dehors des guillemets, le séparateur est l'espace et non le ; ' -------------------------------------------------- Dim asArgs$() = Nothing If String.IsNullOrEmpty(sLigneCmd) Then ReDim asArgs(0) asArgs(0) = "" asArgLigneCmd = asArgs Exit Function End If ' Parser les noms cours : facile 'asArgs = Split(Command, " ") Dim lstArgs As New List(Of String) ' 16/10/2016 Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim sFichier$, sSepar$ Dim sCmd$, iLongCmd%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong As Boolean Dim iCarSuiv% = 1 sCmd = sLigneCmd iLongCmd = Len(sCmd) iDeb = 1 Do bNomLong = False : sSepar = " " ' Chaîne vide : "" Dim s2Car$ = Mid(sCmd, iDeb, 2) If s2Car = sGm & sGm Then bNomLong = True : sSepar = sGm iFin = iDeb + 1 GoTo Suite End If ' Si le premier caractère est un guillement, c'est un nom long Dim sCar$ = Mid(sCmd, iDeb, 1) 'Dim iCar% = Asc(sCar) ' Pour debug If sCar = sGm Then bNomLong = True : sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong AndAlso iDeb2 < iLongCmd Then iDeb2 += 1 ' Gestion chaîne vide iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' 16/10/2016 On tolère que un " peut remplacer un espace iCarSuiv = 1 Dim iFinGM% = InStr(iDeb2 + 1, sCmd, sGm) If iFinGM > 0 AndAlso iFin > 0 AndAlso iFinGM < iFin Then iFin = iFinGM : bNomLong = True : sSepar = sGm : iCarSuiv = 0 End If ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True : iFin = iLongCmd + 1 sFichier = Mid(sCmd, iDeb2, iFin - iDeb2) If bSupprimerEspaces Then sFichier = Trim(sFichier) If sFichier.Length > 0 Then lstArgs.Add(sFichier) If bFin Or iFin = iLongCmd Then Exit Do Suite: iDeb = iFin + iCarSuiv ' 1 ' 16/10/2016 On tolère que un " peut remplacer un espace, plus besoin 'If bNomLong Then iDeb = iFin + 2 If iDeb > iLongCmd Then Exit Do ' 09/10/2014 Gestion chaîne vide Loop asArgs = lstArgs.ToArray() Const iCodeGuillemets% = 34 For iNumArg As Integer = 0 To UBound(asArgs) Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide Dim iLong0% = Len(sArg) If iLong0 = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" Next iNumArg asArgLigneCmd = asArgs End Function Public Function sConvNomDos$(sChaine$, _ Optional bLimit8Car As Boolean = False, _ Optional 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 InStr("òóôõö", sCar) > 0 Then ' 08/05/2013 If bMaj Then sCarDest = "O" Else sCarDest = "o" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ç", sCar) > 0 Then ' 12/06/2015 If bMaj Then sCarDest = "C" Else sCarDest = "c" 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 #Region "Classe Flux Chaine" ' Equivalent de mscorlib.dll: System.IO.StreamReader.ReadLine() As String ' mais pour une chaine : optimisation des flux Public Class clsFluxChaine Private m_iNumLigne% = 0 ' Debug Private m_sChaine$ Private m_iPos% = 0 Private c13 As Char = ChrW(13) ' vbCr Private c10 As Char = ChrW(10) ' vbLf Public Sub New(sChaine$) m_sChaine = sChaine End Sub Public Function asLignes(Optional bVerifierCrCrLf As Boolean = False) As String() Dim lst As New Collections.Generic.List(Of String) Dim iNumLigne2% = 0 Do Dim sLigne$ = StringReadLine(bVerifierCrCrLf) ' 05/02/2014 Ne pas ignorer les lignes vides, et poursuivre 'If String.IsNullOrEmpty(sLigne) Then Exit Do If IsNothing(sLigne) Then sLigne = "" lst.Add(sLigne) iNumLigne2 += 1 Loop While m_iPos < m_sChaine.Length ' 05/02/2014 'Loop While True Return lst.ToArray End Function Public Function StringReadLine$(Optional bVerifierCrCrLf As Boolean = False) If String.IsNullOrEmpty(m_sChaine) Then Return Nothing Dim iLong% = m_sChaine.Length Dim iNum% = m_iPos Do While iNum < iLong Dim ch As Char = m_sChaine.Chars(iNum) Select Case ch Case c13, c10 Dim str As String = m_sChaine.Substring(m_iPos, iNum - m_iPos) m_iPos = iNum + 1 If Not bVerifierCrCrLf Then ' 24/11/2013 If ch = c13 AndAlso m_iPos < iLong AndAlso _ m_sChaine.Chars(m_iPos) = c10 Then m_iPos += 1 Return str End If Dim chSuiv As Char '= m_sChaine.Chars(m_iPos) ' 17/09/2013 Maintenant qu'on fait +2, tester aussi ce cas If m_iPos < iLong Then chSuiv = m_sChaine.Chars(m_iPos) Dim chSuiv2 As Char If m_iPos < iLong - 1 Then chSuiv2 = m_sChaine.Chars(m_iPos + 1) ' 02/08/2013 Il peut arriver 13+13+10 !? If ch = c13 AndAlso m_iPos < iLong - 1 AndAlso _ chSuiv = c13 AndAlso chSuiv2 = c10 Then m_iPos += 2 ElseIf ch = c13 AndAlso m_iPos < iLong AndAlso chSuiv = c10 Then m_iPos += 1 End If 'Debug.WriteLine("L" & m_iNumLigne & ":" & str2) m_iNumLigne += 1 Return str End Select iNum += 1 Loop If iNum > m_iPos Then Dim str2$ = m_sChaine.Substring(m_iPos, (iNum - m_iPos)) m_iPos = iNum 'Debug.WriteLine("L" & m_iNumLigne & ":" & str2) m_iNumLigne += 1 Return str2 End If Return Nothing End Function End Class #End Region 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 Const sDossierShell$ = "shell" Public Const sDossierCmd$ = "command" Public Function bAjouterTypeFichier(sExtension$, sTypeFichier$, _ Optional sDescriptionExtension$ = "", _ Optional bEnlever As Boolean = False) As Boolean ' Ajouter(/Enlever) dans la base de registre un type de fichier ClassesRoot ' pour associer une extension de fichier à 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 Return True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterTypeFichier") Return False End Try End Function Public Function bAjouterMenuContextuel(sTypeFichier$, sCmd$, _ Optional bPrompt As Boolean = True, _ Optional bEnlever As Boolean = False, _ Optional sDescriptionCmd$ = "", _ Optional sCheminExe$ = "", _ Optional sCmdDef$ = """%1""", _ Optional sDescriptionTypeFichier$ = "", _ Optional 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 & "\" & sDossierShell & "\" & 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, m_sTitreMsg) Else If bPrompt Then _ MsgBox("Le type de fichier [" & sTypeFichier & "]" & vbLf & _ "est introuvable dans la base de registre", _ MsgBoxStyle.Information, m_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, m_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, m_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 & "\" & sDossierShell & "\" & sCmd & "\" & sDossierCmd 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, m_sTitreMsg) Return True Catch ex As Exception ' ToDo : bIsAdmin à vérifier AfficherMsgErreur2(ex, "bAjouterMenuContextuel", _ "Cause possible : XL2Csv n'est pas lancé en mode admin.") Return False End Try End Function Public Function bCleRegistreCRExiste(sCle$, _ Optional 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 Return False End Using ' rkCRCle.Close() est automatiquement appelé Return True Catch Return False End Try End Function Public Function bCleRegistreCRExiste(sCle$, 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 Return False ' 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 Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 End Using ' rkCRCle.Close() est automatiquement appelé Return True Catch Return False End Try End Function Public Function bCleRegistreLMExiste(sCle$, _ Optional sSousCle$ = "", _ Optional ByRef sValSousCle$ = "", _ Optional 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 Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 If bEcriture Then oVal = CInt(sNouvValSousCle) rkLMCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord) End If End Using ' rkLMCle.Close() est automatiquement appelé Return True ' On peut lire cette clé, donc elle existe Catch Return False End Try End Function Public Function bCleRegistreCUExiste(sCle$, _ Optional 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 Return False Dim sValSousCle0$ = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle0) Then Return False sValSousCle = sValSousCle0 End Using ' rkCUCle.Close() est automatiquement appelé Return True ' On peut lire cette clé, donc elle existe Catch Return False End Try End Function Public Function asListeSousClesCU(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