ODBCDotNet v1.0.12.*Table des procédures 1 - AssemblyInfo.vb 2 - modDepart.vb 2.1 - Public Sub Depart 2.2 - Public Sub Main 3 - frmODBC.vb 3.1 - Private Function bTestODBC 3.2 - Private Sub AfficherMessage 3.3 - Private Sub cmdAnnuler_Click 3.4 - Private Sub cmdExplorer_Click 3.5 - Private Sub cmdODBC_Click 3.6 - Private Sub frmODBC_Load 3.7 - Private Sub m_oODBC_EvAfficherMessage 4 - clsODBC.vb 4.1 - Private Function bCheminFichierProbable 4.2 - Private Function bCreerFichierDsnODBC 4.3 - Private Function bCreerFichiersDsnEtSQLODBCDefaut 4.4 - Private Sub AfficherErreursADO 4.5 - Private Sub AfficherMessage 4.6 - Private Sub AjouterEntete 4.7 - Private Sub AjouterTemps 4.8 - Private Sub TraiterValChamp 4.9 - Public Function bExplorerSourceODBC 4.10 - Public Function bLireSourceODBC 4.11 - Public Function bLireSQL 4.12 - Public Function bVerifierCheminODBC 4.13 - Public Function sLireNomPiloteODBC$ 4.14 - Public ReadOnly Property bAnnuler 4.15 - Public Shared Sub VerifierConfigODBCExcel 4.16 - Public Sub Annuler 4.17 - Public Sub LibererRessources 4.18 - Public Sub New 4.19 - Public Sub ViderContenuResultat 5 - modUtil.vb 5.1 - Public Function bCleRegistreLMExiste 5.2 - Public Function iConv% 5.3 - Public Function lConv 5.4 - Public Sub AfficherMsgErreur2 5.5 - Public Sub CopierPressePapier 5.6 - Public Sub Sablier 5.7 - Public Sub TraiterMsgSysteme_DoEvents 6 - modUtilFichier.vb 6.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible 6.2 - Public Function asArgLigneCmd 6.3 - Public Function asLireFichier 6.4 - Public Function bAjouterFichier 6.5 - Public Function bAjouterFichier 6.6 - Public Function bChoisirFichier 6.7 - Public Function bCopierArbo 6.8 - Public Function bCopierFichier 6.9 - Public Function bDeplacerDossier 6.10 - Public Function bDeplacerFichiers2 6.11 - Public Function bDeplacerFichiers3 6.12 - Public Function bDossierExiste 6.13 - Public Function bEcrireFichier 6.14 - Public Function bEcrireFichier 6.15 - Public Function bFichierExiste 6.16 - Public Function bFichierExisteFiltre 6.17 - Public Function bFichierExisteFiltre2 6.18 - Public Function bReencoder 6.19 - Public Function bRenommerDossier 6.20 - Public Function bRenommerFichier 6.21 - Public Function bSupprimerDossier 6.22 - Public Function bSupprimerFichier 6.23 - Public Function bSupprimerFichiersFiltres 6.24 - Public Function bVerifierCreerDossier 6.25 - Public Function iNbFichiersFiltres% 6.26 - Public Function sbLireFichier 6.27 - Public Function sCheminRelatif$ 6.28 - Public Function sConvNomDos$ 6.29 - Public Function sDossierParent$ 6.30 - Public Function sEnleverSlashFinal$ 6.31 - Public Function sEnleverSlashInitial$ 6.32 - Public Function sExtraireChemin$ 6.33 - Public Function sFormaterNumerique$ 6.34 - Public Function sFormaterNumerique2$ 6.35 - Public Function sFormaterTailleOctets$ 6.36 - Public Function sLecteurDossier$ 6.37 - Public Function sLireFichier$ 6.38 - Public Function sNomDossierFinal$ 6.39 - Public Function sNomDossierParent$ 6.40 - Public Sub OuvrirAppliAssociee 6.41 - Public Sub ProposerOuvrirFichier AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System.Reflection <Assembly: AssemblyTitle("ODBCDotNet")> <Assembly: AssemblyDescription( _ "ODBCDotNet : Extraire des requêtes ODBC dans un tableau de tableaux de String")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("ODBCDotNet")> <Assembly: AssemblyCopyright("Copyright © 2011 ORS Production")> <Assembly: AssemblyTrademark("ODBCDotNet")> ' Major.Minor.Build : 1.0.12 <Assembly: AssemblyVersion("1.0.12.*")> modDepart.vb ' Fichier modMain.vb ' ------------------ ' ODBCDotNet : Extraire des requêtes ODBC dans un tableau de tableaux de String ' Documentation : ODBCDotNet.html ' http://patrice.dargenton.free.fr/CodesSources/ODBCDotNet.html ' http://patrice.dargenton.free.fr/CodesSources/ODBCDotNet.vbproj.html ' http://www.vbfrance.com/code.aspx?ID=34701 ' 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 11/12/2011 ' Version 1.11 du 13/04/2008 ' 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 Const sTitreMsg$ = "ODBCDotNet" Public ReadOnly sNomAppli$ = My.Application.Info.Title Public ReadOnly sTitreMsg$ = sNomAppli 'Public ReadOnly sVersionAppli$ = My.Application.Info.Version.Major & _ ' "." & My.Application.Info.Version.Minor & _ ' My.Application.Info.Version.Build Public ReadOnly sVersionAppli$ = My.Application.Info.Version.Major & _ "." & My.Application.Info.Version.Build Public Const sDateVersionAppli$ = "11/12/2011" #If DEBUG Then Public Const bDebug As Boolean = True Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bRelease As Boolean = True #End If Public Sub Main() ' S'il n'y a aucune gestion d'erreur, on peut déboguer dans l'IDE ' Sinon, ce n'est pas pratique de retrouver la ligne du bug : ' il faut cocher Thrown dans le menu Debug:Exception... pour les 2 lignes ' (dans ce cas, il peut y avoir beaucoup d'interruptions selon la logique ' de programmation : mieux vaut prévenir les erreurs que de les traiter) ' C'était plus simple avec On Error Goto X, car on pouvait ' désactiver la gestion d'erreur avec une simple constante bTrapErr. If bDebug Then Depart() : Exit Sub ' Attention : En mode Release il faut un Try Catch ici ' (s'il n'y a pas de gestion d'erreur, .Net renvoie un message ' d'erreur équivalent à un plantage complet sans explication) Try Depart() Catch ex As Exception AfficherMsgErreur2(ex, "Départ " & 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 ' 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 Not bFichierExiste(Application.StartupPath & "\ADODB.dll", _ bPrompt:=True) Then Exit Sub Application.Run(New frmODBC) End Sub End Module frmODBC.vb ' Fichier frmODBC.vb ' ------------------ Public Class frmODBC Private WithEvents m_oODBC As New clsODBC Private Sub frmODBC_Load(ByVal sender As Object, ByVal e As EventArgs) _ Handles Me.Load Dim sTxt$ = " " & sVersionAppli & " (" & sDateVersionAppli & ")" If bDebug Then sTxt &= " - Debug" Me.Text &= sTxt End Sub Private Sub cmdODBC_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdODBC.Click Me.cmdAnnuler.Enabled = True Me.cmdODBC.Enabled = False Me.cmdExplorer.Enabled = False bTestODBC(bExplorer:=False) Me.cmdODBC.Enabled = True Me.cmdExplorer.Enabled = True Me.cmdAnnuler.Enabled = False End Sub Private Sub cmdExplorer_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdExplorer.Click Me.cmdAnnuler.Enabled = True Me.cmdODBC.Enabled = False Me.cmdExplorer.Enabled = False bTestODBC(bExplorer:=True) Me.cmdODBC.Enabled = True Me.cmdExplorer.Enabled = True Me.cmdAnnuler.Enabled = False End Sub Private Sub AfficherMessage(ByVal sMsg$) Me.sbStatusBar.Text = sMsg Application.DoEvents() End Sub Private Sub m_oODBC_EvAfficherMessage(ByVal sMsg$) _ Handles m_oODBC.EvAfficherMessage AfficherMessage(sMsg) End Sub Private Sub cmdAnnuler_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles cmdAnnuler.Click Me.m_oODBC.Annuler() End Sub Private Function bTestODBC(ByVal bExplorer As Boolean) As Boolean ' Vider le contenu de debug entre chaque appel 'Me.m_oODBC.ViderContenuResultat() Me.m_oODBC.LibererRessources() ' Plus complet ' Mode de lecture via ADODB.GetString de toutes les lignes en une seule instruction ' (on n'a plus alors l'affichage de l'avancement en cours) 'Me.m_oODBC.m_bLireToutDUnBloc = True ' Même chose mais sans traiter les données : elles sont renvoyées en brut ' (attention aux dates, aux champs nuls, ... : vérifier la différence) 'Me.m_oODBC.m_bLireToutDUnBlocRapide = True Me.m_oODBC.m_bVerifierFichierSourceDonnees = True ' Maintenant la vérification est automatique si DSN Excel 'Me.m_oODBC.VerifierConfigODBCExcel() ' Ne pas afficher de msg : on va proposer directement de consulter le contenu Me.m_oODBC.m_bCopierDonneesPressePapier = False Me.m_oODBC.m_bPrompt = False Const sDossierSrcODBC$ = "\SourcesODBC" Const sFichierDsn$ = "SourceODBC.dsn" Const sFichierSQL$ = "SourceODBC.sql" Const sSourceExcelDef$ = "\SourceODBC_MSExcel\XLDB.xls" Const sListeSQLExcelDef$ = _ "Select * From [Article$];" & _ "Select * From [Famille$];" & _ "Select [Famille$].Famille, [Article$].*" & _ " FROM [Famille$] INNER JOIN [Article$]" & _ " ON [Famille$].CodeFamille = [Article$].CodeFamille;" Dim aiNbChampsAttendusSQL%() = {4, 2, 5} ' 4 : CodeArticle, Article, CodeFamille et PrixEuros ' 2 : CodeFamille et Famille ' 5 : Famille, CodeArticle, Article, CodeFamille et PrixEuros Dim sCheminSourceODBCXL$ = Application.StartupPath & _ sDossierSrcODBC & sSourceExcelDef Const bTestODBCDirecte As Boolean = False If bTestODBCDirecte Then ' Faire une connexion directe sur le fichier Excel If Not bFichierExiste(sCheminSourceODBCXL, _ bPrompt:=True) Then Exit Function Me.m_oODBC.m_sChaineConnexionDirecte = _ "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & sCheminSourceODBCXL & ";" & _ "Extended Properties=""Excel 8.0;"";" Me.m_oODBC.m_sListeSQL = sListeSQLExcelDef Else Me.m_oODBC.m_sCheminDSN = Application.StartupPath & _ sDossierSrcODBC & "\" & sFichierDsn Me.m_oODBC.m_sCheminSQL = Application.StartupPath & _ sDossierSrcODBC & "\" & sFichierSQL Me.m_oODBC.m_sCheminSrcExcel = sCheminSourceODBCXL Me.m_oODBC.m_sSQLExcelDef = sListeSQLExcelDef ' Test Excel en écriture 'Me.m_oODBC.m_bModeEcriture = True 'Me.m_oODBC.m_sSQLExcelDef = _ ' "UPDATE [Article$] SET [Article] = [Article] & '_T';" & _ ' "INSERT INTO [Article$] ([Article]) SELECT 'TestInsertion';" 'Delete * From [Article$] : n'est pas supporté par le pilote ODBC Excel ' Test Navision 'Me.m_oODBC.m_sCompteUtilisateur = "MonCompteUtilisateur" 'Me.m_oODBC.m_sMotDePasse = "MonMotDePasse" 'Me.m_oODBC.m_sCompteSociete = "MonCompteSociete" 'Me.m_oODBC.m_sNomServeur = "MonServeur" 'Me.m_oODBC.m_sSQLNavisionDef = "Select * From Item;" ' Test DB2 ' 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. ' (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) 'Me.m_oODBC.m_sCompteUtilisateur = "MonCompteUtilisateur" 'Me.m_oODBC.m_sCompteSociete = "MonCompteSociete" 'Me.m_oODBC.m_sNomServeur = "MonServeur" 'Me.m_oODBC.m_sSQLDB2Def = "Select * From Item;" '' DBQ ne correspond pas un fichier sur le disque, ne pas vérifier sa présence 'Me.m_oODBC.m_bVerifierFichierSourceDonnees = False ' Test Access 'Dim sCheminSourceODBCAccess$ = Application.StartupPath & _ ' sDossierSrcODBC & "\SourceODBC_MSAccess\Access.mdb" 'Me.m_oODBC.m_sCheminSrcAccess = sCheminSourceODBCAccess 'Me.m_oODBC.m_sSQLAccessDef = "Select * From Article;" ' Test Omnis 'Me.m_oODBC.m_sCheminSrcOmnis = Application.StartupPath & _ ' sDossierSrcODBC & "\SourceODBC_Omnis\BdOmnis.df1" 'Me.m_oODBC.m_sSQLOmnisDef = "Select * From Article;" 'Me.m_oODBC.m_sCompteUtilisateur = "MonCompteUtilisateur" 'Me.m_oODBC.m_sMotDePasse = "MonMotDePasse" End If If bExplorer Then Dim sTableAExplorer$ = tbTable.Text Const bExplorerChamps As Boolean = True If Not Me.m_oODBC.bExplorerSourceODBC( _ bExplorerChamps, sTableAExplorer, _ bRenvoyerContenu:=True) Then _ Exit Function Dim sCheminPlanODBC$ = Application.StartupPath & _ "\PlanSourceODBC.txt" If Not bEcrireFichier(sCheminPlanODBC, Me.m_oODBC.m_sbContenuRetour) Then _ Exit Function ProposerOuvrirFichier(sCheminPlanODBC) 'Dim sTable$ 'Dim sbResultat As New System.Text.StringBuilder 'For Each sTable In Me.m_oODBC.m_alTables ' sbResultat.Append(sTable & vbCrLf) 'Next sTable 'sbResultat.Append(vbCrLf) 'Dim iNumTable% = 0 'For Each sTable In Me.m_oODBC.m_alTables ' sbResultat.Append(sTable & vbCrLf) ' ' Dimension : 1 : NbTables, 2 : NbChamps ' Dim iNbChamps% = UBound(Me.m_oODBC.m_asChamps, 2) + 1 ' Dim i% ' For i = 0 To iNbChamps - 1 ' Dim sChamp$ = Me.m_oODBC.m_asChamps(iNumTable, i) ' ' Le tableau est dimensionné au maximum de champs ' ' trouvés sur la table la plus large ' If IsNothing(sChamp) Then Exit For ' 'sbResultat.Append(sChamp & ";") ' sbResultat.Append(" ").Append(sChamp).Append(vbCrLf) ' Next i ' sbResultat.Append(vbCrLf) ' iNumTable += 1 'Next sTable 'bTestODBC = True 'CopierPressePapier(sbResultat.ToString) 'MsgBox("Exploration de la source de données terminée avec succès ! (cf. presse-papier)", _ ' MsgBoxStyle.Information, sTitreMsg) GoTo Fin End If If Not Me.m_oODBC.bLireSourceODBC(bRenvoyerContenu:=True) Then _ Exit Function Dim sCheminFichier$ = Application.StartupPath & _ "\ContenuODBC.txt" If Not bEcrireFichier(sCheminFichier, Me.m_oODBC.m_sbContenuRetour) Then _ Exit Function ProposerOuvrirFichier(sCheminFichier) 'GoTo Fin ' ' Analyse du ou des tableaux résultats ' Dim asTableau$(,) ' Dim iNbTableaux% = Me.m_oODBC.m_aoMetaTableau.GetUpperBound(0) + 1 ' Dim k% ' For k = 0 To iNbTableaux - 1 ' ' En typage implicite (mode Strict Off), par exemple en mode debug ' ' dans l'IDE, on peut faire directement : ' ' ? (aoMetaTableau(0))(0, 0) ' ' En typage explicite (mode Strict On : programmation beaucoup plus sûre), ' ' il faut préciser explicitement que l'objet est un tableau 2D de String ' ' ? (CType(aoMetaTableau(0), String(,)))(0, 0) ' asTableau = CType(Me.m_oODBC.m_aoMetaTableau(k), String(,)) ' If IsNothing(asTableau) Then GoTo TableauSuivant ' Dim iNbColonnes% = asTableau.GetUpperBound(0) + 1 ' Dim iNbLignes% = asTableau.GetUpperBound(1) + 1 ' If aiNbChampsAttendusSQL.GetUpperBound(0) >= k AndAlso _ ' iNbColonnes <> aiNbChampsAttendusSQL(k) Then ' MsgBox("La source ODBC ne contient pas le nombre de champs attendus :" & vbLf & _ ' iNbColonnes & " <> " & aiNbChampsAttendusSQL(k), _ ' MsgBoxStyle.Exclamation) ' End If ' AfficherMessage("Analyse des données en cours... : " & _ ' k + 1 & "/" & iNbTableaux) ' Dim i%, j%, sVal$ ' Dim sCodeArticle$, sArticle$, sCodeFamille$, sFamille$ ' Dim sPrixEuros$ ' For j = 0 To iNbLignes - 1 ' If j Mod 1000 = 0 Then ' Dim sAvancement$ = _ ' "Analyse des données en cours... : " & _ ' k + 1 & "/" & iNbTableaux & " : enreg. n°" & _ ' j + 1 & "/" & iNbLignes ' AfficherMessage(sAvancement) ' ' Interrompre l'analyse en cours ' If Me.m_oODBC.bAnnuler Then GoTo Fin ' End If ' sCodeArticle = "" : sArticle = "" ' sCodeFamille = "" : sFamille = "" ' sPrixEuros = "" ' For i = 0 To iNbColonnes - 1 ' sVal = asTableau(i, j) ' ' Corrigé : Rq sans enreg. : 1 ligne en fait ' 'If IsNothing(sVal) Then Exit For ' Select Case k ' Case 0 ' 1ère requête ' Select Case i ' Case 0 : sCodeArticle = sVal ' Case 1 : sArticle = sVal ' Case 2 : sCodeFamille = sVal ' Case 3 : sPrixEuros = sVal ' End Select ' Case 1 ' 2ème requête ' Select Case i ' Case 0 : sCodeFamille = sVal ' Case 1 : sFamille = sVal ' End Select ' Case 2 ' 3ème requête... ' End Select ' Next i 'LigneSuivante: ' Next j 'TableauSuivant: ' Next k ' bTestODBC = True ' MsgBox("Les données ont été analysées avec succès !", _ ' MsgBoxStyle.Information, sTitreMsg) Fin: AfficherMessage("Opération terminée.") End Function End Class clsODBC.vb ' Fichier clsODBC.vb ' ------------------ ' Version 1.15 du 16/11/2011 : Dsn auto : If Me.m_bPrompt seulement ' Version 1.14 du 19/09/2010 : Vérification du dépassement de colonnes ' Version 1.13 du 10/04/2009 : m_iNbTentatives de lectures pour Excel ' Version 1.12 du 14/10/2008 : TypeGuessRows Excel : même avec Office 2003 ! ' Version 1.11 du 13/04/2008 : Mode bLireToutDUnBlocRapide amélioré ' Version 1.10 du 26/01/2008 : TypeGuessRows Excel automatique par le code ' Version 1.09 du 25/11/2007 : TypeGuessRows Excel automatique amélioré ' Version 1.08 du 22/11/2007 : Correction requête insertion ' Version 1.07 du 18/11/2007 : Correction bilan exploration ' Version 1.06 du 08/11/2007 : Correction chronométrage ' Version 1.05 du 12/05/2007 : Autre table fantôme Excel : [MonClasseur$_] ' Version 1.04 du 11/03/2007 : Gestion des tables fantômes d'Excel Imports System.Text ' Pour StringBuilder Public Class clsODBC #Region "Déclarations" Public Const sValErreurDef$ = "#Erreur#" ' Evénement signalant l'arrivée d'un message ' (avancement de l'opération en cours ou bien erreur par exemple) Public Event EvAfficherMessage(ByVal sMsg$) ' Si vous voulez contrôler strictement l'état des variables affectées ' depuis l'extérieur de la classe, alors utilisez des propriétés ' Set et Get, et passez ces variables membres en privé dans ce cas ' Requête faite à la volée par le code ' (ou bien liste de requêtes SQL séparées par des ; ) ' (au lieu de requêtes figurant dans un fichier .sql externe) Public m_sListeSQL$ ' Requête spécifique dans le cas où la source est un fichier Excel Public m_sListeSQLExcel$ ' Chaîne de connexion directe à un fichier source, par exemple un fichier Excel Public m_sChaineConnexionDirecte$ ' Chemins vers un fichier DSN et une requête SQL stockés en externe Public m_sCheminDSN$, m_sCheminSQL$ ' Chemins et SQL par défaut lors de la création automatique des fichiers DNS et SQL Public m_sCheminSrcExcel$, m_sCheminSrcAccess$, m_sCheminSrcOmnis$ Public m_sSQLExcelDef$, m_sSQLAccessDef$, m_sSQLOmnisDef$ ' SQL ou liste de SQL Public m_sSQLNavisionDef$, m_sSQLDB2Def$ ' Pour les accès ODBC nécessitant une authentification Public m_sCompteUtilisateur$, m_sMotDePasse$ ' Pour les accès ODBC de type serveur, comme Navision, DB2, ... Public m_sCompteSociete$, m_sNomServeur$ ' Afficher les messages dans les boites de dialogues Public m_bPrompt As Boolean ' Générer des événements pour afficher le détail des opérations en cours Public m_bAfficherMsg As Boolean ' Booléen pour indiquer si le pilote ODBC supporte le retour arrière ' (vrai pour Excel et Access, faux pour Omnis) ' C'est utile pour connaitre à l'avance le nombre de lignes de la source ODBC ' mais cela peut faire perdre du temps : on peut laisser à faux dans ce cas Public m_bODBCArriere As Boolean ' Utile pour effectuer une requête action via une chaîne de connexion directe Public m_bModeEcriture As Boolean ' Copier tout le contenu retourné par les requêtes SQL dans le presse-papier Public m_bCopierDonneesPressePapier As Boolean ' Vérifier la présence du fichier source de données ' (ne pas vérifier s'il n'y a pas de fichier spécifique) Public m_bVerifierFichierSourceDonnees As Boolean ' Vérifier le risque d'erreur de lecture avec Excel < 2003 Public m_bVerifierConfigODBCExcel As Boolean ' Possibilité d'annuler proprement le requêtage depuis l'interface Private m_bAnnuler As Boolean ' Si on lance des requêtes succesives par petits groupes de données ' permet de conserver si une annulation a été demandé Public m_bNePasInitAnnulation As Boolean ' S'il y a plusieurs requêtes consécutives (liste de SQL séparés par un ;), ' cette option permet d'interrompre la requête en cours, ' mais de poursuivre les autres requêtes Public m_bInterrompreSeulementRqEnCours As Boolean ' Remplacer le séparateur décimal dans les valeurs par le . ' pour pouvoir convertir les nombres en réels via Val Public m_bRemplacerSepDec As Boolean ' Remplacer seulement les champs numériques : tester avec IsNumeric ' (attention : IsNumeric est très lent : mieux vaut remplacer tous les champs) ' Autre solution : se baser sur le schéma de la table pour détecter les numériques Public m_bRemplacerSepDecNumSeul As Boolean Private m_bRemplacerSepDecRequis As Boolean Private m_sSepDecimal$ Public m_bEnleverEspacesFin As Boolean ' Appliquer un TrimEnd = RTrim Public m_bRemplacerVraiFaux As Boolean Public m_sValVrai$, m_sValFaux$ ' Valeurs à appliquer en guise de Vrai et Faux Public m_sValErreur$ ' Indiquer la présence d'au moins 1 erreur de lecture de la valeur d'un champ ' (pour l'ensemble des requêtes successives) Public m_bErreursLecture As Boolean ' Méthode ADODB.GetString : Attention, le format des dates peut être différent Public m_bLireToutDUnBloc As Boolean ' Délimiteur ; par défaut et pas de traitement du contenu des champs : Public m_bLireToutDUnBlocRapide As Boolean Public m_sbLignes As StringBuilder ' Stocker les résultats Public m_aoMetaTableau() As Object ' Explorateur ODBC Public m_alTables As ArrayList Public m_asChamps$(,) ' 18/11/2007 Public m_sNomTableMaxChamps$, m_iNumTableMaxChamps%, m_aiNbChamps%() Public m_sbContenuRetour As StringBuilder Public m_bAjouterChronoDebug As Boolean Private Const sTypeODBCExcel$ = "Excel" Private Const sTypeODBCAccess$ = "Access" Private Const sTypeODBCOmnis$ = "Omnis" Private Const sTypeODBCNavision$ = "Navision" Private Const sTypeODBCDB2$ = "DB2" ' Nombre d'enregistrement alloués à l'avance pour le stockage des lignes Public m_iNbEnregAlloues% Private Const iNbEnregAllouesDef% = 100 Private m_oConn As ADODB.Connection = Nothing Public m_iNbTentatives% = 0 ' Tentatives de lecture, par ex. fichier Excel partagé Public ReadOnly Property bAnnuler() As Boolean Get ' Savoir si une annulation est en cours bAnnuler = Me.m_bAnnuler End Get End Property Public Sub Annuler() ' Demander une annulation Me.m_bAnnuler = True End Sub #End Region #Region "Divers" Public Sub New() Me.m_sCheminDSN = "" Me.m_sCheminSQL = "" Me.m_sChaineConnexionDirecte = "" Me.m_sListeSQL = "" Me.m_sListeSQLExcel = "" Me.m_sCheminSrcExcel = "" Me.m_sCheminSrcAccess = "" Me.m_sCheminSrcOmnis = "" Me.m_sSQLExcelDef = "" Me.m_sSQLAccessDef = "" Me.m_sSQLOmnisDef = "" Me.m_sSQLNavisionDef = "" Me.m_sSQLDB2Def = "" Me.m_sNomTableMaxChamps = "" Me.m_iNumTableMaxChamps = 0 Me.m_sCompteSociete = "" Me.m_sNomServeur = "" Me.m_sCompteUtilisateur = "" Me.m_sMotDePasse = "" Me.m_bODBCArriere = False Me.m_bCopierDonneesPressePapier = True Me.m_bPrompt = True Me.m_bRemplacerSepDec = True Me.m_bRemplacerSepDecNumSeul = False Me.m_bEnleverEspacesFin = True Me.m_bRemplacerVraiFaux = True Me.m_sValVrai = "1" Me.m_sValFaux = "" Me.m_sValErreur = sValErreurDef Me.m_bNePasInitAnnulation = False Me.m_bInterrompreSeulementRqEnCours = False Me.m_bAfficherMsg = True Me.m_bVerifierFichierSourceDonnees = True Me.m_bVerifierConfigODBCExcel = True Me.m_bLireToutDUnBloc = False Me.m_bLireToutDUnBlocRapide = False Me.m_bAjouterChronoDebug = True Me.m_iNbEnregAlloues = iNbEnregAllouesDef LibererRessources() End Sub Public Sub LibererRessources() Me.m_bErreursLecture = False Me.m_bAnnuler = False Me.m_aoMetaTableau = Nothing Me.m_alTables = Nothing Me.m_asChamps = Nothing Me.m_aiNbChamps = Nothing 'Me.m_sLignes = "" Me.m_sbLignes = New StringBuilder ViderContenuResultat() If Not Me.m_oConn Is Nothing Then Me.m_oConn.Close() Me.m_oConn = Nothing End If End Sub Public Sub ViderContenuResultat() Me.m_sbContenuRetour = Nothing End Sub Private Sub AfficherMessage(ByVal sMsg$) If Not Me.m_bAfficherMsg Then Exit Sub RaiseEvent EvAfficherMessage(sMsg) Application.DoEvents() End Sub Private Sub AfficherErreursADO(ByVal oConnexion As ADODB.Connection, ByRef sMsgErr$) ' Note sur ByVal oConnexion : ' En VB .NET, il n'est plus nécessaire de passer les objets par ' reférence. De plus, le ByVal est plus rapide (même pour les objets), ' ce qui n'est pas le cas en VB6. Explication : en VB .NET ' si on utilise ByVal, l'objet est copié une fois, mais il est copié ' 2 fois dans le cas du ByRef, selon "VB.NET Professionnel" de Wrox Team If oConnexion Is Nothing Then Exit Sub Dim sMsg$ = "" Dim oErrADO As ADODB.Error For Each oErrADO In oConnexion.Errors sMsg &= "Erreur ADO : " & oErrADO.Description & vbCrLf sMsg &= "Numéro : " & oErrADO.Number & " (" & _ Hex(oErrADO.Number) & ")" & vbCrLf If oErrADO.SQLState <> "" Then _ sMsg &= "Erreur Jet : " & oErrADO.SQLState & vbCrLf If oErrADO.Number = -2147467259 Then ' Si le pilote ODBC n'est pas installé, on peut obtenir l'erreur : ' [Microsoft][Gestionnaire de pilotes ODBC] ' Source de données introuvable et nom de pilote non spécifié" ' Numéro : -2147467259 (80004005), Erreur Jet : IM002 sMsg &= "Cause possible : Le pilote ODBC spécifié n'est pas installé sur ce poste." & vbCrLf End If If oErrADO.Number = -2147217884 Then ' L'ensemble de lignes ne prend pas en charge les récupérations arrière sMsg &= "Explication : Le pilote ODBC ne supporte pas le retour en arrière." & vbCrLf sMsg &= "(Utilisez m_bODBCArriere = False en paramètre)" & vbCrLf End If MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) Next oErrADO sMsgErr &= vbCrLf & sMsg End Sub Public Shared Sub VerifierConfigODBCExcel() ' Vérifier la configuration ODBC pour Excel : ' Pour Excel < 2003, la configuration par défaut peut être insuffisante ' voir la fonction bCreerFichierDsnODBC() Const sCle$ = "SOFTWARE\Microsoft\Jet\4.0\Engines\Excel" Const sSousCleTGR$ = "TypeGuessRows" Dim sValCleTGR$ = "" If Not bCleRegistreLMExiste(sCle, sSousCleTGR, sValCleTGR) Then Exit Sub ' 14/10/2008 Même avec Office2003 le problème existe ! ' Si on détermine qu'Office2003 ou > est installé, inutile de générer une alerte 'Const sSousCleWin32$ = "win32" 'Const sSousCleWin32Old$ = "win32old" 'Dim sValCleWin32$ = "" 'Dim sValCleWin32Old$ = "" 'bCleRegistreLMExiste(sCle, sSousCleWin32, sValCleWin32) 'bCleRegistreLMExiste(sCle, sSousCleWin32Old, sValCleWin32Old) 'sValCleWin32 = sValCleWin32.ToLower 'If sValCleWin32.Length > 0 And sValCleWin32Old.Length > 0 Then ' ' 24/11/2007 : Office10 = XP : insuffisant, il faut 11 ou > ' If (sValCleWin32.IndexOf("office11\msaexp30.dll") > -1 Or _ ' sValCleWin32.IndexOf("office12\msaexp30.dll") > -1) And _ ' sValCleWin32Old.IndexOf("msexcl40.dll") > -1 Then Exit Sub 'End If If sValCleTGR.Length = 0 Then Exit Sub ' Eviter IsNumeric : très lent ! AndAlso IsNumeric(sValCleTGR) Then Dim iValCleTGR% = iConv(sValCleTGR, -1) If Not (iValCleTGR > -1 And iValCleTGR < 1024) Then Exit Sub 'MsgBox("La configuration ODBC pour Excel risque d'être insuffisante :" & vbLf & _ ' "Augmentez la valeur pour lire un plus grand nombre de lignes pour déterminer" & vbLf & _ ' "le type de données capable de stocker les valeurs d'une colonne Excel" & vbLf & _ ' "TypeGuessRow=" & iValCleTGR & " < 1024" & vbLf & _ ' "Clé : HKEY_LOCAL_MACHINE\" & sCle & vbLf & _ ' "Pour cela, il suffit de lancer ODBCExcelAugmenterTypeGuessRows.reg", _ ' MsgBoxStyle.Exclamation, sTitreMsg) Dim sNouvVal$ = "16384" If MsgBoxResult.Cancel = MsgBox( _ "La configuration ODBC pour Excel risque d'être insuffisante :" & vbLf & _ "Cliquez sur OK pour augmentez la valeur (" & sNouvVal & ")" & vbLf & _ "pour lire un plus grand nombre de lignes pour déterminer" & vbLf & _ "le type de données capable de stocker les valeurs d'une colonne Excel" & vbLf & _ "TypeGuessRow=" & iValCleTGR & " < 1024" & vbLf & _ "Clé : HKEY_LOCAL_MACHINE\" & sCle, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, sTitreMsg) Then Exit Sub ' Faire la modif par le code si on a le droit Dim sMsg$ = "Echec de la correction de TypeGuessRow !" Dim bOk As Boolean = False If bCleRegistreLMExiste(sCle, sSousCleTGR, sValCleTGR, sNouvVal) Then If bCleRegistreLMExiste(sCle, sSousCleTGR, sValCleTGR) Then If sValCleTGR = sNouvVal Then _ bOk = True : sMsg = "La correction de TypeGuessRow a réussie !" End If End If If bOk Then MsgBox(sMsg, MsgBoxStyle.Exclamation, sTitreMsg) Else MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) End If End Sub #End Region #Region "Lecture de la source ODBC" Public Function bLireSQL(ByRef sListeSQL$, ByRef sContenuDSN$, _ ByVal bNoterContenu As Boolean, ByRef sbContenu As StringBuilder, _ Optional ByVal bVerifierSQL As Boolean = True, _ Optional ByRef bExcel As Boolean = False) As Boolean sListeSQL$ = "" sContenuDSN$ = "" 'Dim bExcel As Boolean = False If Me.m_sChaineConnexionDirecte.Length > 0 Then If bNoterContenu Then _ sbContenu.Append("Chaîne de connexion directe : " & _ Me.m_sChaineConnexionDirecte & vbCrLf) sListeSQL = Me.m_sListeSQL If Me.m_sChaineConnexionDirecte.IndexOf("Excel") > -1 Then bExcel = True If Me.m_bVerifierConfigODBCExcel Then VerifierConfigODBCExcel() End If Else ' S'il n'y a pas de chaîne de connexion directe, on utilise un fichier DSN ' ainsi qu'un fichier SQL : on peut ainsi personnaliser les requêtes en ' fonction de la source ODBC (si la source DSN est détectée comme étant de ' type Excel, c'est plus simple d'utiliser une requête spécifique ' (Me.m_sListeSQLExcel) que d'ajouter un $ à la fin des noms des tables, ' ce qui n'est envisageable que pour une requête simple ' Si le fichier DSN est absent, on peut le créer automatiquement If Not bFichierExiste(Me.m_sCheminDSN) Then If Not bCreerFichiersDsnEtSQLODBCDefaut() Then Exit Function End If sContenuDSN = sLireFichier(Me.m_sCheminDSN) ' Si par exemple base AS400, alors ne pas faire de vérification ' car DBQ n'indique pas un chemin vers un fichier spécifique du disque dur If Me.m_bVerifierFichierSourceDonnees Then ' Lorsque le fichier DSN est déjà créé, vérifier la présence de la source ODBC ' si le pilote fonctionne ainsi (on teste toutes les possibilités) ' Dans le cas d'un accès réseau, cela permet de tester l'accessibilité ' à la base plutôt que d'afficher un message d'erreur obscur If Not bVerifierCheminODBC("DataFilePath=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("DBQ=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("Database=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("Dbf=", sContenuDSN) Then Exit Function If Not bVerifierCheminODBC("SourceDB=", sContenuDSN) Then Exit Function ' Vérification des dossiers aussi If Not bVerifierCheminODBC("DefaultDir=", sContenuDSN, _ bDossier:=True) Then Exit Function If Not bVerifierCheminODBC("PPath=", sContenuDSN, _ bDossier:=True) Then Exit Function End If ' Si le pilote est pour Omnis et qu'on a oublié de désactiver m_bODBCArriere ' on le fait, car un MoveLast() peut être très très long ! If Me.m_bODBCArriere AndAlso _ sContenuDSN.IndexOf("DRIVER=OMNIS ODBC Driver") > -1 Then Me.m_bODBCArriere = False End If If sContenuDSN.IndexOf("DRIVER=Microsoft Excel Driver") > -1 Then bExcel = True If Me.m_bVerifierConfigODBCExcel Then VerifierConfigODBCExcel() End If If bNoterContenu Then sbContenu.Append("Fichier DSN : " & Me.m_sCheminDSN & " : " & vbCrLf) sbContenu.Append(sContenuDSN & vbCrLf) End If If Me.m_sListeSQL.Length > 0 Then ' Requête(s) à la volée par le code sListeSQL = Me.m_sListeSQL Else If bVerifierSQL Then If Me.m_sCheminSQL.Length = 0 Then _ MsgBox("Le chemin vers le fichier SQL est vide !", _ MsgBoxStyle.Critical, sTitreMsg) : Exit Function ' S'il n'y a pas de requête à la volée par le code, ' alors lire le contenu du fichier SQL externe If Not bFichierExiste(Me.m_sCheminSQL, bPrompt:=True) Then _ Exit Function sListeSQL = sLireFichier(Me.m_sCheminSQL) End If End If End If If bExcel AndAlso Me.m_sListeSQLExcel.Length > 0 Then _ sListeSQL = Me.m_sListeSQLExcel bLireSQL = True End Function Private Function bCheminFichierProbable(ByVal sChemin$) As Boolean ' Voir si le chemin supposé est un vrai chemin, ou bien simplement ' un nom de base de données de type serveur, ' auquel cas, il ne faut pas chercher à vérifier la présence du fichier ' de source de donnée If sChemin.IndexOf("\") > -1 Then bCheminFichierProbable = True End Function Public Function bExplorerSourceODBC( _ Optional ByVal bExplorerChamps As Boolean = True, _ Optional ByVal sNomTableAExplorer$ = "", _ Optional ByVal bRenvoyerContenu As Boolean = False) As Boolean ' Explorer la structure de la source ODBC indiquée par le fichier .dsn ' Pour manipuler des grandes quantités de chaînes, ' StringBuilder est beaucoup plus rapide que String Dim sbContenu As StringBuilder = Nothing Dim bNoterResultat As Boolean = False If bRenvoyerContenu Or Me.m_bCopierDonneesPressePapier Then bNoterResultat = True sbContenu = New StringBuilder End If Dim sListeSQL$ = "" Dim sContenuDSN$ = "" Dim bExcel As Boolean = False If Not bLireSQL(sListeSQL, sContenuDSN, bNoterResultat, sbContenu, _ bVerifierSQL:=False, bExcel:=bExcel) Then Me.AfficherMessage("Erreur !") Exit Function End If ' On initialise à Nothing pour éviter les avertissements intempestifs de VB8 Dim oConn As ADODB.Connection = Nothing Dim oRq As ADODB.Recordset = Nothing Dim bConnOuverte As Boolean, bRqOuverte As Boolean If Not Me.m_bNePasInitAnnulation Then Me.m_bAnnuler = False Me.m_bErreursLecture = False End If Try oConn = New ADODB.Connection oRq = New ADODB.Recordset AfficherMessage("Ouverture de la connexion ODBC en cours...") Sablier() oConn.Mode = ADODB.ConnectModeEnum.adModeRead Dim sConnexion$ If Me.m_sChaineConnexionDirecte.Length = 0 Then sConnexion = "FILEDSN=" & Me.m_sCheminDSN & ";" Else sConnexion = Me.m_sChaineConnexionDirecte End If oConn.Open(sConnexion) bConnOuverte = True Me.m_alTables = New ArrayList If bNoterResultat Then _ sbContenu.Append(vbCrLf & vbCrLf & "Tables :" & vbCrLf) AfficherMessage("Exploration des tables en cours...") oRq.CursorType = ADODB.CursorTypeEnum.adOpenForwardOnly ' Exploration des clés primaires : non pris en charge par les pilotes ODBC 'ADODB.SchemaEnum.adSchemaPrimaryKeys 'Dim asRestrictions$(4) ' Non pris en charge par les pilotes ODBC 'asRestrictions(0) = Nothing ' TABLE_CATALOG 'asRestrictions(1) = Nothing ' TABLE_SCHEMA 'asRestrictions(2) = sNomTableAExplorer ' TABLE_NAME 'asRestrictions(3) = Nothing ' TABLE_TYPE ' http://www.sahirshah.com/articles/ADOOpenSchema.html oRq = oConn.OpenSchema(ADODB.SchemaEnum.adSchemaTables) ', asRestrictions) bRqOuverte = True Dim iNbChamps% = oRq.Fields.Count If iNbChamps = 0 Then GoTo RequeteSuivante ' 18/11/2007 'If iNbChamps = 0 Then bRqOuverte = False : GoTo RequeteSuivante If oRq.EOF Then If Me.m_bPrompt Then _ MsgBox("Aucune table trouvée !", MsgBoxStyle.Exclamation) GoTo RequeteSuivante End If Dim iNumTable% = 0 While Not oRq.EOF Dim sNomTable$ = oRq.Fields("TABLE_NAME").Value.ToString 'If (iNumTable Mod 10 = 0) And iNumTable > 0 Then ' Dim sAvancement$ = _ ' "Exploration des tables en cours... (enreg. n°" & _ ' iNumTable + 1 & ")" ' AfficherMessage(sAvancement) ' ' Interrompre l'exploration ' If Me.m_bAnnuler Then Exit While 'End If ' Si une table à explorer est précisée, ne lister que cette table ' (car l'exploration peut être très longue sur les grosses bases) If sNomTableAExplorer.Length > 0 AndAlso _ sNomTable <> sNomTableAExplorer Then GoTo TableSuivante ' Un classeur Excel contient parfois aussi ' des tables fantômes (sauvegarde de l'aperçu impression ?) Dim sTypeObjet$ = oRq.Fields("TABLE_TYPE").Value.ToString If bExcel AndAlso sNomTable.EndsWith("$Impression_des_t") Then If bNoterResultat Then _ sbContenu.Append(sTypeObjet & " : [" & _ sNomTable & "] : Table fantôme Excel ignorée" & vbCrLf) GoTo TableSuivante End If ' Autre exemple de table fantôme sous Excel : [MonClasseur$_] If bExcel AndAlso Not (sNomTable.EndsWith("$") Or sNomTable.EndsWith("$'")) Then ' Normalement, le nom de la table Excel doit se terminer par $ ou $' ' Parfois (???) on ne peut pas explorer ce genre de table ' Il peut s'agir aussi de plages nommées sous Excel If bNoterResultat Then _ sbContenu.Append(sTypeObjet & " : [" & _ sNomTable & "] : Table fantôme Excel ignorée" & vbCrLf) GoTo TableSuivante End If Me.m_alTables.Add(sNomTable) iNumTable += 1 ' 18/11/2007 ' Pour Excel, la plupart des tables sont de type "SYSTEM TABLE" ' Ignorer les tables systèmes de MS-Access 'If Left(sNomTable, 4) = "MSys" Then GoTo TableSuivante If bNoterResultat Then sbContenu.Append( _ sTypeObjet & " : [" & sNomTable & "]" & vbCrLf) ' 25/11/2007 'If bNoterResultat Then ' sbContenu.Append(vbCrLf).Append("Informations sur la table :").Append(vbCrLf) ' sbContenu.Append(sTypeObjet & " : [" & sNomTable & "]" & vbCrLf) ' Dim i%, j% ' For i = 0 To oRq.Fields.Count - 1 ' sbContenu.Append(oRq.Fields(i).Name & _ ' " : [" & oRq.Fields(i).Value.ToString & "]" & vbCrLf) ' 'For j = 0 To oRq.Fields(i).Properties.Count - 1 ' ' sbContenu.Append( _ ' ' "P " & oRq.Fields(i).Properties(j).Name & _ ' ' " : [" & oRq.Fields(i).Properties(j).Value.ToString & "]" & vbCrLf) ' 'Next j ' Next i 'End If TableSuivante: oRq.MoveNext() 'iNumTable += 1 ' 18/11/2007 End While AfficherMessage("Exploration des tables terminée : " & iNumTable) 'If bDebug Then Threading.Thread.Sleep(500) RequeteSuivante: If bRqOuverte Then oRq.Close() : bRqOuverte = False If Not bExplorerChamps Then GoTo FinOk ' Exploration des champs des tables ' Documentation : ADO Data Types (incomplet pour Access) ' http://www.w3schools.com/ado/ado_datatypes.asp ' Comment interpréter les données via ADO OpenSchema adSchemaColumns : ' MS SQL DataTypes QuickRef ' http://webcoder.info/reference/MSSQLDataTypes.html If bNoterResultat Then sbContenu.Append(vbCrLf) Dim sTable$ 'Dim iNbTables% = iNumTable Dim iNbTables% = Me.m_alTables.Count ' 18/11/2007 ReDim Me.m_aiNbChamps(iNbTables - 1) ReDim Me.m_asChamps(iNbTables, 0) iNumTable = 0 Dim iNbChampsTableMax% = 0 For Each sTable In Me.m_alTables If (iNumTable Mod 10 = 0 Or iNumTable = iNbTables - 1) And iNumTable > 0 Then Dim sAvancement$ = _ "Exploration des champs en cours... (table n°" & _ iNumTable + 1 & "/" & iNbTables & ")" AfficherMessage(sAvancement) ' Interrompre l'exploration If Me.m_bAnnuler Then sbContenu.Append( _ "(interruption de l'utilisateur)").Append(vbCrLf) Exit For End If End If ' Attention, avec une connexion directe sur un fichier Excel ' l'ordre des champs est perdu ! mais pas avec un dsn !!! ' Heureusement, en lisant la valeur du champ ORDINAL_POSITION ' et en stockant le résultat dans un tableau de string, ' on retrouve l'ordre exact des champs oRq.CursorType = ADODB.CursorTypeEnum.adOpenKeyset oRq = oConn.OpenSchema(ADODB.SchemaEnum.adSchemaColumns, _ New Object() {Nothing, Nothing, sTable}) bRqOuverte = True If bNoterResultat Then _ sbContenu.Append(vbCrLf & "Table [" & sTable & "] :" & vbCrLf) ' Ne marche pas ici : 'oRq.MoveLast() 'Dim iNbChampsTable% = oRq.RecordCount 'oRq.MoveFirst() Dim iNumChampMax% = 0 Dim iNumChamp% = 0 If (oRq.BOF And oRq.EOF) Then GoTo TableSuivante2 ' Table vide 18/11/2007 While Not oRq.EOF Dim iNumChampTable% = 0 Dim oValChamp As Object = oRq.Fields("ORDINAL_POSITION").Value If IsDBNull(oValChamp) Then iNumChampTable = iNumChamp Else iNumChampTable = CInt(oValChamp) - 1 End If If iNumChampTable > iNumChampMax Then _ iNumChampMax = iNumChampTable iNumChamp += 1 oRq.MoveNext() End While oRq.MoveFirst() Me.m_aiNbChamps(iNumTable) = iNumChampMax Dim iNbChampsTable% = iNumChampMax If iNbChampsTable > iNbChampsTableMax Then iNbChampsTableMax = iNbChampsTable Me.m_sNomTableMaxChamps = sTable ' 18/11/2007 Me.m_iNumTableMaxChamps = iNumTable End If ' Prendre tjrs le max du nbre de champs sur toutes les tables ReDim Preserve Me.m_asChamps(iNbTables, iNbChampsTableMax) iNumChamp = 0 While Not oRq.EOF Dim sDescription$ = "" If Not IsDBNull(oRq.Fields("Description").Value) Then _ sDescription = oRq.Fields("Description").Value.ToString Dim sChamp$ = oRq.Fields("COLUMN_NAME").Value.ToString Dim oValChamp As Object = oRq.Fields("ORDINAL_POSITION").Value Dim iNumChampTable% = 1 If IsDBNull(oValChamp) Then iNumChampTable = iNumChamp Else iNumChampTable = CInt(oValChamp) - 1 End If If bNoterResultat Then Dim sAffTaille$ = "" Dim lTailleCar& = 0 If Not IsDBNull(oRq.Fields("CHARACTER_MAXIMUM_LENGTH").Value) Then lTailleCar = CLng(oRq.Fields("CHARACTER_MAXIMUM_LENGTH").Value) If lTailleCar = 1073741823 Then sAffTaille = ":1Go" Else sAffTaille = ":" & lTailleCar.ToString End If End If Dim sAffTypeDonnees$ = "" Dim lDataType& = 0 If Not IsDBNull(oRq.Fields("DATA_TYPE").Value) Then lDataType& = CLng(oRq.Fields("DATA_TYPE").Value) Dim lVal As ADODB.DataTypeEnum = CType(lDataType, ADODB.DataTypeEnum) sAffTypeDonnees = " (" & lVal.ToString & sAffTaille & ")" End If Dim sAffDescr$ = "" If sDescription.Length > 0 Then sAffDescr = " : " & sDescription sbContenu.Append(" [" & sChamp & "]" & _ sAffTypeDonnees & sAffDescr & vbCrLf) End If 'Dim lFlags& = 0 'If Not IsDBNull(oRq.Fields("COLUMN_FLAGS").Value) Then ' lFlags = CLng(oRq.Fields("COLUMN_FLAGS").Value) 'End If Me.m_asChamps(iNumTable, iNumChampTable) = sChamp iNumChamp += 1 oRq.MoveNext() End While TableSuivante2: oRq.Close() : bRqOuverte = False iNumTable += 1 Next sTable If iNbTables > 0 Then AfficherMessage("Exploration des champs terminée : " & _ iNumTable & "/" & iNbTables) If bDebug Then Threading.Thread.Sleep(500) End If FinOk: If bNoterResultat Then If sNomTableAExplorer.Length > 0 And Me.m_alTables.Count = 0 Then sbContenu.Append( _ "Table [" & sNomTableAExplorer & "] non trouvée !" & vbCrLf) End If sbContenu.Append(vbCrLf & vbCrLf) sbContenu.Append( _ "Documentation : ADO Data Types (incomplet pour Access) :" & vbCrLf) sbContenu.Append("www.w3schools.com/ado/ado_datatypes.asp" & vbCrLf) End If Catch ex As Exception Sablier(bDesactiver:=True) Dim sMsg$ = "" If Me.m_sChaineConnexionDirecte.Length = 0 Then sMsg &= vbCrLf & "Dsn : " & Me.m_sCheminDSN Else sMsg &= vbCrLf & "Chaîne de connexion : " & Me.m_sChaineConnexionDirecte End If Dim sDetailMsgErr$ = "" ' Ne pas copier l'erreur dans le presse-papier maintenant ' car on va le faire dans le Finally Dim sMsgErrFinal$, sMsgErrADO$, sDetail$ If bConnOuverte Then sDetail = "Certains champs sont peut-être introuvables, ou bien :" Else sDetail = "Erreur lors de l'ouverture de la connexion " If sContenuDSN.Length > 0 Then sDetail &= "'" & sLireNomPiloteODBC(sContenuDSN) & "' :" Else sDetail &= ":" End If End If sMsgErrFinal = "" : sMsgErrADO = "" AfficherMsgErreur2(ex, "bExplorerSourceODBC", sMsg, sDetail, _ bCopierMsgPressePapier:=False, sMsgErrFinal:=sMsgErrFinal) If Me.m_bCopierDonneesPressePapier Then _ sbContenu.Append(vbCrLf & sMsgErrFinal & vbCrLf) AfficherErreursADO(oConn, sMsgErrADO) If Me.m_bCopierDonneesPressePapier Then _ sbContenu.Append(sMsgErrADO & vbCrLf) Me.AfficherMessage("Erreur !") Exit Function Finally Sablier(bDesactiver:=True) If bRqOuverte Then oRq.Close() : bRqOuverte = False ' Connexion ADODB et non OleDb If bConnOuverte Then oConn.Close() : bConnOuverte = False ' Copier les informations dans le presse-papier (utile pour le debogage) If Me.m_bCopierDonneesPressePapier Then _ CopierPressePapier(sbContenu.ToString) ' Dans le cas de plusieurs accès ODBC, ' on peut avoir besoin de mémoriser tous les contenus successifs If bRenvoyerContenu Then sbContenu.Append(vbCrLf).Append(vbCrLf).Append(vbCrLf) If IsNothing(Me.m_sbContenuRetour) Then _ Me.m_sbContenuRetour = New StringBuilder Me.m_sbContenuRetour.Append(sbContenu) End If End Try If Me.m_bPrompt Then Me.AfficherMessage("Opération terminée.") Dim sMsg$ = "L'exploration de la source ODBC a été effectuée avec succès !" If Me.m_bCopierDonneesPressePapier Then sMsg &= " (cf. presse-papier)" MsgBox(sMsg, vbExclamation, sTitreMsg) End If bExplorerSourceODBC = True End Function Public Function bLireSourceODBC( _ Optional ByVal bRenvoyerContenu As Boolean = False, _ Optional ByVal bNePasFermerConnexion As Boolean = False) As Boolean ' Extraire les données de la requête SQL via la source ODBC ' indiquée par le fichier .dsn ' Pour manipuler des grandes quantités de chaînes, ' StringBuilder est beaucoup plus rapide que String Dim sbContenu As StringBuilder = Nothing Dim sbLigne As StringBuilder = Nothing Dim bNoterResultat As Boolean = False If bRenvoyerContenu Or Me.m_bCopierDonneesPressePapier Then bNoterResultat = True sbContenu = New StringBuilder sbLigne = New StringBuilder End If Dim sListeSQL$ = "" Dim sContenuDSN$ = "" If Not bLireSQL(sListeSQL, sContenuDSN, _ bNoterResultat, sbContenu) Then Me.AfficherMessage("Erreur !") Exit Function End If ' On initialise à Nothing pour éviter les avertissements intempestifs de VB8 Dim oRq As ADODB.Recordset = Nothing Dim bConnOuverte As Boolean, bRqOuverte As Boolean Dim asSQL$() = sListeSQL.Split(CChar(";")) Dim iNbSQL% = 0 Dim sSQL$ = "" Me.m_bRemplacerSepDecRequis = False Me.m_sSepDecimal = "" If Me.m_bRemplacerSepDec Then ' Remplacer , par . dans toutes les valeurs des champs Me.m_sSepDecimal = Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator() If Me.m_sSepDecimal.Length > 0 AndAlso Me.m_sSepDecimal <> "." Then _ Me.m_bRemplacerSepDecRequis = True End If If Not Me.m_bNePasInitAnnulation Then Me.m_bAnnuler = False Me.m_bErreursLecture = False End If Try Sablier() If IsNothing(Me.m_oConn) Then Me.m_oConn = New ADODB.Connection AfficherMessage("Ouverture de la connexion ODBC en cours...") If m_bModeEcriture Then Me.m_oConn.Mode = ADODB.ConnectModeEnum.adModeReadWrite Else Me.m_oConn.Mode = ADODB.ConnectModeEnum.adModeRead 'http://www.w3schools.com/ado/prop_mode.asp 'Allows others to open a connection with any permissions. 'Me.m_oConn.Mode = ADODB.ConnectModeEnum.adModeShareDenyNone End If Dim sConnexion$ If Me.m_sChaineConnexionDirecte.Length = 0 Then sConnexion = "FILEDSN=" & Me.m_sCheminDSN & ";" Else sConnexion = Me.m_sChaineConnexionDirecte End If Me.m_oConn.Open(sConnexion) End If bConnOuverte = True oRq = New ADODB.Recordset Dim iNbRqMax% = asSQL.GetLength(0) Dim iNbChampsMax% = 0 For Each sSQL In asSQL sSQL = sSQL.Trim If sSQL.Length = 0 Then Exit For ReDim Preserve Me.m_aoMetaTableau(iNbSQL) iNbSQL += 1 Dim dDate As Date If bNoterResultat Then sbContenu.Append(vbCrLf & vbCrLf & "SQL n°" & iNbSQL & " : " & _ sSQL & vbCrLf & vbCrLf) dDate = Now AjouterTemps(sbContenu, "Heure début ouverture", dDate, dDate) End If If iNbRqMax >= 100 Then If ((iNbSQL Mod 100 = 0) Or iNbSQL = iNbRqMax) And iNbSQL > 0 Then Dim sAvancement$ = _ "Exécution des requêtes en cours... : SQL n°" & _ iNbSQL & "/" & iNbRqMax AfficherMessage(sAvancement) If Me.m_bAnnuler Then Exit For End If Else AfficherMessage("Exécution de la requête n°" & iNbSQL & " en cours...") If Me.m_bAnnuler Then Exit For End If If Me.m_bODBCArriere Then oRq.CursorType = ADODB.CursorTypeEnum.adOpenKeyset Else oRq.CursorType = ADODB.CursorTypeEnum.adOpenForwardOnly End If ' Par défaut : oRq.LockType = ADODB.LockTypeEnum.adLockReadOnly ' 10/04/2009 Tentatives de lecture, par ex. pour Excel Dim bOk As Boolean = False If m_iNbTentatives > 0 Then For iNumTentative As Integer = 1 To m_iNbTentatives - 1 Try oRq.Open(sSQL, Me.m_oConn) bRqOuverte = True bOk = True Exit For Catch 'Attendre(3000) Threading.Thread.Sleep(3000) ' iDelaiMSec End Try Next End If If Not bOk Then oRq.Open(sSQL, Me.m_oConn) bRqOuverte = True End If Dim asTableau$(,) = Nothing ' Penser à réinitialiser le tableau Dim iNumEnreg%, i%, sValChamp$, iNbEnregAllouesAct% Dim oValChamp As Object Dim iNbChamps% = oRq.Fields.Count ' Cela peut arriver pour les requêtes en écriture, par exemple : ' UPDATE [Article$] SET [Article] = [Article] & '_Test' ' Dans ce cas, pensez à mettre ReadOnly=0 dans le fichier .dsn ' Ne pas faire oRq.Close() pour une requete insertion : cela plante ! 'If iNbChamps = 0 Then GoTo RequeteSuivante If iNbChamps = 0 Then bRqOuverte = False : GoTo RequeteSuivante ' On peut noter les noms des champs systématiquement : pas couteux 'If bNoterResultat Then Dim iNumSQL% = iNbSQL - 1 ' Prendre tjrs le max du nbre de champs sur toutes les rq If iNbChamps > iNbChampsMax Then iNbChampsMax = iNbChamps If iNumSQL = 0 Then ReDim Me.m_asChamps(iNbRqMax, iNbChampsMax) Else ReDim Preserve Me.m_asChamps(iNbRqMax, iNbChampsMax) End If For i = 0 To iNbChamps - 1 Me.m_asChamps(iNumSQL, i) = oRq.Fields(i).Name Next i 'End If If oRq.EOF Then If bNoterResultat Then AjouterTemps(sbContenu, "Heure début analyse ", Now, dDate) dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) End If If Me.m_bPrompt Then _ MsgBox("La requête ne renvoie aucun enregistrement !", _ MsgBoxStyle.Exclamation) GoTo MemoriserTab_RqSuivante End If Dim iNbLignes% = -1 If Me.m_bODBCArriere Then ' Si l'ODBC ne supporte pas le retour en arrière MoveFirst, on obtient ' l'erreur -2147217884 (80040E24) avec la traduction en petit-nègre : ' L'ensemble de lignes ne prend pas en charge les récupérations arrière ' (Le jeu de données - RecordSet : l'objet requête - ' ne prend pas en charge le retour en arrière) ' Les pilotes ODBC Access et Excel le supporte, on peut donc dimensionner ' le tableau à l'avance (quoique le MoveLast ralenti au départ) : AfficherMessage("Détermination du nombre de lignes...") oRq.MoveLast() iNbLignes = oRq.RecordCount AfficherMessage("Retour au début du jeu de données...") oRq.MoveFirst() ReDim asTableau(iNbChamps - 1, iNbLignes - 1) Else iNbLignes = 0 ' Bug corrigé : attendre d'avoir au moins un enregistrement ' sinon on ne pourra pas distinguer entre 0 et 1 enregistrement 'ReDim asTableau(iNbChamps - 1, 0) End If ' On peut optimiser la lecture, mais de toute façon se sera long en ODBC ' GetString est surtout utile conjointement avec OWC ' (test réalisé : beaucoup plus rapide pour lire un fichier Excel en local, ' mais pas de gain constaté pour lire dans un PGI sur le réseau, ' et on n'a plus l'avancement en temps réel) If Me.m_bLireToutDUnBloc Or Me.m_bLireToutDUnBlocRapide Then If bNoterResultat Then 'AjouterTemps(sbContenu, "Heure début lecture ", dDate, dDate) AjouterTemps(sbContenu, "Heure début lecture ", Now, dDate) ' 08/11/2007 dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) ' 13/04/2008 End If AfficherMessage("SQL n°" & iNbSQL & _ " : Lecture des données d'un seul bloc...") If bDebug Then Threading.Thread.Sleep(500) ' Avec un délimiteur ; on peut afficher la ligne directement, ' mais on ne traite pas les champs et il ne faut pas que ' le signe ; se trouve dans le contenu d'un champ texte If Me.m_bLireToutDUnBlocRapide Then Const sDelimiteurColonnesRapide$ = ";" Const sDelimiteurLignesRapide$ = vbCrLf ' 13/04/2008 ' 13/04/2008 : m_bLireToutDUnBlocRapide incompatible avec ' multi-rq, sauf si les rq sont de même structure 'Me.m_sbLignes = New StringBuilder( _ ' oRq.GetString(, , sDelimiteurColonnesRapide)) Dim sb As New StringBuilder( _ oRq.GetString(, , _ sDelimiteurColonnesRapide, sDelimiteurLignesRapide)) If bNoterResultat Then sbContenu.Append(sb) If IsNothing(Me.m_sbLignes) Then Me.m_sbLignes = sb Else Me.m_sbLignes.Append(sb) End If ' On laisse le tableau vide, on ne renvoi que Me.m_sLignes GoTo MemoriserTab_RqSuivante End If Const sDelimiteurColonnes$ = vbTab ' ";" Dim asLignes$() = oRq.GetString(, , _ sDelimiteurColonnes).Split(CChar(vbCr)) If bNoterResultat Then AjouterTemps(sbContenu, "Heure début analyse ", Now, dDate) dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) End If AfficherMessage("SQL n°" & iNbSQL & _ " : Analyse des données en cours...") If bDebug Then Threading.Thread.Sleep(500) Dim sLigne$ iNumEnreg = 0 For Each sLigne In asLignes If sLigne.Length = 0 Then GoTo LigneSuivante Dim asChamps$() = sLigne.Split(CChar(sDelimiteurColonnes)) If iNumEnreg = 0 Then iNbLignes = asLignes.GetLength(0) iNbChamps = asChamps.GetLength(0) ReDim asTableau(iNbChamps - 1, iNbLignes - 1) End If Dim sValChamp0$ Dim iNumChamp% = 0 If bNoterResultat Then sbLigne.Length = 0 For Each sValChamp0 In asChamps If sValChamp0.Length > 0 Then TraiterValChamp(sValChamp0) End If ' 19/09/2010 Vérification du dépassement de colonnes If iNumChamp >= iNbChampsMax Then ' Le contenu du champ contient le séparateur : bug 'Debug.WriteLine("!") Else asTableau(iNumChamp, iNumEnreg) = sValChamp0 End If If bNoterResultat Then sbLigne.Append(sValChamp0) If iNumChamp < iNbChamps - 1 Then sbLigne.Append(";") End If iNumChamp += 1 Next sValChamp0 If bNoterResultat Then sbContenu.Append(sbLigne) sbContenu.Append(vbCrLf) End If iNumEnreg += 1 LigneSuivante: Next sLigne GoTo MemoriserTab_RqSuivante End If ' Autre idée : DataAdaptater.Fill(DataTable) en une instruction ' (méta-tableau de DataTable), mais on n'aura plus l'avancement ' (on peut faire une boucle seulement pour débug) If bNoterResultat Then 'AjouterTemps(sbContenu, "Heure début lecture ", dDate, dDate) AjouterTemps(sbContenu, "Heure début lecture ", Now, dDate) ' 08/11/2007 dDate = Now AjouterEntete(sbContenu, iNbSQL - 1, iNbChamps) End If iNumEnreg = 0 : iNbEnregAllouesAct = 0 While Not oRq.EOF If (iNumEnreg Mod 100 = 0) And iNumEnreg > 0 Then Dim sAvancement$ = _ "Lecture de la source ODBC en cours... : SQL n°" & _ iNbSQL & " : enreg. n°" & iNumEnreg + 1 If Me.m_bODBCArriere Then sAvancement &= "/" & iNbLignes AfficherMessage(sAvancement) ' Interrompre la requête en cours If Me.m_bAnnuler Then Exit While End If If bNoterResultat Then sbLigne.Length = 0 If Not Me.m_bODBCArriere Then ' Bug corrigé : attendre le premier enregistrement ' pour commencer à dimensionner le tableau : ReDim If iNumEnreg = 0 Then 'ReDim asTableau(iNbChamps - 1, iNumEnreg) ' Première allocation iNbEnregAllouesAct = Me.m_iNbEnregAlloues ReDim asTableau(iNbChamps - 1, iNbEnregAllouesAct - 1) ElseIf iNumEnreg > iNbEnregAllouesAct - 1 Then ' Redim ne peut changer que la dimension la plus à droite : iNbLignes 'ReDim Preserve asTableau(iNbChamps - 1, iNumEnreg) ' Allocations suivantes iNbEnregAllouesAct += Me.m_iNbEnregAlloues ReDim Preserve asTableau(iNbChamps - 1, iNbEnregAllouesAct - 1) End If End If For i = 0 To iNbChamps - 1 oValChamp = Nothing sValChamp = "" Try oValChamp = oRq.Fields(i).Value If Not IsDBNull(oValChamp) Then ' Attention : La conversion ToString utilise le format ' en vigueur dans les paramètres régionaux de Windows ' par exemple pour le séparateur décimal sValChamp = oValChamp.ToString End If Catch ex As Exception Me.m_bErreursLecture = True sValChamp = Me.m_sValErreur 'Dim s$ = ex.ToString ' Une date du type 30/11/1899 provoque l'erreur suivante ' pourtant IsDate("30/11/1899") est vrai ' et une table Access liée sur cette source renvoie bien ' une vrai date 30/11/1899 ' Run-Time error '-2147217887 (80040E21)' ' Multi-step OLE DB operation generated errors. ' Une opération OLE-DB en plusieurs étapes a généré des erreurs. ' Vérifiez chaque valeur d'état OLE-DB disponible. ' Aucun travail n'a été effectué. 'AfficherErreursADO(oConn) 'Exit Function End Try If sValChamp.Length > 0 Then TraiterValChamp(sValChamp) End If If bNoterResultat Then sbLigne.Append(sValChamp) If i < iNbChamps - 1 Then sbLigne.Append(";") End If asTableau(i, iNumEnreg) = sValChamp Next i If bNoterResultat Then sbContenu.Append(sbLigne) sbContenu.Append(vbCrLf) End If oRq.MoveNext() iNumEnreg += 1 End While ' Avec Me.m_bInterrompreSeulementRqEnCours = True, on peut annuler une requête ' mais poursuivre avec les autres, s'il y en a plusieurs If Me.m_bInterrompreSeulementRqEnCours Then Me.m_bAnnuler = False Else If Me.m_bAnnuler Then sbContenu.Append( _ "(interruption de l'utilisateur)").Append(vbCrLf) Exit Function End If End If MemoriserTab_RqSuivante: ' Réduire la taille allouée du tableau à la taille effective If Me.m_iNbEnregAlloues > 1 AndAlso Not IsNothing(asTableau) Then If asTableau.GetUpperBound(1) >= iNumEnreg Then ReDim Preserve asTableau(iNbChamps - 1, iNumEnreg - 1) End If End If ' Stocker le tableau dans le méta-tableau (tableau de tableaux de string) Me.m_aoMetaTableau(iNbSQL - 1) = asTableau If bNoterResultat Then AjouterTemps(sbContenu, "Heure fin analyse ", Now, dDate) dDate = Now End If RequeteSuivante: If bRqOuverte Then oRq.Close() : bRqOuverte = False Next sSQL Catch ex As Exception Sablier(bDesactiver:=True) ' Si l'erreur a lieu lors de l'ouverture de la connexion ' afficher la liste des SQL If sSQL.Length = 0 Then sSQL = sListeSQL If sSQL.Length > 80 Then sSQL = sSQL.Substring(0, 80) & "..." End If Dim sMsg$ = "SQL : " & sSQL If Me.m_sChaineConnexionDirecte.Length = 0 Then sMsg &= vbCrLf & "Dsn : " & Me.m_sCheminDSN Else sMsg &= vbCrLf & "Chaîne de connexion : " & Me.m_sChaineConnexionDirecte End If Dim sDetailMsgErr$ = "" ' Ne pas copier l'erreur dans le presse-papier maintenant ' car on va le faire dans le Finally Dim sMsgErrFinal$, sMsgErrADO$, sDetail$ If bConnOuverte Then sDetail = "Certains champs sont peut-être introuvables, ou bien :" Else sDetail = "Erreur lors de l'ouverture de la connexion " If sContenuDSN.Length > 0 Then sDetail &= "'" & sLireNomPiloteODBC(sContenuDSN) & "' :" Else sDetail &= ":" End If End If sMsgErrFinal = "" : sMsgErrADO = "" AfficherMsgErreur2(Ex, "bLireSourceODBC", sMsg, sDetail, _ bCopierMsgPressePapier:=False, sMsgErrFinal:=sMsgErrFinal) If bNoterResultat Then sbContenu.Append(vbCrLf & sMsgErrFinal & vbCrLf) AfficherErreursADO(Me.m_oConn, sMsgErrADO) If bNoterResultat Then sbContenu.Append(sMsgErrADO & vbCrLf) Me.AfficherMessage("Erreur !") Exit Function Finally Sablier(bDesactiver:=True) If bRqOuverte And Not IsNothing(oRq) Then _ oRq.Close() : bRqOuverte = False If Not bNePasFermerConnexion Then ' Connexion ADODB et non OleDb If bConnOuverte Then Me.m_oConn.Close() : bConnOuverte = False Me.m_oConn = Nothing End If ' Copier les informations dans le presse-papier (utile pour le debogage) If Me.m_bCopierDonneesPressePapier Then _ CopierPressePapier(sbContenu.ToString) ' Dans le cas de plusieurs accès ODBC, ' on peut avoir besoin de mémoriser tous les contenus successifs If bRenvoyerContenu Then ' Autre syntaxe possible (pour éviter & vbCrLf & vbCrLf) sbContenu.Append(vbCrLf).Append(vbCrLf).Append(vbCrLf) If IsNothing(Me.m_sbContenuRetour) Then _ Me.m_sbContenuRetour = New StringBuilder Me.m_sbContenuRetour.Append(sbContenu) End If End Try Me.AfficherMessage("Opération terminée.") If Me.m_bPrompt Then Dim sMsg$ = "La lecture de la source ODBC a été effectuée avec succès !" If Me.m_bCopierDonneesPressePapier Then sMsg &= " (cf. presse-papier)" MsgBox(sMsg, vbExclamation, sTitreMsg) End If bLireSourceODBC = True End Function Private Sub TraiterValChamp(ByRef sValChamp$) ' Traiter la valeur des champs au cas où If Me.m_bRemplacerSepDecRequis Then ' Quel que soit le séparateur décimal, le convertir en . ' pour pouvoir convertir les nombres en réels via Val() ' IsNumeric dépend du séparateur régional, mais il est très lent ' Voir dans la doc : Notes sur la conversion en nombre réel Dim bRemp As Boolean = True If Me.m_bRemplacerSepDecNumSeul Then If Not IsNumeric(sValChamp) Then bRemp = False End If If bRemp Then sValChamp = sValChamp.Replace(Me.m_sSepDecimal, ".") End If If Me.m_bEnleverEspacesFin Then _ sValChamp = sValChamp.TrimEnd ' = RTrim If Me.m_bRemplacerVraiFaux Then Dim sValChampMin$ = sValChamp.ToLower If sValChampMin = "faux" OrElse sValChampMin = "false" Then _ sValChamp = Me.m_sValFaux If sValChampMin = "vrai" OrElse sValChampMin = "true" Then _ sValChamp = Me.m_sValVrai End If End Sub Private Sub AjouterTemps(ByRef sbContenu As StringBuilder, _ ByVal sTexte$, ByVal dDate2 As Date, ByVal dDate1 As Date) If Not Me.m_bAjouterChronoDebug Then Exit Sub sbContenu.Append(sTexte).Append(" : ") sbContenu.Append(Now.ToLongTimeString) If dDate2 > dDate1 Then sbContenu.Append(" : ") Dim tsDelai As System.TimeSpan = dDate2.Subtract(dDate1) If tsDelai.TotalMinutes >= 1 Then _ sbContenu.Append(tsDelai.TotalMinutes.ToString("0")).Append(" mn : ") sbContenu.Append(tsDelai.TotalSeconds).Append(" sec.") End If sbContenu.Append(vbCrLf) End Sub Private Sub AjouterEntete(ByRef sbContenu As StringBuilder, _ ByVal iNumSQL%, ByVal iNbChamps%) Dim i% For i = 0 To iNbChamps - 1 sbContenu.Append(Me.m_asChamps(iNumSQL, i)) If i < iNbChamps - 1 Then sbContenu.Append(";") Next i sbContenu.Append(vbCrLf) End Sub #End Region #Region "Creation d'un fichier DSN" Private Function bCreerFichiersDsnEtSQLODBCDefaut() As Boolean ' Créer un fichier DSN ODBC par défaut en fonction des sources ' possibles trouvées, ainsi que les requêtes SQL correspondantes ' Chemins des sources ODBC possibles ' Autres fichiers DSN ODBC : www.prosygma.com/odbc-dsn.htm Dim sListeSrcPossibles$ = "" If Me.m_sCheminSrcExcel.Length > 0 Then _ sListeSrcPossibles &= Me.m_sCheminSrcExcel & vbLf If Me.m_sCheminSrcAccess.Length > 0 Then _ sListeSrcPossibles &= Me.m_sCheminSrcAccess & vbLf If Me.m_sCheminSrcOmnis.Length > 0 Then _ sListeSrcPossibles &= Me.m_sCheminSrcOmnis If Me.m_sSQLNavisionDef.Length > 0 And _ Me.m_sCompteSociete.Length > 0 And Me.m_sNomServeur.Length > 0 Then If Not bCreerFichierDsnODBC(sTypeODBCNavision, Me.m_sCheminDSN, _ Me.m_sCheminSQL, "", Me.m_sSQLNavisionDef, _ Me.m_sCompteUtilisateur, Me.m_sMotDePasse, _ Me.m_sCompteSociete, Me.m_sNomServeur) Then _ Exit Function ElseIf Me.m_sSQLDB2Def.Length > 0 And _ Me.m_sCompteSociete.Length > 0 And Me.m_sNomServeur.Length > 0 Then If Not bCreerFichierDsnODBC(sTypeODBCDB2, Me.m_sCheminDSN, _ Me.m_sCheminSQL, "", Me.m_sSQLDB2Def, _ Me.m_sCompteUtilisateur, Me.m_sMotDePasse, _ Me.m_sCompteSociete, Me.m_sNomServeur) Then _ Exit Function ElseIf Me.m_sCheminSrcExcel.Length > 0 AndAlso _ bFichierExiste(Me.m_sCheminSrcExcel) Then If Not bCreerFichierDsnODBC(sTypeODBCExcel, Me.m_sCheminDSN, _ Me.m_sCheminSQL, Me.m_sCheminSrcExcel, Me.m_sSQLExcelDef) Then _ Exit Function ElseIf Me.m_sCheminSrcAccess.Length > 0 AndAlso _ bFichierExiste(Me.m_sCheminSrcAccess) Then If Not bCreerFichierDsnODBC(sTypeODBCAccess, Me.m_sCheminDSN, _ Me.m_sCheminSQL, Me.m_sCheminSrcAccess, Me.m_sSQLAccessDef) Then _ Exit Function ElseIf Me.m_sCheminSrcOmnis.Length > 0 AndAlso _ bFichierExiste(Me.m_sCheminSrcOmnis) Then If Not bCreerFichierDsnODBC(sTypeODBCOmnis, Me.m_sCheminDSN, _ Me.m_sCheminSQL, Me.m_sCheminSrcOmnis, Me.m_sSQLOmnisDef, _ Me.m_sCompteUtilisateur, Me.m_sMotDePasse) Then _ Exit Function Else Dim sMsg$ = "Aucune source ODBC possible n'a été trouvée pour créer un fichier DSN !" If sListeSrcPossibles.Length > 0 Then _ sMsg &= vbLf & "Liste des sources possibles : " & vbLf & sListeSrcPossibles MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) Exit Function End If bCreerFichiersDsnEtSQLODBCDefaut = True End Function Private Function bCreerFichierDsnODBC(ByVal sTypeODBC$, ByVal sCheminDsn$, _ ByVal sCheminSQL$, ByVal sFichierSrc$, ByVal sSQL$, _ Optional ByVal sCompteUtilisateur$ = "", _ Optional ByVal sMotDePasse$ = "", _ Optional ByVal sCompteSociete$ = "", _ Optional ByVal sNomServeur$ = "") As Boolean ' Créer un fichier DSN ODBC par défaut en fonction des sources possibles trouvées ' ainsi que les requêtes SQL correspondantes Dim sSource$ = sFichierSrc Dim sDossierSrc$ = "" If sFichierSrc.Length > 0 Then _ sDossierSrc = IO.Path.GetDirectoryName(sFichierSrc) Dim sb As New StringBuilder ' Autres fichiers DSN ODBC : www.prosygma.com/odbc-dsn.htm Select Case sTypeODBC Case sTypeODBCExcel sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=Microsoft Excel Driver (*.xls)" & vbCrLf) sb.Append("UID=admin" & vbCrLf) sb.Append("UserCommitSync=Yes" & vbCrLf) sb.Append("Threads=3" & vbCrLf) sb.Append("SafeTransactions=0" & vbCrLf) If Me.m_bModeEcriture Then sb.Append("ReadOnly=0" & vbCrLf) Else sb.Append("ReadOnly=1" & vbCrLf) End If sb.Append("PageTimeout=5" & vbCrLf) ' En pratique MaxScanRows n'est pas utilisé dans le fichier DSN ! ' Seule la clé TypeGuessRows de la base de registre : ' HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Jet\4.0\Engines\Excel ' permet de prendre en compte un plus grand nombre de lignes ' pour déterminer automatiquement le type du champ, ' ce qui est nécessaire si les n premières occurrences ' du champs sont vides dans la feuille Excel : ' www.dicks-blog.com/archives/2004/06/03/external-data-mixed-data-types/ ' Utilisez la fonction VerifierConfigODBCExcel() pour vérifier sa valeur ' sauf si vous travaillez avec Excel 2003, qui fonctionne bien ' dans tous les cas, car il utilise une dll plus efficace : ' Microsoft Access Expression Builder : ' C:\Program Files\Microsoft Office\Office11\msaexp30.dll (11.0.6561.0) ' la dll par défaut étant : Microsoft Jet Excel Isam : ' C:\Windows\System32\msexcl40.dll (4.0.8618.0) sb.Append("MaxScanRows=8" & vbCrLf) sb.Append("MaxBufferSize=2048" & vbCrLf) sb.Append("FIL=excel 8.0" & vbCrLf) sb.Append("DriverId=790" & vbCrLf) sb.Append("DefaultDir=" & sDossierSrc & vbCrLf) sb.Append("DBQ=" & sFichierSrc & vbCrLf) ' On peut aussi indiquer un chemin relatif avec . ' Ex.: DefaultDir=.\SourcesODBC\SourceODBC_MSExcel ' DBQ=.\SourcesODBC\SourceODBC_MSExcel\XLDB.xls Case sTypeODBCAccess sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=Microsoft Access Driver (*.mdb)" & vbCrLf) sb.Append("UID=admin" & vbCrLf) sb.Append("UserCommitSync=Yes" & vbCrLf) sb.Append("Threads=3" & vbCrLf) sb.Append("SafeTransactions=0" & vbCrLf) sb.Append("PageTimeout=5" & vbCrLf) sb.Append("MaxScanRows=8" & vbCrLf) sb.Append("MaxBufferSize=2048" & vbCrLf) sb.Append("FIL=MS Access" & vbCrLf) sb.Append("DriverId=25" & vbCrLf) sb.Append("DefaultDir=" & sDossierSrc & vbCrLf) sb.Append("DBQ=" & sFichierSrc & vbCrLf) Case sTypeODBCOmnis ' Pilote : www.omnis.net/downloads/odbc/win32/Omnis%20ODBC%20Driver.exe sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=OMNIS ODBC Driver" & vbCrLf) sb.Append("UID=admin" & vbCrLf) sb.Append("Password=" & sMotDePasse & vbCrLf) sb.Append("Username=" & sCompteUtilisateur & vbCrLf) sb.Append("DataFilePath=" & sFichierSrc & vbCrLf) Case sTypeODBCNavision sSource = sCompteSociete ' Doc sur le pilote C-Odbc : ' http://www.comsolag.de/old/pdf/Handbuch/W1/w1w1codbc.pdf sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=C/ODBC 32 bit" & vbCrLf) sb.Append("UID=" & sCompteUtilisateur & vbCrLf) sb.Append("SERVER=N" & vbCrLf) ' Non documenté ! sb.Append("CN=" & sCompteSociete & vbCrLf) ' The account/company to open sb.Append("RD=No" & vbCrLf) ' Non documenté ! ' ML indique la langue utilisée : 1033 pour l'anglais (USA), ' 1036 pour le français. Les tables et les champs de la requête SQL ' doivent être dans la langue choisie. Il est apparemment impossible ' de faire passer les accents en français, donc laisser 1033. sb.Append("ML=1033" & vbCrLf) ' CD Specifies whether the connection supports closing date. sb.Append("CD=No" & vbCrLf) ' BE Specifies whether BLOB fields should be visible from ODBC. sb.Append("BE=Yes" & vbCrLf) ' CC Specifies whether the commit cache should be used. sb.Append("CC=Yes" & vbCrLf) ' RO Specifies whether access to the Microsoft Business Solutions ' database should be read-only. sb.Append("RO=No" & vbCrLf) sb.Append("QTYesNo=Yes" & vbCrLf) ' Enables or disables query time-out ' IT Specify the way identifiers are returned to an external application sb.Append("IT=All Except Space" & vbCrLf) ' OPT Specifies how the contents of a Navision option field are ' transferred to an application. sb.Append("OPT=Text" & vbCrLf) ' PPath : The name of the folder where the program files are located. Dim sLecteur$ = IO.Path.GetPathRoot(Environment.SystemDirectory) ' Ex.: C:\ sb.Append("PPath=" & sLecteur & _ "Program Files\Microsoft Business Solutions-Navision\Client" & vbCrLf) ' NType : The name of the network protocol module (tcp or netb). sb.Append("NType=tcp" & vbCrLf) sb.Append("SName=" & sNomServeur & vbCrLf) ' The name of the server host computer. ' CSF Specifies whether the driver operates as a client in a ' client/server environment or as a stand-alone. sb.Append("CSF=Yes" & vbCrLf) ' Attention : il n'est pas possible de crypter le mot de passe avec ce pilote : ' La doc recommande de créer un compte utilisateur spécifique avec les seuls ' droits requis pour l'exécution de la requête. sb.Append("PWD=" & sMotDePasse & vbCrLf) Case sTypeODBCDB2 ' DB2 = iSeries d'IBM (anciennement AS/400) sSource = sCompteSociete sb.Append("[ODBC]" & vbCrLf) sb.Append("DRIVER=Client Access ODBC Driver (32-bit)" & vbCrLf) sb.Append("UID=" & sCompteUtilisateur & vbCrLf) ' ou CA400 par défaut ' Pour DB2, il n'y a pas de mot de passe, il faut laisser une connexion ' ouverte et le pilote ODBC va réutiliser cette connexion. ' voir la doc avec SIGNON=1 ' (si la connexion n'est pas ouverte, le système devrait ouvrir une ' boite de dialogue pour saisir le mot de passe, mais je n'ai pas ' réussi à le faire marcher ainsi) sb.Append("DEBUG=64" & vbCrLf) sb.Append("SIGNON=1" & vbCrLf) sb.Append("LIBVIEW=1" & vbCrLf) sb.Append("TRANSLATE=1" & vbCrLf) sb.Append("NAM=1" & vbCrLf) sb.Append("DESC=Source de données ODBC iSeries Access for Windows" & vbCrLf) sb.Append("SQDIAGCODE=" & vbCrLf) sb.Append("DATABASE=" & vbCrLf) sb.Append("QAQQINILIB=" & vbCrLf) sb.Append("PKG=QGPL/DEFAULT(IBM),2,0,1,0,512" & vbCrLf) Dim sLecteur$ = IO.Path.GetPathRoot(Environment.SystemDirectory) ' Ex.: C:\ Dim sUtilisateur$ = Environment.UserName ' A vérifier : sUtilisateur = 'Utilisateur' littéralement ? sb.Append("TRACEFILENAME=" & sLecteur & _ "Documents and Settings\" & sUtilisateur & _ "\Mes documents\IBM\Client Access\Maintenance\Fichiers trace" & vbCrLf) sb.Append("SORTTABLE=" & vbCrLf) sb.Append("LANGUAGEID=ENU" & vbCrLf) sb.Append("XLATEDLL=" & vbCrLf) sb.Append("DFTPKGLIB=QGPL" & vbCrLf) ' A vérifier : ici on peut indiquer une autre librairie ' que la librairie QGPL par défaut ' ce qui évite d'avoir à préfixer les noms de table ' par la librairie dans les requêtes, le cas échéant sb.Append("DBQ=QGPL" & vbCrLf) sb.Append("SYSTEM=" & sNomServeur & vbCrLf) ' autre poss.: Adresse IP End Select If Not bEcrireFichier(sCheminDsn, sb) Then Exit Function ' On peut ne pas avoir besoin d'un fichier de requête SQL, ' si on les crée à la volée If sCheminSQL.Length > 0 And sSQL.Length > 0 Then If bFichierExiste(sCheminSQL) Then _ If Not bRenommerFichier(sCheminSQL, sCheminSQL & ".bak") Then _ Exit Function If Not bEcrireFichier(sCheminSQL, sSQL) Then Exit Function End If If Me.m_bPrompt Then _ MsgBox("Le fichier DSN pour la source ODBC " & sTypeODBC & " : " & vbLf & _ sSource & vbLf & "a été créé avec les chemins en local :" & vbLf & _ sCheminDsn, vbExclamation, sTitreMsg) bCreerFichierDsnODBC = True End Function Public Function bVerifierCheminODBC(ByVal sChampBD$, ByVal sContenuDSN$, _ Optional ByVal bDossier As Boolean = False) As Boolean ' Vérifier la présence de la source ODBC si le fichier DSN existe déjà Dim sContenuDSNMin$ = sContenuDSN.ToLower sChampBD = sChampBD.ToLower Dim iPosDeb% = sContenuDSNMin.IndexOf(sChampBD) Dim sCheminBd$ = "" If iPosDeb > -1 Then Dim iPosFin% = sContenuDSNMin.IndexOf(vbLf, iPosDeb + sChampBD.Length) If iPosFin > -1 Then sCheminBd = sContenuDSN.Substring( _ iPosDeb + sChampBD.Length, iPosFin - 1 - iPosDeb - sChampBD.Length) Else sCheminBd = sContenuDSN.Substring(iPosDeb + sChampBD.Length) End If If sCheminBd.Length = 0 Then MsgBox("Le chemin indiqué dans le fichier DSN pour " & sChampBD & _ " est vide !", MsgBoxStyle.Critical, sTitreMsg) Exit Function End If If Not bCheminFichierProbable(sCheminBd) Then ' Si le chemin ne correspond pas à un vrai chemin ' alors ne pas chercher à vérifier la présence du fichier ' poursuivre sans erreur bVerifierCheminODBC = True Exit Function End If Dim sDebutLigneChamp$ = sContenuDSNMin.Substring( _ iPosDeb - 3, sChampBD.Length) If sDebutLigneChamp.IndexOf(";") > -1 Then ' Si le chemin indiqué est en commentaire ' alors ignorer la ligne, poursuivre sans erreur bVerifierCheminODBC = True Exit Function End If End If bVerifierCheminODBC = True If sCheminBd.Length > 0 Then If bDossier Then bVerifierCheminODBC = bDossierExiste(sCheminBd, bPrompt:=True) Else bVerifierCheminODBC = bFichierExiste(sCheminBd, bPrompt:=True) End If End If End Function Public Function sLireNomPiloteODBC$(ByVal sContenuDSN$) ' Vérifier la présence de la source ODBC si le fichier DSN existe déjà Dim sContenuDSNMin$ = sContenuDSN.ToLower Dim sChampPilote$ = "driver=" Dim iPosDeb% = sContenuDSNMin.IndexOf(sChampPilote) Dim sNomPilote$ = "" If iPosDeb > -1 Then Dim iPosFin% = sContenuDSNMin.IndexOf(vbLf, iPosDeb + sChampPilote.Length) If iPosFin > -1 Then sNomPilote = sContenuDSN.Substring( _ iPosDeb + sChampPilote.Length, iPosFin - 1 - iPosDeb - sChampPilote.Length) Else sNomPilote = sContenuDSN.Substring(iPosDeb + sChampPilote.Length) End If End If sLireNomPiloteODBC = sNomPilote End Function #End Region End Class modUtil.vb ' Fichier modUtil.vb ' ------------------ Imports Microsoft.Win32 ' Pour RegistryKey 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 Function bCleRegistreLMExiste(ByVal sCle$, _ Optional ByVal sSousCle$ = "", _ Optional ByRef sValSousCle$ = "", _ Optional ByVal sNouvValSousCle$ = "") As Boolean ' Vérifier si une clé LocalMachine existe dans la base de registre sValSousCle = "" Try Dim bEcriture As Boolean = False If sNouvValSousCle.Length > 0 Then bEcriture = True ' Si la clé n'existe pas, on passe dans le Catch Using rkLMCle As RegistryKey = Registry.LocalMachine Using rkLMSousCle As RegistryKey = rkLMCle.OpenSubKey(sCle, writable:=bEcriture) Dim oVal As Object = rkLMSousCle.GetValue(sSousCle) ' Si la sous-clé n'existe pas, oVal reste à Nothing ' (aucune exception n'est générée) If IsNothing(oVal) Then Exit Function sValSousCle = CStr(oVal) ' Il faut aussi tester ce cas obligatoirement If IsNothing(sValSousCle) Then Exit Function If sNouvValSousCle.Length > 0 Then oVal = CInt(sNouvValSousCle) ' à retester ! rkLMSousCle.SetValue(sSousCle, oVal, RegistryValueKind.DWord) End If End Using ' rkLMSousCle.Close() est automatiquement appelé End Using ' rkLMCle.Close() est automatiquement appelé bCleRegistreLMExiste = True ' On peut lire cette clé, donc elle existe Catch End Try End Function Public Function 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 Public Sub TraiterMsgSysteme_DoEvents() Try Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire Catch End Try End Sub End Module modUtilFichier.vb ' Fichier modUtilFichier.vb : Module de gestion des fichiers ' ------------------------- Imports System.Text ' Pour StringBuilder 'Imports System.IO ' Pour Path, File, Directory... Module modUtilFichier Public Const sCauseErrPoss$ = _ "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" Public Const sCauseErrPossDossier$ = _ "Le dossier est peut-être protégé en écriture" & vbLf & _ "ou bien un fichier est verrouillé par une autre application" ' Le code page 1252 correspond à FileOpen de VB .NET, l'équivalent en VB6 de ' Open sCheminFichier For Input As #1 ' Mettre & pour Long en DotNet1 et % pour Integer en DotNet2 Public Const iCodePageWindowsLatin1252% = 1252 ' windows-1252 = msoEncodingWestern ' L'encodage UTF-8 est le meilleur compromis encombrement/capacité ' il permet l'encodage par exemple du grec, sans doubler la taille du texte '(mais le décodage est plus complexe en interne et les caractères ne s'affichent ' pas bien dans les certains logiciels utilitaires comme WinDiff, ' ni par exemple en csv pour Excel) ' http://fr.wikipedia.org/wiki/Unicode ' 65001 = Unicode UTF-8, 65000 = Unicode UTF-7 Public Const iEncodageUnicodeUTF8% = 65001 Public Const sEncodageISO_8859_1$ = "ISO-8859-1" #Region "Gestion des fichiers" Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _ ByVal sTitre$, Optional ByVal sInitDir$ = "", _ Optional ByVal bDoitExister As Boolean = True, _ Optional ByVal bMultiselect As Boolean = False) As Boolean ' Afficher une boite de dialogue pour choisir un fichier ' Exemple de filtre : "|Fichiers texte (*.txt)|*.txt|Tous les fichiers (*.*)|*.*" ' On peut indiquer le dossier initial via InitDir, ou bien via le chemin du fichier Static bInit As Boolean = False Dim ofd As New OpenFileDialog With ofd If Not bInit Then bInit = True If sInitDir.Length = 0 Then If sCheminFichier.Length = 0 Then .InitialDirectory = Application.StartupPath Else .InitialDirectory = IO.Path.GetDirectoryName(sCheminFichier) End If Else .InitialDirectory = sInitDir End If End If If Not String.IsNullOrEmpty(sCheminFichier) Then .FileName = sCheminFichier .CheckFileExists = bDoitExister ' 14/10/2007 .DefaultExt = sExtDef .Filter = sFiltre .Multiselect = bMultiselect .Title = sTitre .ShowDialog() If .FileName <> "" Then bChoisirFichier = True : sCheminFichier = .FileName End With End Function Public Function bFichierExiste(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt bFichierExiste = IO.File.Exists(sCheminFichier) If Not bFichierExiste And bPrompt Then _ MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _ MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable") End Function Public Function bFichierExisteFiltre(ByVal sCheminFiltre$, ByVal sFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si au moins un fichier correspondant au filtre est trouvé ' dans le répertoire indiqué, ex.: C:\Tmp avec *.txt Dim di As New IO.DirectoryInfo(sCheminFiltre) If Not di.Exists Then bFichierExisteFiltre = False : GoTo Fin Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés Dim iNbFichiers% = afi.GetLength(0) bFichierExisteFiltre = (iNbFichiers > 0) Fin: If Not bFichierExisteFiltre And bPrompt Then _ MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _ MsgBoxStyle.Critical, sTitreMsg & " - Fichiers introuvables") End Function Public Function bFichierExisteFiltre2(ByVal sCheminFiltre$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourner True si un fichier correspondant au filtre est trouvé ' Exemple de filtre : C:\Tmp\*.txt If sCheminFiltre.Length = 0 Then Exit Function 'bFichierExisteFiltre2 = (Len(Dir(sFiltre)) > 0) Dim sDossier$ = IO.Path.GetDirectoryName(sCheminFiltre) Dim sFiltre$ = IO.Path.GetFileName(sCheminFiltre) bFichierExisteFiltre2 = bFichierExisteFiltre(sDossier, sFiltre, bPrompt) End Function Public Function iNbFichiersFiltres%(ByVal sCheminDossier$, ByVal sFiltre$) ' Retourner le nombre de fichiers correspondants au filtre, par exemple : C:\ avec *.txt Dim di As New IO.DirectoryInfo(sCheminDossier) If Not di.Exists Then Exit Function Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Tableau de FileInfo iNbFichiersFiltres = fi.GetLength(0) End Function Public Function bCopierFichier(ByVal sCheminSrc$, ByVal sCheminDest$, _ Optional ByVal bPromptErr As Boolean = True, _ Optional ByVal bVerifierDate As Boolean = False) As Boolean If bVerifierDate Then If Not bFichierExiste(sCheminSrc, bPrompt:=True) Then Exit Function Dim dDateSrc As Date = IO.File.GetLastWriteTime(sCheminSrc) Dim lTailleSrc& = New IO.FileInfo(sCheminSrc).Length If bFichierExiste(sCheminDest) Then Dim dDateDest As Date = IO.File.GetLastWriteTime(sCheminDest) Dim lTailleDest& = New IO.FileInfo(sCheminDest).Length ' Si la date et la taille sont les mêmes, la copie est déjà faite ' (la vérification du hashcode serait plus sûr mais trop longue ' de toute façon : il serait alors plus rapide de tjrs recopier) If dDateSrc = dDateDest And lTailleSrc = lTailleDest Then _ bCopierFichier = True : Exit Function ' Sinon supprimer le fichier de destination If Not bSupprimerFichier(sCheminDest) Then Exit Function End If End If If Not bFichierExiste(sCheminSrc, bPromptErr) Then Exit Function 'If bFichierExiste(sDest) Then ' Déjà vérifié dans bSupprimerFichier If Not bSupprimerFichier(sCheminDest, bPromptErr) Then Exit Function 'End If Try IO.File.Copy(sCheminSrc, sCheminDest) bCopierFichier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bCopierFichier", _ "Impossible de copier le fichier source :" & vbLf & _ sCheminSrc & vbLf & "vers le fichier de destination :" & _ vbLf & sCheminDest, sCauseErrPoss) End Try End Function Public Function bSupprimerFichier(ByVal sCheminFichier$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then _ bSupprimerFichier = True : Exit Function If Not bFichierAccessible(sCheminFichier, _ bPromptFermer:=bPromptErr, bPromptRetenter:=bPromptErr) Then _ Exit Function ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) bSupprimerFichier = True Catch ex As Exception If bPromptErr Then _ MsgBox("Impossible de supprimer le fichier :" & vbLf & _ sCheminFichier & vbLf & _ sCauseErrPoss, MsgBoxStyle.Critical, sTitreMsg) End Try End Function Public Function bSupprimerFichiersFiltres(ByVal sCheminDossier$, ByVal sFiltre$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Supprimer tous les fichiers correspondants au filtre, par exemple : C:\ avec *.txt ' Si le dossier n'existe pas, on considère que c'est un succès If Not bDossierExiste(sCheminDossier) Then bSupprimerFichiersFiltres = True : Exit Function Dim asFichier$() = IO.Directory.GetFileSystemEntries(sCheminDossier, sFiltre) For Each sFichier As String In asFichier If Not bSupprimerFichier(sFichier, bPromptErr) Then Exit Function Next sFichier bSupprimerFichiersFiltres = True End Function Public Function bRenommerFichier(ByVal sSrc$, ByVal sDest$, _ Optional ByVal bConserverDest As Boolean = False) As Boolean ' Renommer ou déplacer un et un seul fichier If Not bFichierExiste(sSrc, bPrompt:=True) Then Exit Function If bConserverDest Then ' Cette option permet de conserver le fichier de destination s'il existe If bFichierExiste(sDest) Then ' Dans ce cas on supprime la source If Not bSupprimerFichier(sSrc, bPromptErr:=True) Then Exit Function bRenommerFichier = True Exit Function End If Else If Not bSupprimerFichier(sDest, bPromptErr:=True) Then Exit Function End If Try IO.File.Move(sSrc, sDest) bRenommerFichier = True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerFichier", _ "Impossible de renommer le fichier source :" & vbLf & _ sSrc & vbLf & "vers le fichier de destination :" & vbLf & sDest, _ sCauseErrPoss) End Try End Function Public Function bDeplacerFichiers2(ByVal sSrc$, ByVal sDest$) As Boolean ' Renommer ou déplacer une arborescence de fichiers ' Attention : cette fonction nécessite la suppression du dossier src ' voir aussi modUtilLT.bDeplacerFichiers et bDeplacerFichiers3 ' On pourrait faire plus rapide en déplacant les fichiers, mais tant pis ' Ex.: Déplacer C:\Tmp\*.txt -> C:\Tmp2\ ' Cette fonction est déjà dans : modUtilFichierLT.vb Dim bStatut As Boolean, sListeErr$ = "" If Not bCopierArbo(sSrc, sDest, bStatut, sListeErr) Then Exit Function Dim sDossierSrc$ = IO.Path.GetPathRoot(sSrc) If Not bSupprimerDossier(sDossierSrc, bPromptErr:=True) Then Exit Function bDeplacerFichiers2 = True End Function Public Function bDeplacerFichiers3(ByVal sCheminSrc$, ByVal sFiltre$, ByVal sCheminDest$, _ Optional ByVal bConserverDest As Boolean = True, _ Optional ByVal sExtDest$ = "", Optional ByVal sPrefixe$ = "") As Boolean ' Déplacer tous les fichiers correspondants au filtre dans le répertoire de destination ' en vérifiant s'ils existent déjà : dans ce cas, conserver le fichier de destination ' (option par défaut pour conserver la date) If Not bVerifierCreerDossier(sCheminDest) Then Exit Function Dim bChExt As Boolean = False If sExtDest.Length > 0 Then bChExt = True Dim di As New IO.DirectoryInfo(sCheminSrc) Dim aFi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = aFi.GetLength(0) Dim i% For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileName(aFi(i).Name) Dim sSrc$ = sCheminSrc & "\" & sFichier Dim sDest$ = sCheminDest & "\" & sFichier ' Option possible : changer l'extension du fichier ' par exemple rename *.csv *.txt If bChExt Then sDest = sCheminDest & "\" & sPrefixe & _ IO.Path.GetFileNameWithoutExtension(sFichier) & sExtDest If Not bRenommerFichier(sSrc, sDest, bConserverDest) Then Exit Function Next i bDeplacerFichiers3 = True End Function ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception <System.Diagnostics.DebuggerStepThrough()> _ Public Function bFichierAccessible(ByVal sCheminFichier$, _ Optional ByVal bPrompt As Boolean = False, _ Optional ByVal bPromptFermer As Boolean = False, _ Optional ByVal bInexistOk As Boolean = False, _ Optional ByVal bPromptRetenter As Boolean = False, _ Optional ByVal bLectureSeule As Boolean = False, _ Optional ByVal bEcriture As Boolean = True) As Boolean ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple) ' bEcriture = True par défaut (pour la rétrocompatibilité de la fct bFichierAccessible) ' Nouveau : Simple lecture : Mettre bEcriture = False ' On conserve l'option bLectureSeule pour alerter qu'un fichier doit être fermé ' par l'utilisateur (par exemple un classeur Excel ouvert) bFichierAccessible = False If bInexistOk Then ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas If Not bFichierExiste(sCheminFichier) Then ' Et ne pas alerter non plus bFichierAccessible = True Exit Function End If Else If Not bFichierExiste(sCheminFichier, bPrompt) Then Exit Function End If End If Retenter: Dim reponse As MsgBoxResult = MsgBoxResult.Cancel Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim mode As IO.FileMode = IO.FileMode.Open Dim access As IO.FileAccess = IO.FileAccess.ReadWrite If Not bEcriture Then access = IO.FileAccess.Read Using fs As New IO.FileStream(sCheminFichier, mode, access, IO.FileShare.ReadWrite) fs.Close() End Using bFichierAccessible = True Catch ex As Exception Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation If bPrompt Then AfficherMsgErreur2(ex, "bFichierAccessible", _ "Impossible d'accéder au fichier :" & vbLf & _ sCheminFichier, sCauseErrPoss) ElseIf bPromptFermer Then Dim sQuestion$ = "" If bPromptRetenter Then msgbs = msgbs Or MsgBoxStyle.RetryCancel sQuestion = vbLf & "Voulez-vous réessayer ?" End If ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons ! ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture ' par ex. certains fichiers du dossier ' \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\ If bLectureSeule Then ' Le verrouillage Excel peut ralentir une lecture ODBC, ' mais sinon la lecture directe n'est pas possible, même avec ' IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read ? ' (sauf si le fichier a l'attribut lecture seule) ' En fait si, à condition de préciser IO.FileShare.ReadWrite reponse = MsgBox( _ "Veuillez fermer S.V.P. le fichier :" & vbLf & _ sCheminFichier & sQuestion, msgbs, sTitreMsg) Else reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & _ sCheminFichier & vbLf & _ "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & _ "ses attributs de protection, ou alors les droits d'accès." & _ sQuestion, msgbs, sTitreMsg) End If End If End Try If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter End Function Public Sub ProposerOuvrirFichier(ByVal sCheminFichier$, _ Optional ByVal sInfo$ = "") If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub Dim lTailleFichier& = (New IO.FileInfo(sCheminFichier)).Length Dim sTailleFichier$ = sFormaterTailleOctets(lTailleFichier) Dim sMsg$ = _ "Le fichier " & IO.Path.GetFileName(sCheminFichier) & _ " a été créé avec succès :" & vbLf & _ sCheminFichier If sInfo.Length > 0 Then sMsg &= vbLf & sInfo sMsg &= vbLf & "Voulez-vous l'afficher ? (" & sTailleFichier & ")" If MsgBoxResult.Cancel = MsgBox(sMsg, _ MsgBoxStyle.Exclamation Or MsgBoxStyle.OkCancel, sTitreMsg) Then Exit Sub OuvrirAppliAssociee(sCheminFichier) End Sub Public Sub OuvrirAppliAssociee(ByVal sCheminFichier$, _ Optional ByVal bMax As Boolean = False, _ Optional ByVal bVerifierFichier As Boolean = True) If bVerifierFichier Then ' Ne pas vérifier le fichier si c'est une URL à lancer If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Sub End If Dim p As New Process p.StartInfo = New ProcessStartInfo(sCheminFichier) ' Il faut indiquer le chemin de l'exe si on n'utilise pas le shell 'p.StartInfo.UseShellExecute = False If bMax Then p.StartInfo.WindowStyle = ProcessWindowStyle.Maximized p.Start() End Sub Public Function sFormaterTailleOctets$(ByVal lTailleOctets&, _ Optional ByVal bDetail As Boolean = False, _ Optional ByVal bSupprimerPt0 As Boolean = False) ' Renvoyer une taille de fichier bien formatée dans une chaîne de caractère ' Sinon il existe aussi l'API StrFormatByteSizeA dans shlwapi.dll ' 1024 est la norme actuellement employée dans Windows, ' mais 1000 sera peut être un jour la norme ' http://fr.wikipedia.org/wiki/Octet Dim rNbKo! = CSng(Math.Round(lTailleOctets / 1024, 1)) Dim rNbMo! = CSng(Math.Round(lTailleOctets / (1024 * 1024), 1)) Dim rNbGo! = CSng(Math.Round(lTailleOctets / (1024 * 1024 * 1024), 1)) Dim sAffichage$ = "" If bDetail Then sAffichage = sFormaterNumerique(lTailleOctets) & " octets" If rNbKo >= 1 Then sAffichage &= " (" & sFormaterNumerique(rNbKo) & " Ko" If rNbMo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbMo) & " Mo" If rNbGo >= 1 Then sAffichage &= " = " & sFormaterNumerique(rNbGo) & " Go" If rNbKo >= 1 Or rNbMo >= 1 Or rNbGo >= 1 Then sAffichage &= ")" Else If rNbGo >= 1 Then sAffichage = sFormaterNumerique(rNbGo, bSupprimerPt0) & " Go" ElseIf rNbMo >= 1 Then sAffichage = sFormaterNumerique(rNbMo, bSupprimerPt0) & " Mo" ElseIf rNbKo >= 1 Then sAffichage = sFormaterNumerique(rNbKo, bSupprimerPt0) & " Ko" Else sAffichage = sFormaterNumerique(lTailleOctets, _ bSupprimerPt0:=True) & " octets" End If End If sFormaterTailleOctets = sAffichage End Function Public Function sFormaterNumerique$(ByVal rVal!, _ Optional ByVal bSupprimerPt0 As Boolean = True, _ Optional ByVal iNbDecimales% = 1) ' Formater un numérique avec une précision d'une décimale ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 Dim nfi As Globalization.NumberFormatInfo = _ New Globalization.NumberFormatInfo ' Définition des spérateurs numériques nfi.NumberGroupSeparator = " " ' Séparateur des milliers, millions... nfi.NumberDecimalSeparator = "." ' Séparateur décimal ' 3 groupes pour milliard, million et millier ' (on pourrait en ajouter un 4ème pour les To : 1000 Go) nfi.NumberGroupSizes = New Integer() {3, 3, 3} nfi.NumberDecimalDigits = iNbDecimales ' 1 décimale de précision sFormaterNumerique = rVal.ToString("n", nfi) ' n : numérique général ' Enlever la décimale si 0 If bSupprimerPt0 Then If iNbDecimales = 1 Then sFormaterNumerique = sFormaterNumerique.Replace(".0", "") ElseIf iNbDecimales > 1 Then Dim i% Dim sb As New StringBuilder(".") For i = 1 To iNbDecimales : sb.Append("0") : Next sFormaterNumerique = sFormaterNumerique.Replace(sb.ToString, "") End If End If End Function Public Function sFormaterNumerique2$(ByVal rVal!) ' Formater un numérique selon le format choisi dans le panneau de config. ' Le format numérique standard est correct (séparation des milliers et plus), ' il suffit juste d'enlever la décimale inutile si 0 'sFormaterNumerique2 = rVal.ToString("n").Replace(".00", "") ' n : numérique général ' Vérifier , et . : sFormaterNumerique2 = rVal.ToString("n").Replace(",00", "").Replace(".00", "") ' n : numérique général End Function #End Region #Region "Gestion des dossiers" Public Function bVerifierCreerDossier(ByVal sCheminDossier$, _ Optional ByVal bPrompt As Boolean = True) As Boolean ' Vérifier si le dossier existe, et le créer sinon Dim di As New IO.DirectoryInfo(sCheminDossier) If di.Exists Then bVerifierCreerDossier = True : Exit Function Try di.Create() di = New IO.DirectoryInfo(sCheminDossier) If di.Exists Then bVerifierCreerDossier = True : Exit Function Catch ex As Exception If bPrompt Then _ MsgBox("Impossible de créer le dossier :" & vbCrLf & _ sCheminDossier & vbCrLf & ex.Message, _ MsgBoxStyle.Critical, sTitreMsg) 'MsgBox("Impossible de créer le dossier :" & vbCrLf & sCheminDossier, _ ' MsgBoxStyle.Critical, sTitreMsg) End Try End Function Public Function bDossierExiste(ByVal sCheminDossier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un dossier correspondant au filtre sFiltre est trouvé 'Dim di As New IO.DirectoryInfo(sCheminDossier) 'bDossierExiste = di.Exists() bDossierExiste = IO.Directory.Exists(sCheminDossier) If Not bDossierExiste And bPrompt Then _ MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, _ MsgBoxStyle.Critical, sTitreMsg & " - Dossier introuvable") End Function Public Function bRenommerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bDeplacerDossier If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function If Not bSupprimerDossier(sCheminDossierDest, bPromptErr:=True) Then Exit Function Try IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) bRenommerDossier = True Catch ex As Exception AfficherMsgErreur2(ex, "bRenommerDossier", _ "Impossible de renommer le dossier source :" & vbLf & _ sCheminDossierSrc & vbLf & _ "vers le dossier de destination :" & vbLf & sCheminDossierDest, _ sCauseErrPossDossier) End Try End Function Public Function bDeplacerDossier(ByVal sCheminDossierSrc$, ByVal sCheminDossierDest$, _ Optional ByVal bPromptErr As Boolean = True) As Boolean ' Renommer ou déplacer un et un seul dossier ' Idem bRenommerDossier ' Roir aussi My.Computer.MoveDirectory en DotNet2 If Not bDossierExiste(sCheminDossierSrc, bPrompt:=True) Then Exit Function If Not bSupprimerDossier(sCheminDossierDest, bPromptErr) Then Exit Function Try 'Dim di As New IO.DirectoryInfo(sCheminDossierSrc) 'di.MoveTo(sCheminDossierDest) IO.Directory.Move(sCheminDossierSrc, sCheminDossierDest) bDeplacerDossier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bDeplacerDossier", _ "Impossible de déplacer le dossier source :" & vbLf & sCheminDossierSrc & vbLf & _ "vers le dossier de destination :" & vbLf & sCheminDossierDest, _ sCauseErrPossDossier) End Try End Function Public Function bSupprimerDossier(ByVal sCheminDossier$, _ Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier si le dossier existe If Not bDossierExiste(sCheminDossier) Then _ bSupprimerDossier = True : Exit Function Try IO.Directory.Delete(sCheminDossier, recursive:=True) ' Si l'explorateur est ouvert sur le dossier, il faut attendre qq sec. ' pour que le dossier soit bien détruit Dim i% = 0 While bDossierExiste(sCheminDossier) And i < 10 'TraiterMsgSysteme_DoEvents() Application.DoEvents() Threading.Thread.Sleep(1000) i += 1 End While If i = 10 Then If bPromptErr Then _ MsgBox("Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, MsgBoxStyle.Critical, sTitreMsg) Exit Function End If bSupprimerDossier = True Catch ex As Exception If bPromptErr Then _ AfficherMsgErreur2(ex, "bSupprimerDossier", _ "Impossible de supprimer le dossier :" & vbLf & _ sCheminDossier, sCauseErrPossDossier) End Try End Function Public Function sDossierParent$(ByVal sCheminDossier$) ' Renvoyer le chemin du dossier parent ' Ex.: C:\Tmp\Tmp2 -> C:\Tmp ' (à renommer plutot en sCheminDossierParent ?) ' Ex. avec un chemin de fichier ' C:\Tmp\MonFichier.txt -> C:\Tmp ' Ex. avec un chemin de fichier avec filtre ' C:\Tmp\*.txt -> C:\Tmp sDossierParent = IO.Path.GetDirectoryName(sCheminDossier) End Function Public Function sNomDossierFinal$(ByVal sCheminDossier$) ' Renvoyer le nom du dernier dossier à partir du chemin du dossier ' Exemples : ' C:\Tmp\Tmp\MonDossier -> MonDossier ' C:\MonDossier\ -> MonDossier ' (si on passe un fichier en argument, alors c'est le fichier qui est renvoyé) sNomDossierFinal = sCheminDossier sCheminDossier = sEnleverSlashFinal(sCheminDossier) Dim iPosDossier% = sCheminDossier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierFinal = sCheminDossier.Substring(iPosDossier + 1) End Function Public Function sExtraireChemin$(ByVal sCheminFichier$, _ Optional ByRef sNomFichier$ = "", Optional ByRef sExtension$ = "", _ Optional ByRef sNomFichierSansExt$ = "") ' Retourner le chemin du fichier passé en argument ' Non compris le caractère \ ' Retourner aussi le nom du fichier sans le chemin ainsi que son extension ' Exemple : ' C:\Tmp\MonFichier.txt -> C:\Tmp, MonFichier.txt, .txt, MonFichier sExtraireChemin = IO.Path.GetDirectoryName(sCheminFichier) sNomFichier = IO.Path.GetFileName(sCheminFichier) sNomFichierSansExt = IO.Path.GetFileNameWithoutExtension(sCheminFichier) sExtension = IO.Path.GetExtension(sCheminFichier) '(avec le point, ex.: .txt) End Function Public Function sNomDossierParent$(ByVal sCheminDossierOuFichier$, _ Optional ByVal sCheminReference$ = "") ' Renvoyer le nom du dernier dossier parent à partir du chemin du dossier ' et renvoyer aussi le fichier avec si on passe le chemin complet du fichier ' sauf si le dossier parent n'existe pas : chemin de référence ' Exemples avec un dossier : ' C:\Tmp\Tmp\MonDossier -> \Tmp\MonDossier ' C:\MonDossier -> \MonDossier ' Exemples avec un fichier : ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt sNomDossierParent = "" Dim iPosDossier% = sCheminDossierOuFichier.LastIndexOf("\") If iPosDossier < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossier) ' Si c'est le chemin de référence, on le renvoit tel quel Dim sCheminDossierParent$ = IO.Path.GetDirectoryName(sCheminDossierOuFichier) If sCheminDossierParent = sEnleverSlashFinal(sCheminReference) Then Exit Function Dim iFin% = iPosDossier - 1 Dim iPosDossierParent% = sCheminDossierOuFichier.LastIndexOf("\", iFin) If iPosDossierParent < 0 Then Exit Function sNomDossierParent = sCheminDossierOuFichier.Substring(iPosDossierParent) End Function Public Function sCheminRelatif$(ByVal sCheminFichier$, ByVal sCheminReference$) ' Renvoyer le chemin relatif au chemin de référence ' à partir du chemin complet du fichier ' Exemples avec C:\ pour le chemin de référence ' C:\Tmp\Tmp\MonFichier.txt -> \Tmp\Tmp\MonFichier.txt ' C:\MonFichier.txt -> \MonFichier.txt ' Exemple avec C:\Tmp1 pour le chemin de référence ' C:\Tmp1\Tmp2\MonFichier.txt -> \Tmp2\MonFichier.txt sCheminReference = sEnleverSlashFinal(sCheminReference) sCheminRelatif = sCheminFichier.Substring(sCheminReference.Length) End Function Public Function sEnleverSlashFinal$(ByVal sChemin$) ' Enlever le slash final à la fin du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashFinal = "" : Exit Function If sChemin.EndsWith("\") Then sEnleverSlashFinal = sChemin.Substring(0, sChemin.Length - 1) Else sEnleverSlashFinal = sChemin End If End Function Public Function sEnleverSlashInitial$(ByVal sChemin$) ' Enlever le slash au début du chemin, le cas échéant If IsNothing(sChemin) OrElse sChemin.Length = 0 Then _ sEnleverSlashInitial = "" : Exit Function If sChemin.StartsWith("\") Then sEnleverSlashInitial = sChemin.Substring(1) Else sEnleverSlashInitial = sChemin End If End Function Public Function bCopierArbo(ByVal sSrc$, ByVal sDest$, _ ByRef bStatut As Boolean, _ ByRef sListeErr$, Optional ByVal sListeErrExcep$ = "") As Boolean ' Copier une arborescence de fichiers ' en retournant bStatut : Succès ou Echec de la fonction récursive ' En cas d'échec, la liste des fichiers n'ayant pu être copiés est ' indiquée dans sListeErr (sListeErrExcep permet d'exclure des fichiers ' de ce rapport si on sait déjà qu'on ne pourra les copier) ' Voir aussi : Zeta Folder XCOPY By Uwe Keim ' A small class to perform basic XCOPY like operations from within C# ' http://www.codeproject.com/KB/recipes/ZetaFolderXCopy.aspx If sDest.Chars(sDest.Length - 1) <> IO.Path.DirectorySeparatorChar Then _ sDest &= IO.Path.DirectorySeparatorChar Try If Not IO.Directory.Exists(sDest) Then IO.Directory.CreateDirectory(sDest) Catch ex As Exception AfficherMsgErreur2(ex, "bCopierArbo", _ "Impossible de créer le dossier :" & vbLf & _ sDest, sCauseErrPossDossier) Exit Function End Try Dim aElements$() = IO.Directory.GetFileSystemEntries(sSrc) For Each sCheminElements As String In aElements Dim sNomElements$ = IO.Path.GetFileName(sCheminElements) If IO.Directory.Exists(sCheminElements) Then ' L'élement est un sous-dossier : le copier bCopierArbo(sCheminElements, sDest & sNomElements, bStatut, _ sListeErr, sListeErrExcep) Else ' Sinon copier le fichier Try IO.File.Copy(sCheminElements, sDest & sNomElements, True) Catch ex As Exception If sListeErrExcep.IndexOf(" " & sNomElements & " ") = -1 Then ' Noter le chemin du fichier imposs. à copier ssi pas exception If sListeErr.Length < 200 Then If sListeErr.Length = 0 Then sListeErr = sDest & sNomElements Else sListeErr &= vbLf & sDest & sNomElements End If ElseIf Right$(sListeErr, 3) <> "..." Then sListeErr &= vbLf & "..." End If bStatut = False ' Il y a des erreurs particulières End If End Try End If Next bCopierArbo = bStatut End Function Public Function sLecteurDossier$(ByVal sDossier$) ' Renvoyer le lecteur du dossier sans \ à la fin ' Exemple : C:\Tmp -> C: sLecteurDossier = sEnleverSlashFinal(IO.Path.GetPathRoot(sDossier)) End Function #End Region #Region "Gestion de la lecture et de l'écriture de fichiers" Public Function sLireFichier$(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) ' Lire et renvoyer le contenu d'un fichier sLireFichier = "" If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim sbContenu As New StringBuilder Dim bDebut As Boolean = False Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbContenu.Append(vbCrLf) bDebut = True sbContenu.Append(sLigne) Loop While True End Using : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sLireFichier") Exit Function End Try sLireFichier = sbContenu.ToString End Function Public Function sbLireFichier(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) As StringBuilder ' Lire et renvoyer le contenu d'un fichier sbLireFichier = New StringBuilder If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim bDebut As Boolean = False Try ' Si Excel a verrouillé le fichier, une simple ouverture en lecture ' est permise à condition de préciser aussi IO.FileShare.ReadWrite Dim share As IO.FileShare = IO.FileShare.Read ' Valeur par défaut If bLectureSeule Then share = IO.FileShare.ReadWrite Using fs As New IO.FileStream(sCheminFichier, IO.FileMode.Open, _ IO.FileAccess.Read, share) ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv Using sr As New IO.StreamReader(fs, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) Do Dim sLigne$ = sr.ReadLine() If IsNothing(sLigne) Then Exit Do If bDebut Then sbLireFichier.Append(vbCrLf) bDebut = True sbLireFichier.Append(sLigne) Loop While True End Using : End Using Catch ex As Exception AfficherMsgErreur2(ex, "sbLireFichier") End Try End Function Public Function asLireFichier(ByVal sCheminFichier$, _ Optional ByVal bLectureSeule As Boolean = False) As String() ' Lire et renvoyer le contenu d'un fichier asLireFichier = Nothing If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Try If bLectureSeule Then Using fs As New IO.FileStream(sCheminFichier, _ IO.FileMode.Open, IO.FileAccess.Read, IO.FileShare.ReadWrite) Using sr As New IO.StreamReader(fs, Encoding.GetEncoding(iCodePageWindowsLatin1252)) Dim lst As New Collections.Generic.List(Of String) While Not sr.EndOfStream lst.Add(sr.ReadLine()) End While asLireFichier = lst.ToArray End Using : End Using Else asLireFichier = IO.File.ReadAllLines(sCheminFichier, _ Encoding.GetEncoding(iCodePageWindowsLatin1252)) End If Catch ex As Exception AfficherMsgErreur2(ex, "asLireFichier") End Try End Function Public Function bEcrireFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder, _ Optional ByVal bEncodageDefaut As Boolean = False, _ Optional ByVal bEncodageISO_8859_1 As Boolean = False, _ Optional ByVal bEncodageUFT8 As Boolean = False, _ Optional ByVal iEncodage% = 0, Optional ByVal sEncodage$ = "", _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Exit Function End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUFT8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sbContenu.ToString()) sw.Close() bEcrireFichier = True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bEcrireFichier(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal bEncodageDefaut As Boolean = False, _ Optional ByVal bEncodageISO_8859_1 As Boolean = False, _ Optional ByVal bEncodageUFT8 As Boolean = False, _ Optional ByVal iEncodage% = 0, Optional ByVal sEncodage$ = "", _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean 'Reessayer: ' Déjà pris en charge dans bSupprimerFichier If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then 'Dim iReponse% = MsgBox( _ ' "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _ ' "Voulez-vous réessayer ?", _ ' MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg) 'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer Exit Function End If Dim sw As IO.StreamWriter = Nothing Try If bEncodageDefaut Then ' Pour produire un document xml valide, il faut laisser l'encodage par défaut ' de DotNet, sinon certains caractères spéciaux ne passent pas, comme ø ' Encoding.Default ? sw = New IO.StreamWriter(sCheminFichier, append:=False) Else Dim encodage As Encoding If bEncodageISO_8859_1 Then encodage = Encoding.GetEncoding(sEncodageISO_8859_1) ElseIf bEncodageUFT8 Then encodage = Encoding.UTF8 ' Même chose que : 'encodage = Encoding.GetEncoding(iEncodageUnicodeUTF8) ElseIf iEncodage > 0 Then encodage = Encoding.GetEncoding(iEncodage) ElseIf sEncodage.Length > 0 Then encodage = Encoding.GetEncoding(sEncodage) Else ' Encodage par défaut de VB6 et de Windows en français encodage = Encoding.GetEncoding(iCodePageWindowsLatin1252) End If sw = New IO.StreamWriter(sCheminFichier, append:=False, Encoding:=encodage) End If sw.Write(sContenu) sw.Close() bEcrireFichier = True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bEcrireFichier", sMsg) Finally If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, ByVal sContenu$, _ Optional ByVal bPrompt As Boolean = True, _ Optional ByRef sMsgErr$ = "") As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Exit Function 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sContenu) End Using 'sw.Close() bAjouterFichier = True Catch ex As Exception Dim sMsg$ = "Impossible d'écrire les données dans le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPrompt Then AfficherMsgErreur2(ex, "bAjouterFichier", sMsg) 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bAjouterFichier(ByVal sCheminFichier$, _ ByVal sbContenu As StringBuilder) As Boolean ' Vérification de l'acces en écriture auparavant If Not bFichierAccessible(sCheminFichier, bPromptFermer:=True, _ bInexistOk:=True, bPromptRetenter:=True) Then Exit Function 'Dim sw As IO.StreamWriter = Nothing Try Using sw As New IO.StreamWriter(sCheminFichier, append:=True, _ Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252)) sw.Write(sbContenu.ToString()) End Using 'sw.Close() bAjouterFichier = True Catch ex As Exception AfficherMsgErreur2(ex, "bAjouterFichier", _ "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier) 'Finally ' If Not IsNothing(sw) Then sw.Close() End Try End Function Public Function bReencoder(ByVal sCheminFichier$) As Boolean ' Réencoder un fichier avec les sauts de ligne Unix (vbLf) en fichier Windows (vbCrLf) If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function Dim sb As StringBuilder = sbLireFichier(sCheminFichier) If sb.Length = 0 Then Exit Function bReencoder = bEcrireFichier(sCheminFichier, sb.Append(vbCrLf)) End Function #End Region #Region "Divers" Public Function asArgLigneCmd(ByVal sLigneCmd$, _ Optional ByVal bSupprimerEspaces As Boolean = True) As String() ' Retourner les arguments de la ligne de commande Dim asArgs$() = Nothing If String.IsNullOrEmpty(sLigneCmd) Then ReDim asArgs(0) asArgs(0) = "" asArgLigneCmd = asArgs Exit Function End If 'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg ' Parser les noms cours : facile 'asArgs = Split(Command, " ") ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : "" ' une fois le nom traité, les guillemets sont enlevés ' S'il y a un non court parmi eux, il n'est pas entre guillemets Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim iNbArg%, sFichier$, sSepar$ Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong As Boolean sCmd = sLigneCmd iLen = Len(sCmd) iDeb = 1 Do bNomLong = False : sSepar = " " ' Si le premier caractère est un guillement, c'est un nom long If Mid$(sCmd, iDeb, 1) = sGm Then bNomLong = True : sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong Then iDeb2 += 1 ' Bug corrigé : iDeb2 + 1 et non iDeb2 + 2 iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True : iFin = iLen + 1 'sFichier = Trim$(Mid$(sCmd, iDeb2, iFin - iDeb2)) sFichier = Mid$(sCmd, iDeb2, iFin - iDeb2) If bSupprimerEspaces Then sFichier = Trim$(sFichier) If sFichier <> "" Then ReDim Preserve asArgs(iNbArg) asArgs(iNbArg) = sFichier iNbArg += 1 End If If bFin Or iFin = iLen Then Exit Do iDeb = iFin + 1 If bNomLong Then iDeb = iFin + 2 Loop Const iCodeGuillemets% = 34 Dim iNumArg% For iNumArg = 0 To UBound(asArgs) 'If bSupprimerEspaces Then ' asArgs(iNumArg) = Trim$(asArgs(iNumArg)) 'Else ' asArgs(iNumArg) = asArgs(iNumArg) 'End If Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide If Len(sArg) = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" End If Next iNumArg asArgLigneCmd = asArgs End Function Public Function sConvNomDos$(ByVal sChaine$, _ Optional ByVal bLimit8Car As Boolean = False, _ Optional ByVal bConserverSignePlus As Boolean = False) ' Remplacer les caractères interdits pour les noms de fichiers DOS ' et retourner un nom de fichier 8.3 correct si demandé Dim iSel%, sBuffer$, sCar$, iCode%, sCarConv2$, sCarDest$ Dim bOk As Boolean, bMaj As Boolean sBuffer = Trim$(sChaine) If bLimit8Car Then sBuffer = Left$(sBuffer, 8) Const sCarConv$ = " .«»/[]:;|=,*-" ' Caractères à convertir en souligné sCarConv2 = sCarConv If Not bConserverSignePlus Then sCarConv2 &= "+" For iSel = 1 To Len(sBuffer) sCar = Mid$(sBuffer, iSel, 1) iCode = Asc(sCar) bMaj = False If iCode >= 65 And iCode <= 90 Then bMaj = True If iCode >= 192 And iCode <= 221 Then bMaj = True If InStr(sCarConv2, sCar) > 0 Then _ Mid$(sBuffer, iSel, 1) = "_" : GoTo Suite If InStr("èéêë", sCar) > 0 Then If bMaj Then sCarDest = "E" Else sCarDest = "e" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("àáâä", sCar) > 0 Then If bMaj Then sCarDest = "A" Else sCarDest = "a" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ìíîï", sCar) > 0 Then If bMaj Then sCarDest = "I" Else sCarDest = "i" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If InStr("ùúûü", sCar) > 0 Then If bMaj Then sCarDest = "U" Else sCarDest = "u" Mid$(sBuffer, iSel, 1) = sCarDest GoTo Suite End If If bConserverSignePlus And iCode = 43 Then GoTo Suite 'de 65 à 90 maj 'de 97 à 122 min 'de 48 à 57 Chiff bOk = False If (iCode >= 65 And iCode <= 90) Then bOk = True If (iCode >= 97 And iCode <= 122) Then bOk = True If (iCode >= 48 And iCode <= 57) Then bOk = True If Not bOk Then Mid$(sBuffer, iSel, 1) = "_" Suite: Next iSel sConvNomDos = sBuffer End Function #End Region End Module