VBXL v1.0.4.*

Table des procédures

1 - AssemblyInfo.vb

2 - modMain.vb
    2.1 - Private Sub Depart
    2.2 - Private Sub SauverConfigErr
    2.3 - Public Sub Main
    2.4 - Public Sub SauverConfig

3 - frmVBXL.vb
    3.1 - Private Sub AfficherInfoCellule
    3.2 - Private Sub AfficherMessage
    3.3 - Private Sub AfficherMessage
    3.4 - Private Sub APropos
    3.5 - Private Sub ChargerModele
    3.6 - Private Sub Demo_AjusterAuContenu
    3.7 - Private Sub Demo_CDPatrice
    3.8 - Private Sub Demo_Coller
    3.9 - Private Sub Demo_ExporterExcel
    3.10 - Private Sub Demo_ExporterWord
    3.11 - Private Sub Demo_ExporterWordModele
    3.12 - Private Sub Demo_FilmsIMDB
    3.13 - Private Sub Demo_FilmsPatrice
    3.14 - Private Sub Demo_LectureSeule
    3.15 - Private Sub Demo_ModifierStructure
    3.16 - Private Sub Demo_ODBC_XL
    3.17 - Private Sub Demo_Rechercher
    3.18 - Private Sub Demo_Scroll
    3.19 - Private Sub Demo_Scroll_Noter
    3.20 - Private Sub Demo_Scroll_Restaurer
    3.21 - Private Sub Demo_TailleFonteMoins
    3.22 - Private Sub Demo_TailleFontePlus
    3.23 - Private Sub Demo_TesterVitesse
    3.24 - Private Sub Demo_Trier
    3.25 - Private Sub Effacer
    3.26 - Private Sub EffacerTout
    3.27 - Private Sub frmVBXL_Closing
    3.28 - Private Sub frmVBXL_Load
    3.29 - Private Sub InitialiserVBXL
    3.30 - Private Sub lbDemo_Click
    3.31 - Private Sub lbDemo_DoubleClick
    3.32 - Private Sub Presentation
    3.33 - Private Sub RemplirFeuille
    3.34 - Private Sub ucT_CelluleClic
    3.35 - Private Sub ucT_CelluleDblClic
    3.36 - Private Sub ucT_EvCelluleChange
    3.37 - Private Sub ucT_EvSelectionChange

4 - modUtilitaire.vb
    4.1 - Public Function bAppliDejaOuverte
    4.2 - Public Function bCleRegistreCRExiste
    4.3 - Public Function bCleRegistreLMExiste
    4.4 - Public Function bCreerObjet
    4.5 - Public Function bEnregistrerDllActiveX
    4.6 - Public Function bVerifierDllActiveX
    4.7 - Public Function iConv%
    4.8 - Public Function rConvStrEnReel!
    4.9 - Public Function sValeurPtDecimal$
    4.10 - Public Function sValeurPtDecimal$
    4.11 - Public Sub AfficherMsgErreur
    4.12 - Public Sub AfficherMsgErreur2
    4.13 - Public Sub CopierPressePapier
    4.14 - Public Sub LibererRessourceDotNet
    4.15 - Public Sub LibererRessourcesDotNet
    4.16 - Public Sub Sablier
    4.17 - Public Sub TraiterMsgSysteme_DoEvents
    4.18 - Public Sub VerifierVersionExe

5 - modUtilLT.vb
    5.1 - Private Sub LibererObjetCom
    5.2 - Public Function bExporterExcel
    5.3 - Public Function bResauverFichierExcel
    5.4 - Public Function bVerifierInstallObjet
    5.5 - Public Sub ExporterWord

6 - modUtilOWC.vb
    6.1 - Public Function bChangerSeparateurDecimal
    6.2 - Public Function bVerifierADO
    6.3 - Public Function bVerifierComposants
    6.4 - Public Function bVerifierFichiers
    6.5 - Public Function bVerifierOWC

7 - ucTableur.vb
    7.1 - <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent
    7.2 - <System.Diagnostics.DebuggerStepThrough()> Public Sub SelectionnerPlage
    7.3 - Private Function bPlageInvalide
    7.4 - Private Function sLireCelluleActive$
    7.5 - Private Function sValEvInfo$
    7.6 - Private Sub Initialisation
    7.7 - Private Sub oXL_BeforeCommand
    7.8 - Private Sub oXL_ClickEvent
    7.9 - Private Sub oXL_CommandBeforeExecute
    7.10 - Private Sub oXL_DblClick
    7.11 - Private Sub oXL_DblClick
    7.12 - Private Sub oXL_KeyPressEvent
    7.13 - Private Sub oXL_KeyPressEvent
    7.14 - Private Sub oXL_MouseDownEvent
    7.15 - Private Sub oXL_MouseUpEvent
    7.16 - Private Sub oXL_SelectionChange
    7.17 - Private Sub oXL_SelectionChange
    7.18 - Private Sub oXL_StartEdit
    7.19 - Private Sub oXL_StartEdit
    7.20 - Protected Overloads Overrides Sub Dispose
    7.21 - Public Function bChercher
    7.22 - Public Function bExporterExcel
    7.23 - Public Function bInitFeuilleXL
    7.24 - Public Function bPlusieursLignesSelectionnees
    7.25 - Public Function iColEnCours%
    7.26 - Public Function iColFinPlage%
    7.27 - Public Function iColPlage%
    7.28 - Public Function iConvLettresEnNum%
    7.29 - Public Function iDerniereLigneSelectionnee%
    7.30 - Public Function iLigneEnCours%
    7.31 - Public Function iLigneFinPlage%
    7.32 - Public Function iLignePlage%
    7.33 - Public Function iPremiereLigneSelectionnee%
    7.34 - Public Function rLireCellule!
    7.35 - Public Function sConvEnPlage$
    7.36 - Public Function sConvNumEnLettres$
    7.37 - Public Function sLireCellule$
    7.38 - Public Function sLireCellule2$
    7.39 - Public Function sLireCouleurFondCellule$
    7.40 - Public Function sLireFormule$
    7.41 - Public Function sPlageSelectionnee$
    7.42 - Public Function sPlageUtilisee$
    7.43 - Public Property bActivationSimpleClic
    7.44 - Public Property bActiverCalculAuto
    7.45 - Public Property bActiverCalculAuto
    7.46 - Public Property bAfficherBarreDefilH
    7.47 - Public Property bAfficherBarreDefilV
    7.48 - Public Property bAfficherBarreOutils
    7.49 - Public Property bAfficherBarreTitre
    7.50 - Public Property bAfficherEntetesColonne
    7.51 - Public Property bAfficherEntetesColonne
    7.52 - Public Property bAfficherEntetesLigne
    7.53 - Public Property bAfficherEntetesLigne
    7.54 - Public Property bAfficherMsgErr
    7.55 - Public Property bAfficherOngletFeuille
    7.56 - Public Property bAfficherOngletFeuille
    7.57 - Public Property bAfficherQuadrillage
    7.58 - Public Property bCollageInterdit
    7.59 - Public Property bLectureSeule
    7.60 - Public Property bModifierStructureInterdit
    7.61 - Public Property bProtegerFeuille
    7.62 - Public Property bVerrouillerCellule
    7.63 - Public Property bVerrouillerPlage
    7.64 - Public Property iScrollH%
    7.65 - Public Property iScrollH%
    7.66 - Public Property iScrollV%
    7.67 - Public Property iScrollV%
    7.68 - Public Property sTitre$
    7.69 - Public ReadOnly Property iPositionHPlage%
    7.70 - Public ReadOnly Property iPositionHPlage%
    7.71 - Public ReadOnly Property iPositionVPlage%
    7.72 - Public ReadOnly Property iPositionVPlage%
    7.73 - Public ReadOnly Property sMinColVisible$
    7.74 - Public ReadOnly Property sMinColVisible$
    7.75 - Public ReadOnly Property sMinLigneVisible$
    7.76 - Public ReadOnly Property sMinLigneVisible$
    7.77 - Public Sub AffichageColonne
    7.78 - Public Sub AffichageLigne
    7.79 - Public Sub AjusterCellulesAuContenu
    7.80 - Public Sub AnnulerEdition
    7.81 - Public Sub AnnulerEdition
    7.82 - Public Sub ChangerCouleurBordCellule
    7.83 - Public Sub ChangerCouleurBordCellules
    7.84 - Public Sub ChangerCouleurFondCellule
    7.85 - Public Sub ChangerCouleurFondCellules
    7.86 - Public Sub ChangerCouleurFonteCellule
    7.87 - Public Sub ChangerEpaisseurFonteCellule
    7.88 - Public Sub CommencerModif
    7.89 - Public Sub CopierPressePapier
    7.90 - Public Sub DefinirPlageVisible
    7.91 - Public Sub EcrireCellule
    7.92 - Public Sub EcrireCellule
    7.93 - Public Sub EcrireCellules
    7.94 - Public Sub EcrireEnTexte
    7.95 - Public Sub EcrireFormule
    7.96 - Public Sub EffacerContenuPlage
    7.97 - Public Sub EffacerPlage
    7.98 - Public Sub FinirModif
    7.99 - Public Sub FormatNumerique
    7.100 - Public Sub FormatNumeriquePlage
    7.101 - Public Sub HauteurLigne
    7.102 - Public Sub LargeurColonne
    7.103 - Public Sub LireEnregistrements
    7.104 - Public Sub New
    7.105 - Public Sub SelectionnerCellule
    7.106 - Public Sub SelectionnerContenu
    7.107 - Public Sub SupprimerLignes
    7.108 - Public Sub TaillePolice
    7.109 - Public WriteOnly Property sPositionPlage$
    7.110 - Public WriteOnly Property sPositionPlage$

8 - ucGraphe.vb
    8.1 - <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent
    8.2 - Protected Overloads Overrides Sub Dispose
    8.3 - Public Sub AjouterCourbe
    8.4 - Public Sub EffacerGraphique
    8.5 - Public Sub InitCourbes
    8.6 - Public Sub New
    8.7 - Public Sub TracerGraphique

9 - clsCourbe.vb

10 - Settings.vb

11 - clsAfficherMsg.vb
    11.1 - Public Delegate Sub GestEvAfficherAvancement
    11.2 - Public Delegate Sub GestEvAfficherFEC
    11.3 - Public Delegate Sub GestEvAfficherMessage
    11.4 - Public Delegate Sub GestEvSablier
    11.5 - Public Delegate Sub GestEvTick
    11.6 - Public ReadOnly Property bDesactiver
    11.7 - Public ReadOnly Property iNumFichierEnCours%
    11.8 - Public ReadOnly Property lAvancement
    11.9 - Public ReadOnly Property sMessage$
    11.10 - Public ReadOnly Property sMessage$
    11.11 - Public Sub AfficherAvancement
    11.12 - Public Sub AfficherFichierEnCours
    11.13 - Public Sub AfficherMsg
    11.14 - Public Sub New
    11.15 - Public Sub New
    11.16 - Public Sub New
    11.17 - Public Sub New
    11.18 - Public Sub New
    11.19 - Public Sub New
    11.20 - Public Sub New
    11.21 - Public Sub New
    11.22 - Public Sub Sablier
    11.23 - Public Sub Tick

12 - clsHebOffice.vb
    12.1 - Public Function bMonInstanceOuverte
    12.2 - Public Function bOuvert
    12.3 - Public Overloads Shared Function bOuvert
    12.4 - Public Overloads Shared Function bOuvert
    12.5 - Public Shared Function bOuvert
    12.6 - Public Shared Sub LibererObjetCom
    12.7 - Public Shared Sub LibererObjetCom
    12.8 - Public Sub Fermer
    12.9 - Public Sub New
    12.10 - Public Sub New
    12.11 - Public Sub New
    12.12 - Public Sub New
    12.13 - Public Sub Quitter
    12.14 - Public Sub Quitter

13 - clsODBC.vb
    13.1 - Private Function bCheminFichierProbable
    13.2 - Private Function bCreerFichierDsnODBC
    13.3 - Private Function bCreerFichiersDsnEtSQLODBCDefaut
    13.4 - Private Sub AfficherErreursADO
    13.5 - Private Sub AfficherMessage
    13.6 - Private Sub AjouterEntete
    13.7 - Private Sub AjouterTemps
    13.8 - Private Sub TraiterValChamp
    13.9 - Public Function bExplorerSourceODBC
    13.10 - Public Function bLireSourceODBC
    13.11 - Public Function bLireSQL
    13.12 - Public Function bVerifierCheminODBC
    13.13 - Public Function sLireNomPiloteODBC$
    13.14 - Public ReadOnly Property bAnnuler
    13.15 - Public Shared Sub VerifierConfigODBCExcel
    13.16 - Public Sub Annuler
    13.17 - Public Sub LibererRessources
    13.18 - Public Sub New
    13.19 - Public Sub ViderContenuResultat

14 - modUtilFichier.vb
    14.1 - <System.Diagnostics.DebuggerStepThrough()> Public Function bFichierAccessible
    14.2 - Public Function asArgLigneCmd
    14.3 - Public Function asLireFichier
    14.4 - Public Function bAjouterFichier
    14.5 - Public Function bAjouterFichier
    14.6 - Public Function bChoisirFichier
    14.7 - Public Function bCopierArbo
    14.8 - Public Function bCopierFichier
    14.9 - Public Function bDeplacerDossier
    14.10 - Public Function bDeplacerFichiers2
    14.11 - Public Function bDeplacerFichiers3
    14.12 - Public Function bDossierExiste
    14.13 - Public Function bEcrireFichier
    14.14 - Public Function bEcrireFichier
    14.15 - Public Function bFichierExiste
    14.16 - Public Function bFichierExisteFiltre
    14.17 - Public Function bFichierExisteFiltre2
    14.18 - Public Function bReencoder
    14.19 - Public Function bRenommerDossier
    14.20 - Public Function bRenommerFichier
    14.21 - Public Function bSupprimerDossier
    14.22 - Public Function bSupprimerFichier
    14.23 - Public Function bSupprimerFichiersFiltres
    14.24 - Public Function bVerifierCreerDossier
    14.25 - Public Function iNbFichiersFiltres%
    14.26 - Public Function sbLireFichier
    14.27 - Public Function sCheminRelatif$
    14.28 - Public Function sConvNomDos$
    14.29 - Public Function sDossierParent$
    14.30 - Public Function sEnleverSlashFinal$
    14.31 - Public Function sEnleverSlashInitial$
    14.32 - Public Function sExtraireChemin$
    14.33 - Public Function sFormaterNumerique$
    14.34 - Public Function sFormaterNumerique2$
    14.35 - Public Function sFormaterTailleOctets$
    14.36 - Public Function sLecteurDossier$
    14.37 - Public Function sLireFichier$
    14.38 - Public Function sNomDossierFinal$
    14.39 - Public Function sNomDossierParent$
    14.40 - Public Sub OuvrirAppliAssociee
    14.41 - Public Sub ProposerOuvrirFichier



AssemblyInfo.vb



' Fichier AssemblyInfo.vb
' -----------------------

Imports System.Reflection

<Assembly: AssemblyTitle("VBXL")> 
<Assembly: AssemblyDescription("Programmation efficace d'Excel en VBA, VB6 et VB .Net")> 
<Assembly: AssemblyCompany("ORS Production")> 
<Assembly: AssemblyProduct("VBXL")> 
<Assembly: AssemblyCopyright("2009 Par Patrice Dargenton")> 
<Assembly: AssemblyTrademark("VBXL")> 
<Assembly: AssemblyCulture("")> 

' Parfois ne fonctionne pas (peut être confusion avec les options 
'  My Project : "Informations de l'assembly")
' Solution : supprimer \obj et .pdb, quitter l'IDE et régénérer tout
<Assembly: AssemblyVersion("1.0.4.*")> 


modMain.vb



' VBXL : Programmation efficace d'Excel en VBA, VB6 et VB .Net
' ------------------------------------------------------------
' www.vbfrance.com/code.aspx?ID=17783
' Par Patrice Dargenton : patrice.dargenton@free.fr
' http://patrice.dargenton.free.fr/index.html
' http://patrice.dargenton.free.fr/divers/vbxl.html
' http://patrice.dargenton.free.fr/CodesSources/VBXL.vbproj.html
' www.vbfrance.com/listeauteur2.aspx?ID=1124
' Version 1.04 du 17/08/2009
' Documentation : vbxl.html

' 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 glb ' Global

Public Const sTitreMsg$ = "VBXL"
Private Const sVersionVBXL$ = "1.04"
Private Const sDateVersionVBXL$ = "17/08/2009"
Public Const sNomAppli$ = "VBXL"
Public Const sVersionAppli$ = sVersionVBXL
Public Const sDateVersionAppli$ = sDateVersionVBXL

#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

' On n'est plus obligé de protéger la feuille,
'  on peut mettre simplement en lecture seule (pas d'édition des cellules), 
'  ce qui permet de trier les lignes sans être géné par le mode édition
' Par contre, pour pouvoir tester la formule, il faut remettre la protection
'  de la feuille, déverrouiller les cellules modifiables du modèle, 
'  et enlever la lecture seule du contrôle ucTableur
Public Const bProtegerFeuille As Boolean = True
Public Const bLectureSeule As Boolean = False

Public bVerifierComposantsIni As Boolean
Public Const bTjrsVerifierComposants As Boolean = False
Public Const bGraphiques As Boolean = False
Public Const bActivationSimpleClic As Boolean = False

Public Const bGestionSepDecimal As Boolean = True

Public Const sDossierExport$ = "Export"
Public Const sFichierExportXL$ = "Export_Excel.xls"
Public Const sFichierExportWord$ = "Export_Word.doc"
Public Const sDossierExportExcel$ = "Export_Excel"

' Nom des paramètres du fichier de configuration  ' V1.02 :
'Public Const sFrmVBXL_X$ = "frmVBXL_X"           ' "frmVBXL.X"
'Public Const sFrmVBXL_Y$ = "frmVBXL_Y"           ' "frmVBXL.Y"
'Public Const sFrmVBXL_Width$ = "frmVBXL_Width"   ' "frmVBXL.Width"
'Public Const sFrmVBXL_Height$ = "frmVBXL_Height" ' "frmVBXL.Height"
'Public Const sbVerifierCtrlActiveX$ = "bVerifierCtrlActiveX"

' Position et taille par défaut de l'application
Public Const ptLocationX% = 10
Public Const ptLocationY% = 10
Public Const szTailleX% = 800
Public Const szTailleY% = 600

Public WithEvents msgDelegue As clsMsgDelegue = New clsMsgDelegue

Public sSepDecimal$ = _
    Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator()

Public Sub Main()

    If bDebug Then Depart() : Exit Sub

    ' Attention : En mode Release il faut un Try Catch ici  
    '  car sinon il n'y a pas de gestion d'erreur !
    ' (.Net renvoie un message d'erreur équivalent 
    '  à un plantage complet sans explication)
    Try
        Depart()
    Catch ex As Exception
        AfficherMsgErreur2(ex, "Depart " & sTitreMsg, _
            "Une erreur s'est produite !", _
            "Cause possible : OWC 11 n'est pas installé (cf. lien dans la doc.)" & vbLf & _
            "Veuillez relancer l'application pour vérifier les composants.")
        SauverConfigErr()
    End Try

End Sub

Private Sub Depart()

    If bAppliDejaOuverte() Then Exit Sub

    If Not bVerifierFichiers(Application.StartupPath) Then Exit Sub

    Dim bVerifierCtrlActiveX As Boolean = My.Settings.bVerifierCtrlActiveX
    If bVerifierCtrlActiveX Or bTjrsVerifierComposants Then
        If Not bVerifierComposants() Then
            SauverConfigErr()
            Exit Sub
        End If
    End If
    ' Ne plus vérifier les composants maintenant
    glb.bVerifierComposantsIni = False
    Application.Run(New frmVBXL)

End Sub

#Region "Configuration"

Private Sub SauverConfigErr()

    Dim pt As New Point(ptLocationX, ptLocationY)
    Dim sz As New Size(szTailleX, szTailleY)
    ' Si erreur, forcer une prochaine vérification
    SauverConfig(pt, sz, FormWindowState.Normal, bVerifierComposants:=True)

End Sub

Public Sub SauverConfig( _
    ByVal pt As Point, _
    ByVal sz As Size, _
    Optional ByVal ws As Windows.Forms.FormWindowState = FormWindowState.Normal, _
    Optional ByVal bVerifierComposants As Boolean = True)

    ' Sauver la configuration (emplacement de la fenêtre) dans le fichier .exe.config

    ' Le fichier sera sauvé ici :
    '\Documents and Settings\<utilisateur>\Local Settings\Application Data\
    ' ORS_Production\VBXL_Net.exe_Url_xxx...xxx\1.0.4.xxxxx\user.config

    My.Settings.bVerifierCtrlActiveX = bVerifierComposants
    If ws <> FormWindowState.Maximized Then
        My.Settings.frmVBXL_X = pt.X
        My.Settings.frmVBXL_Y = pt.Y
        My.Settings.frmVBXL_Width = sz.Width
        My.Settings.frmVBXL_Height = sz.Height
        My.Settings.frmVBXL_bMaxim = False
    Else
        My.Settings.frmVBXL_bMaxim = True
    End If

    ' Si l'infrastructure de l'appli. est activée, l'appel peut être automatique
    ' (simple case à cocher)
    My.Settings.Save()

End Sub

#End Region

End Module


frmVBXL.vb



' Fichier frmVBXL.vb
' ------------------

Friend Class frmVBXL : Inherits Form

#Region "Déclarations"

' Déclarations des constantes membres de la classe fenêtre

' On préfixe la catégorie et l'oeuvre pour éviter la confusion numérique/texte
' Si on ne formate pas la date, le tri se fait par jour en 1er !
'  il faut d'abord changer le format pour éviter de confondre 
'  le format français et anglais (MM/dd/yyyy) 
'  et ensuite l'affichage revient à jj/mm/aaaa automatiquement
' Si on utilise le format dd/MM/yyyy, alors l'export Excel montre
'  que la colonne contient un mélange de dates préfixées par ' ou pas
'  car OWC tente de lire au format anglais et préfixe par ' en cas d'échec
'  ce qui pose des problèmes par la suite (la conversion en csv via ODBC échoue)
Private Const sSQL_prm$ = _
    "SELECT ""'"" & Oeuvre, Annee, Vote, ""'"" & Categorie," & _
    " TitreUSA, Auteur, Votant, TypeOeuvre, NbVotes," & _
    " Format(Date, 'yyyy/MM/dd') AS DateTxt" & _
    " FROM {0} Order By Vote DESC;"

' Un formulaire = un écran : ici les constantes pour un tableur
Private Const sPlageVisible$ = "A1:S"
Private Const sPlageDonnees$ = "A2:S"
Private Const sPlageDonneesCellDeb$ = "A2"
Private Const sPlageDonneesColonnes$ = "A:S"
Private Const sPlageDonneesDefaut$ = "A1:ZZ65535"

Private Const sFichierModeleXL$ = "ModeleXL.html"
Private m_iTailleFonte% = 10 ' Dans le modèle

' S'il y a un volet figé, il faut indiquer 
'  la première colonne pouvant être masquée dans iMinColVisible
Private Const iMinColVisible% = 5 '1
' S'il y a un volet figé, il faut indiquer 
'  la première ligne pouvant être masquée dans iMinLigneVisible
Private Const iMinLigneVisible% = 2 '1

Private Const sDossierModeles$ = "" ' Possibilité : "\Modeles"
Private Const sFichierModeleExcel$ = "ModeleXL.xls"
Private Const sFichierModeleWord$ = "ModeleWord.doc"

Private Const sDemo_Effacer$ = "Effacer"
Private Const sDemo_EffacerVolet$ = "Effacer volet"
Private Const sDemo_Modele$ = "Modèle"
Private Const sDemo_FilmsPatrice$ = "Films Patrice"
Private Const sDemo_FilmsIMDB$ = "Films IMDB"
Private Const sDemo_CDPatrice$ = "CD Patrice"
Private Const sDemo_TailleFontePlus$ = "Taille fonte +"
Private Const sDemo_TailleFonteMoins$ = "Taille fonte -"
Private Const sDemo_AjusterAuContenu$ = "Ajuster cell."
Private Const sDemo_TesterVitesse$ = "Test vitesse"
Private Const sDemo_ExporterExcel$ = "Export Excel"
Private Const sDemo_ExporterWord$ = "Export Word"
Private Const sDemo_ExporterWordModele$ = "Export Word M."
Private Const sDemo_Scroll$ = "Scroll"
Private Const sDemo_ScrollNoter$ = "Scroll : Noter"
Private Const sDemo_ScrollRestaurer$ = "Scroll : Rest."
Private Const sDemo_Rechercher$ = "Rechercher"
Private Const sDemo_Trier$ = "Trier"
Private Const sDemo_LectureSeule$ = "Lecture seule"
Private Const sDemo_Coller$ = "Coller"
Private Const sDemo_ModifierStructure$ = "Modifier struct."
Private Const sDemo_ActivBarreTitre$ = "Activ. Titre"
Private Const sDemo_ActivBarreOutils$ = "Activ. Outils"
Private Const sDemo_ActivEntetesL$ = "Activ. Entêt. L."
Private Const sDemo_ActivEntetesC$ = "Activ. Entêt. C."
Private Const sDemo_ActivBarreDefilH$ = "Activ. Défil. H"
Private Const sDemo_ActivBarreDefilV$ = "Activ. Défil. V"
Private Const sDemo_ODBC_XL$ = "ODBC Excel"
Private Const sAPropos$ = "A propos..."

'Private m_iNbEnreg%
Private m_sMinColVisible$, m_sMinLigneVisible$, m_sPlageSelect$

Private WithEvents m_msgDelegue As clsMsgDelegue = New clsMsgDelegue

#End Region

#Region "Initialisations"

' Note : l'appel à InitialiserVBXL() se trouve dans la fonction New()
' cf. frmVBXL.Designer.vb

' Ne fonctionne que si on désactive l'infrastructure de l'application
'  dans ce cas, il suffit juste de sauver les paramètres, c'est tout !
'  (mais pas de vérification instance unique, ...)
'Public Shared Sub Main()

    'MsgBox("Depart")
    'Exit Sub ' Quitter sans ouvrir le frm
    'Application.Run(New frmVBXL)
    ' Sauver les paramètres
    'My.Settings.Save()

'End Sub

Private Sub frmVBXL_Load(ByVal sender As Object, ByVal e As EventArgs) _
    Handles Me.Load
    Me.Text &= " - Version " & sVersionAppli & " (" & sDateVersionAppli & ")"
    If bDebug Then Me.Text &= " - Debug"
End Sub

Private Sub frmVBXL_Closing(ByVal sender As Object, _
    ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing

    SauverConfig(Me.Location, Me.Size, Me.WindowState, _
       glb.bVerifierComposantsIni)

End Sub

Private Sub InitialiserVBXL()

    ' Reprendre la taille et la position précédente de la fenêtre

    ' Positionnement de la fenêtre par le code : mode manuel
    Me.StartPosition = FormStartPosition.Manual
    ' Fixer la position et la taille de la feuille sauvées dans le fichier .exe.config
    Dim x% = My.Settings.frmVBXL_X
    Dim y% = My.Settings.frmVBXL_Y
    Dim w% = My.Settings.frmVBXL_Width
    Dim h% = My.Settings.frmVBXL_Height

    Me.Location = New Drawing.Point(x, y)
    Me.Size = New Size(w, h)

    If My.Settings.frmVBXL_bMaxim Then Me.WindowState = FormWindowState.Maximized

    Me.m_sMinColVisible = ""
    Me.m_sMinLigneVisible = ""
    Me.m_sPlageSelect = ""
    Presentation()

    Me.lbDemo.Items.Add(sDemo_Effacer)
    Me.lbDemo.Items.Add(sDemo_EffacerVolet)
    Me.lbDemo.Items.Add(sDemo_Modele)
    Me.lbDemo.Items.Add(sDemo_FilmsPatrice)
    Me.lbDemo.Items.Add(sDemo_FilmsIMDB)
    Me.lbDemo.Items.Add(sDemo_CDPatrice)
    Me.lbDemo.Items.Add(sDemo_TailleFontePlus)
    Me.lbDemo.Items.Add(sDemo_TailleFonteMoins)
    Me.lbDemo.Items.Add(sDemo_AjusterAuContenu)
    Me.lbDemo.Items.Add(sDemo_TesterVitesse)
    Me.lbDemo.Items.Add(sDemo_ExporterExcel)
    Me.lbDemo.Items.Add(sDemo_ExporterWord)
    Me.lbDemo.Items.Add(sDemo_ExporterWordModele)
    Me.lbDemo.Items.Add(sDemo_Scroll)
    Me.lbDemo.Items.Add(sDemo_ScrollNoter)
    Me.lbDemo.Items.Add(sDemo_ScrollRestaurer)
    Me.lbDemo.Items.Add(sDemo_Rechercher)
    Me.lbDemo.Items.Add(sDemo_Trier)
    Me.lbDemo.Items.Add(sDemo_LectureSeule)
    Me.lbDemo.Items.Add(sDemo_Coller)
    Me.lbDemo.Items.Add(sDemo_ModifierStructure)
    Me.lbDemo.Items.Add(sDemo_ActivBarreTitre)
    Me.lbDemo.Items.Add(sDemo_ActivBarreOutils)
    Me.lbDemo.Items.Add(sDemo_ActivEntetesL)
    Me.lbDemo.Items.Add(sDemo_ActivEntetesC)
    Me.lbDemo.Items.Add(sDemo_ActivBarreDefilH)
    Me.lbDemo.Items.Add(sDemo_ActivBarreDefilV)
    Me.lbDemo.Items.Add(sDemo_ODBC_XL)
    Me.lbDemo.Items.Add(sAPropos)

End Sub

Private Sub lbDemo_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles lbDemo.Click

    Select Case Me.lbDemo.Items(Me.lbDemo.SelectedIndex).ToString
    Case sDemo_Effacer
        AfficherMessage("Effacer le contenu et le format")
    Case sDemo_EffacerVolet
        AfficherMessage("Effacer tout, y compris les volets figés, et rétablir la plage maximale")
    Case sDemo_Modele
        AfficherMessage("Charger le modèle de présentation")
    Case sDemo_FilmsPatrice
        AfficherMessage("Afficher les 800 films DVD préférés de Patrice en 1 seconde !")
    Case sDemo_FilmsIMDB
        AfficherMessage("Afficher 2800 films DVD préférés des internautes ayant votés sur The Internet Movie Database : IMDB.com en une seconde !")
    Case sDemo_CDPatrice
        AfficherMessage("Afficher les 600 CD préférés de Patrice en 1 seconde ! (et faire un test de bordure en couleur en B4)")
    Case sDemo_TailleFontePlus
        AfficherMessage("Augmenter la taille de la police de caractère")
    Case sDemo_TailleFonteMoins
        AfficherMessage("Diminuer la taille de la police de caractère")
    Case sDemo_AjusterAuContenu
        AfficherMessage("Ajuster la taille des cellules à leur contenu")
    Case sDemo_TesterVitesse
        AfficherMessage("Test de vitesse : < à 1 sec. normalement et 10 sec. si bug OWC 9 (lorsque RAM >= 1Go ???)")
    Case sDemo_ExporterExcel
        AfficherMessage("Exporter le contenu du tableur vers Excel")
    Case sDemo_ExporterWord
        AfficherMessage("Exporter le contenu du tableur vers Word (Attention : cela peut prendre plusieurs minutes)")
    Case sDemo_ExporterWordModele
        AfficherMessage("Exporter le contenu du tableur vers Word selon un modèle (Attention : cela peut prendre plusieurs minutes)")
    Case sDemo_Scroll
        AfficherMessage("S'assurer que la cellule E5 est visible")
    Case sDemo_ScrollNoter
        AfficherMessage("Noter la position actuelle des cellules affichées dans le tableur")
    Case sDemo_ScrollRestaurer
        AfficherMessage("Retaurer la position notée des cellules affichées dans le tableur")
    Case sDemo_Rechercher
        AfficherMessage("Rechercher la première occurrence de Fincher dans la colonne F")
    Case sDemo_Trier
        AfficherMessage("Activer/Désactiver les tris sur la feuille (Désactiver/Activer la protection de la feuille)")
    Case sDemo_LectureSeule
        AfficherMessage("Activer/Désactiver le mode lecture seule (permettre les tris sans pour autant autoriser la modification des cellules)")
    Case sDemo_Coller
        AfficherMessage("Activer/Désactiver le collage dans la feuille")
    Case sDemo_ModifierStructure
        AfficherMessage("Activer/Désactiver la modification de structure de la feuille (insertion et suppression de lignes et colonnes)")
    Case sDemo_ActivBarreTitre
        AfficherMessage("Activer/Désactiver la barre de titre")
    Case sDemo_ActivBarreOutils
        AfficherMessage("Activer/Désactiver la barre d'outils")
    Case sDemo_ActivEntetesL
        AfficherMessage("Activer/Désactiver les entêtes de lignes")
    Case sDemo_ActivEntetesC
        AfficherMessage("Activer/Désactiver les entêtes de colonnes")
    Case sDemo_ActivBarreDefilH
        AfficherMessage("Activer/Désactiver la barre de défilement horizontale")
    Case sDemo_ActivBarreDefilV
        AfficherMessage("Activer/Désactiver la barre de défilement verticale")
    Case sDemo_ODBC_XL
        AfficherMessage("Charger les données du classeur Excel FilmsPatrice.xls via ODBC")
    Case sAPropos
        AfficherMessage("Afficher le n° de version des composants OWC et ADO")
    End Select

End Sub

Private Sub lbDemo_DoubleClick(ByVal sender As Object, ByVal e As EventArgs) _
    Handles lbDemo.DoubleClick

    Select Case Me.lbDemo.Items(Me.lbDemo.SelectedIndex).ToString
    Case sDemo_Effacer
        Effacer()
    Case sDemo_EffacerVolet
        EffacerTout()
    Case sDemo_Modele
        ChargerModele()
    Case sDemo_FilmsPatrice
        Demo_FilmsPatrice()
    Case sDemo_FilmsIMDB
        Demo_FilmsIMDB()
    Case sDemo_CDPatrice
        Demo_CDPatrice()
    Case sDemo_TailleFontePlus
        Demo_TailleFontePlus()
    Case sDemo_TailleFonteMoins
        Demo_TailleFonteMoins()
    Case sDemo_AjusterAuContenu
        Demo_AjusterAuContenu()
    Case sDemo_TesterVitesse
        Demo_TesterVitesse()
    Case sDemo_ExporterExcel
        Demo_ExporterExcel()
    Case sDemo_ExporterWord
        Demo_ExporterWord()
    Case sDemo_ExporterWordModele
        Demo_ExporterWordModele()
    Case sDemo_Scroll
        Demo_Scroll()
    Case sDemo_ScrollNoter
        Demo_Scroll_Noter()
    Case sDemo_ScrollRestaurer
        Demo_Scroll_Restaurer()
    Case sDemo_Rechercher
        Demo_Rechercher()
    Case sDemo_Trier
        Demo_Trier()
    Case sDemo_LectureSeule
        Demo_LectureSeule()
    Case sDemo_Coller
        Demo_Coller()
    Case sDemo_ModifierStructure
        Demo_ModifierStructure()
    Case sDemo_ActivBarreTitre
        Me.ucT.bAfficherBarreTitre = Not Me.ucT.bAfficherBarreTitre
    Case sDemo_ActivBarreOutils
        Me.ucT.bAfficherBarreOutils = Not Me.ucT.bAfficherBarreOutils
    Case sDemo_ActivEntetesL
        Me.ucT.bAfficherEntetesLigne = Not Me.ucT.bAfficherEntetesLigne
    Case sDemo_ActivEntetesC
        Me.ucT.bAfficherEntetesColonne = Not Me.ucT.bAfficherEntetesColonne
    Case sDemo_ActivBarreDefilH
        Me.ucT.bAfficherBarreDefilH = Not Me.ucT.bAfficherBarreDefilH
    Case sDemo_ActivBarreDefilV
        Me.ucT.bAfficherBarreDefilV = Not Me.ucT.bAfficherBarreDefilV
    Case sDemo_ODBC_XL
        Demo_ODBC_XL()
    Case sAPropos
        APropos()
    End Select

End Sub

Private Sub ucT_CelluleClic(ByVal iCol%, ByVal iLigne%, ByVal sValeur$) _
    Handles ucT.EvCelluleClic
    'AfficherInfoCellule(iCol, iLigne, sValeur)
End Sub

Private Sub ucT_EvSelectionChange(ByVal iCol%, ByVal iLigne%, _
    ByVal sValeur$) Handles ucT.EvSelectionChange
    ' Afficher aussi les infos si on se déplace via le clavier
    AfficherInfoCellule(iCol, iLigne, sValeur)
End Sub

Private Sub AfficherInfoCellule(ByVal iCol%, ByVal iLigne%, ByVal sValeur$)
    Dim sNomColonne$ = Me.ucT.sConvNumEnLettres(iCol)
    Dim sFormule$ = Me.ucT.sLireFormule(iLigne, iCol)
    Dim sMsg$ = "Clic" & " L" & iLigne & _
        " C" & iCol & "(" & sNomColonne & ") : " & sValeur
    If sFormule.Length > 0 Then sMsg &= ", Formule : " & sFormule
    AfficherMessage(sMsg)
End Sub

Private Sub ucT_CelluleDblClic(ByVal iCol%, ByVal iLigne%, ByVal sValeur$) _
    Handles ucT.EvCelluleDblClic
    Dim sNomColonne$ = Me.ucT.sConvNumEnLettres(iCol)
    MsgBox( _
        "Double-Clic" & " L" & iLigne & _
        " C" & iCol & "(" & sNomColonne & ") : " & sValeur, _
        MsgBoxStyle.Information, sTitreMsg)
End Sub

Private Sub ucT_EvCelluleChange(ByVal iCol%, ByVal iLigne%, _
    ByVal sAncienneValeur$) Handles ucT.EvCelluleChange
    Dim sNomColonne$ = Me.ucT.sConvNumEnLettres(iCol)
    ' Attendre un peu pour pouvoir connaitre la nouvelle valeur
    'Dim sNouvelleValeur$ = Me.ucT.sLireCellule(iLigne, iCol)
    AfficherMessage("Le contenu de la cellule L" & iLigne & _
        " C" & iCol & "(" & sNomColonne & ") a changé : ancienne valeur : " & _
        sAncienneValeur) ' & " -> " & sNouvelleValeur)
End Sub

Private Sub AfficherMessage(ByVal sender As Object, _
    ByVal e As clsMsgEventArgs) Handles m_msgDelegue.EvAfficherMessage
    AfficherMessage(e.sMessage)
End Sub

Private Sub AfficherMessage(ByVal sMessage$)
    Me.sbBarreEtat.Text = sMessage
    'Me.sbBarreEtat.Panels(0).Text = sMessage
End Sub

#End Region

#Region "Gestion du composant tableur"

Private Sub Effacer()

    ' Effacer le contenu et le format du tableur OWC
    Me.ucT.EffacerPlage("")

End Sub

Private Sub EffacerTout()

    ' Effacer tout, y-compris les volets figés, et rétablir la plage maximale
    ChargerModele("ModeleXLVide.html")
    Me.ucT.DefinirPlageVisible(sPlageDonneesDefaut, _
        iLigneVoletFige:=iMinLigneVisible, _
        iColVoletFige:=iMinColVisible)
    ' La largeur de la première colonne n'est pas la même que celle des autres
    '  le fait d'effacer corrige cela
    Effacer()

End Sub

Private Sub ChargerModele(Optional ByVal sFichierModele$ = sFichierModeleXL)

    ' Charger le modèle Excel ModeleXL.html de présentation des données
    ' Note : la barre d'outil est restaurée automatiquement
    '  ainsi que les entêtes de lignes et colonnes
    '  on rappèle donc la fonction de présentation

    Dim sCheminFichierModeleXL$
    sCheminFichierModeleXL = Application.StartupPath & _
        sDossierModeles & "\" & sFichierModele
    Me.ucT.bInitFeuilleXL(sCheminFichierModeleXL, bProteger:=bProtegerFeuille)
    Me.ucT.bLectureSeule = bLectureSeule
    Me.ucT.DefinirPlageVisible(sPlageVisible & iMinLigneVisible, _
        iLigneVoletFige:=iMinLigneVisible, _
        iColVoletFige:=iMinColVisible)
    Presentation()

End Sub

Private Sub Presentation()
    'Me.ucT.bAfficherEntetesLigne = False
    'Me.ucT.bAfficherEntetesColonne = False
    'Me.ucT.bAfficherBarreOutils = False
    'Me.ucT.sTitre = "Démo VBXL"
End Sub

Private Sub RemplirFeuille(ByVal sSQL$)

    ' Récupération des données de RqDVDClass.mdb

    Sablier()

    Me.ucT.CommencerModif()

    Dim oConn As New ADODB.Connection
    Dim oRqAdoDb As New ADODB.Recordset
    Dim sBD$ = Application.StartupPath & "\RqDVDClass.mdb"

    Try

        oConn.Mode = ADODB.ConnectModeEnum.adModeRead
        oRqAdoDb.LockType = ADODB.LockTypeEnum.adLockReadOnly
        oRqAdoDb.CursorType = ADODB.CursorTypeEnum.adOpenForwardOnly
        ' Pour pouvoir faire le moveLast
        'oRqAdoDb.CursorType = ADODB.CursorTypeEnum.adOpenKeyset

        oConn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & sBD)
        oRqAdoDb.Open(sSQL, oConn)

        ' Effacer les lignes précédentes, au cas où la rq 
        '  renverrait moins d'enreg.
        Me.ucT.SupprimerLignes(sPlageDonnees & "65535")

        If oRqAdoDb.EOF Then

            Me.ucT.DefinirPlageVisible( _
                sPlageVisible & iMinLigneVisible)

        Else

            'Me.ucT.DefinirPlageVisible(sPlageVisible & "65535")
            Me.ucT.DefinirPlageVisible(sPlageDonneesColonnes)

            Me.ucT.LireEnregistrements( _
                sPlageDonneesCellDeb, oRqAdoDb, bGestionSepDecimal)

            ' Trouver le nombre d'enregistrements
            'oRqAdoDb.MoveLast() ' 1ère solution : requiert adOpenKeyset
            'Me.m_iNbEnreg = oRqAdoDb.RecordCount
            Dim sPlage$ = Me.ucT.sPlageUtilisee() ' 2ème solution
            'Me.m_iNbEnreg = Me.ucT.iLigneFinPlage(sPlage) - 2
            ' Délimiter le tableur au contenu
            Me.ucT.DefinirPlageVisible(sPlage, _
                iLigneVoletFige:=iMinLigneVisible, _
                iColVoletFige:=iMinColVisible)

        End If

        oRqAdoDb.Close()
        oConn.Close()

        ' Bug : formatage de la colonne vote, ne suffit pas :
        '  il faut que le champ vote soit réel,
        '  et il faut gérer le sep.dec. : bGestionSepDecimal = True
        ' Dans ce cas, le format du modèle est respecté, ne pas le changer :
        'Me.oXL.ActiveSheet.Range("C:C").NumberFormat = "0.00"

    Catch Err As Exception
        AfficherMsgErreur2(Err, "RemplirFeuille")
    End Try

    ' Ajuster la taille des cellules à leur contenu
    'Demo_AjusterAuContenu()

Fin:
    oRqAdoDb = Nothing
    oConn = Nothing
    ' Ne pas activer le verrouillage de la feuille 
    '  si on veut trier, filtrer...
    Me.ucT.FinirModif(bProteger:=bProtegerFeuille)
    Sablier(bDesactiver:=True)

End Sub

Private Sub Demo_FilmsPatrice()

    Effacer()
    ChargerModele()
    'RemplirFeuille("Select * From FilmsDVDPatrice")
    Dim sSQL$ = String.Format(sSQL_prm, "FilmsDVDPatrice")
    RemplirFeuille(sSQL)

End Sub

Private Sub Demo_FilmsIMDB()

    Effacer()
    ChargerModele()
    ' Bug avec la valeur '- Nul' : le signe - fait boguer l'affichage !
    'RemplirFeuille("Select * From FilmsDVDIMDB")
    Dim sSQL$ = String.Format(sSQL_prm, "FilmsDVDIMDB")
    RemplirFeuille(sSQL)

End Sub

Private Sub Demo_CDPatrice()

    Effacer()
    ChargerModele()
    ' Il y a deux titres de CD en numérique : 18 (Moby) et 1964 (Miossec)
    'RemplirFeuille("Select * From CDPatrice")
    Dim sSQL$ = String.Format(sSQL_prm, "CDPatrice")
    RemplirFeuille(sSQL)

    ' Test bordure
    Me.ucT.CommencerModif()
    ' Tous les bords
    'Me.ucT.ChangerCouleurBordCellule(4, 2, 4, 3, ucTableur.sCouleurVert)
    Me.ucT.ChangerCouleurBordCellule(4, 2, 0, 3, ucTableur.sCouleurVert)
    Me.ucT.ChangerCouleurBordCellule(4, 2, 1, 3, ucTableur.sCouleurRouge)
    Me.ucT.ChangerCouleurBordCellule(4, 2, 2, 3, ucTableur.sCouleurOrange)
    Me.ucT.ChangerCouleurBordCellule(4, 2, 3, 3, ucTableur.sCouleurNoir)
    Me.ucT.FinirModif(bProteger:=bProtegerFeuille)

End Sub

Private Sub Demo_TailleFontePlus()

    Me.m_iTailleFonte += 1
    Me.ucT.CommencerModif()
    Me.ucT.TaillePolice(Me.ucT.sPlageUtilisee, Me.m_iTailleFonte)
    Me.ucT.FinirModif(bProteger:=bProtegerFeuille)

End Sub

Private Sub Demo_TailleFonteMoins()

    Me.m_iTailleFonte -= 1
    Me.ucT.CommencerModif()
    Me.ucT.TaillePolice(Me.ucT.sPlageUtilisee, Me.m_iTailleFonte)
    Me.ucT.FinirModif(bProteger:=bProtegerFeuille)

End Sub

Private Sub Demo_AjusterAuContenu()

    ' Ajuster la taille des cellules à leur contenu

    Me.ucT.AjusterCellulesAuContenu()
    Me.ucT.SelectionnerCellule(3, 1) ' Remettre le Scroll en ligne 3
    Me.ucT.SelectionnerCellule(1, 1)

End Sub

Private Sub Demo_TesterVitesse()

    'Effacer()
    EffacerTout()
    Me.ucT.CommencerModif()
    Dim i% = 0
    Dim j% = 0
    For i = 1 To 10
    For j = 1 To 5
        Me.ucT.EcrireCellule(i, j, (i + j).ToString, bReel:=False)
        'Me.ucT.oXL.Cells(i, j) = (i + j).ToString
    Next j : Next i

    ' Délimiter le tableur au contenu
    Me.ucT.DefinirPlageVisible(Me.ucT.sPlageUtilisee())

    Me.ucT.FinirModif(bProteger:=bProtegerFeuille)
    MsgBox("Test d'écriture cellule par cellule terminé", _
        MsgBoxStyle.Exclamation, sTitreMsg)

    Effacer()
    Me.ucT.CommencerModif()
    Const sDelimiteurCol$ = vbTab
    Dim sb As New System.Text.StringBuilder
    For i = 1 To 10
        For j = 1 To 5
            'Me.ucT.EcrireCellule(i, j, (i + j).ToString, bReel:=False)
            'Me.ucT.oXL.Cells(i, j) = (i + j).ToString
            sb.Append((i + j).ToString).Append(sDelimiteurCol)
        Next j
        ' Test programmation de formule : ok cela fonctionne aussi
        'sb.Append("=B1+D1").Append(sDelimiteurCol)
        sb.Append(vbLf)
    Next i
    'Me.ucT.oXL.ActiveSheet.Range("A1").ParseText(sb.ToString, sDelimiteurCol)
    Me.ucT.EcrireCellules("A1", sb)

    Me.ucT.DefinirPlageVisible(Me.ucT.sPlageUtilisee())

    Me.ucT.FinirModif(bProteger:=bProtegerFeuille)
    MsgBox("Test d'écriture d'une plage entière terminé", _
        MsgBoxStyle.Exclamation, sTitreMsg)

End Sub

Private Sub Demo_ExporterExcel()

    Dim sCheminFichierXLModele$ = Application.StartupPath & _
        sDossierModeles & "\" & sFichierModeleExcel
    If Not bFichierExiste(sCheminFichierXLModele, bPrompt:=True) Then Exit Sub
    Dim sPlageDonneesXL$ = Me.ucT.sPlageUtilisee()
    'Me.ucT.CopierPressePapier(sPlageDonneesXL)
    'bExporterExcel(sCheminFichierXLModele, sFichierModeleExcel, _
    '    sPlageDonneesXL, Me.m_msgDelegue)

    glb.msgDelegue = Me.m_msgDelegue
    Me.ucT.bExporterExcel( _
        sPlageDonneesXL:=sPlageDonneesXL, _
        sCheminFichierXLModele:=sCheminFichierXLModele, _
        sFichierModele:=sFichierModeleExcel)

End Sub

Private Sub Demo_ExporterWord()

    Me.ucT.CopierPressePapier(Me.ucT.sPlageUtilisee())
    ExporterWord(Me.m_msgDelegue)

End Sub

Private Sub Demo_ExporterWordModele()

    Dim sCheminFichierModele$ = Application.StartupPath & _
        sDossierModeles & "\" & sFichierModeleWord
    If Not bFichierExiste(sCheminFichierModele, bPrompt:=True) Then Exit Sub
    Me.ucT.CopierPressePapier(Me.ucT.sPlageUtilisee())
    ExporterWord(Me.m_msgDelegue, , , sCheminFichierModele)

End Sub

Private Sub Demo_Trier()
    Me.ucT.bProtegerFeuille = Not Me.ucT.bProtegerFeuille
    If Me.ucT.bProtegerFeuille Then
        AfficherMessage("La feuille est vérrouillée, le tri n'est pas autorisé")
    Else
        AfficherMessage("La feuille est dévérrouillée, le tri est autorisé")
    End If
End Sub

Private Sub Demo_LectureSeule()
    Me.ucT.bLectureSeule = Not Me.ucT.bLectureSeule
    If Not Me.ucT.bLectureSeule Then Me.ucT.bProtegerFeuille = False
    If Me.ucT.bLectureSeule Then
        AfficherMessage("La feuille est en mode lecture seule")
    Else
        If Me.ucT.bProtegerFeuille Then
            AfficherMessage( _
                "La feuille est vérrouillée, la modification du contenu des cellules n'est toujours pas permise")
        Else
            AfficherMessage( _
                "La feuille est dévérrouillée, la modification du contenu des cellules est permise")
        End If
    End If
End Sub

Private Sub Demo_Coller()
    Me.ucT.bCollageInterdit = Not Me.ucT.bCollageInterdit
    If Me.ucT.bCollageInterdit Then
        AfficherMessage("Le collage n'est pas autorisé dans la feuille")
    Else
        Me.ucT.bProtegerFeuille = False
        AfficherMessage("Le collage est autorisé dans la feuille")
    End If
End Sub

Private Sub Demo_ModifierStructure()
    Me.ucT.bModifierStructureInterdit = Not Me.ucT.bModifierStructureInterdit
    If Me.ucT.bModifierStructureInterdit Then
        ' Note : la commande Annuler (undo) reste possible !
        AfficherMessage( _
            "La modification de structure de la feuille n'est pas autorisée")
    Else
        Me.ucT.bProtegerFeuille = False
        AfficherMessage( _
            "La modification de structure de la feuille est autorisée")
    End If
End Sub

Private Sub Demo_Scroll()

    ' Démo Scroll (défillement)
    '  S'assurer que la cellule E5 est toujours visible

    ' Noter la position horizontale de la première colonne non figée : E
    ' Note : La lecture de la position ne fonctionne plus en OWC10
    Dim iPosH_CMin% = Me.ucT.iPositionHPlage("E5")
    ' Noter la position verticale de la première ligne non figée : 3
    Dim iPosV_LMin% = Me.ucT.iPositionVPlage("E3")
    ' Noter la position horizontale de la cellule à droite de E5 : F5
    Dim iPosH_F5% = Me.ucT.iPositionHPlage("F5")
    ' Noter la position horizontale de la cellule en bas de E5 : E6
    Dim iPosV_E6% = Me.ucT.iPositionVPlage("E6")
    'AfficherMessage( _
    '    "iPosV_LMin=" & iPosV_LMin & ", E6=" & iPosV_E6 & ", " & _
    '    "iPosH_CMin=" & iPosH_CMin & ", F5=" & iPosH_F5)
    ' Si la position suivante est <= à la position min. alors repositionner
    If iPosV_E6 <= iPosV_LMin Or iPosH_F5 <= iPosH_CMin Then
        Me.ucT.sPositionPlage = "E5"
        AfficherMessage("Repositionnement sur E5")
    Else
        AfficherMessage("E5 est visible")
    End If

End Sub

Private Sub Demo_Scroll_Noter()

    ' Noter la position actuelle des cellules affichées dans le tableur

    If ucTableur.iOWC > ucTableur.iOWC9 Then
        'MsgBox("Cette démo ne fonctionne plus en OWC10 !", _
        '    MsgBoxStyle.Exclamation, sTitreMsg) 
        Me.m_sPlageSelect = Me.ucT.sPlageSelectionnee()
        If Me.m_sPlageSelect.Length > 0 Then _
            AfficherMessage("Plage sélectionnée : " & Me.m_sPlageSelect)
        Exit Sub
    End If

    Me.m_sMinColVisible = Me.ucT.sMinColVisible(iMinColVisible)
    Me.m_sMinLigneVisible = Me.ucT.sMinLigneVisible(iMinLigneVisible)

    Me.m_sPlageSelect = Me.ucT.sPlageSelectionnee()
    Dim iMinColPlageSel% = Me.ucT.iColPlage(Me.m_sPlageSelect)
    Dim iMinLignePlageSel% = Me.ucT.iLignePlage(Me.m_sPlageSelect)

    Dim iMinColVisible0% = Me.ucT.iConvLettresEnNum(Me.m_sMinColVisible)
    If Me.m_sMinLigneVisible.Length = 0 Then Exit Sub
    If Not IsNumeric(Me.m_sMinLigneVisible) Then Exit Sub
    Dim iMinLigneVisible0% = CInt(Me.m_sMinLigneVisible)

    ' Si la sélection est en dehors de la plage visible,
    '  alors ne pas la mémoriser
    If iMinColPlageSel < iMinColVisible0 Or _
       iMinLignePlageSel < iMinLigneVisible0 Then
        Me.m_sPlageSelect = ""
    End If

    Dim sInfo$ = "Min col visible : " & Me.m_sMinColVisible & _
        ", Min ligne visible : " & Me.m_sMinLigneVisible
    If Me.m_sPlageSelect.Length > 0 Then _
        sInfo &= ", Plage sélectionnée : " & Me.m_sPlageSelect
    AfficherMessage(sInfo)

End Sub

Private Sub Demo_Scroll_Restaurer()

    ' Retaurer la position notée des cellules affichées dans le tableur

    If ucTableur.iOWC > ucTableur.iOWC9 Then
        'MsgBox("Cette démo ne fonctionne plus en OWC10 !", _
        '    MsgBoxStyle.Exclamation, sTitreMsg)
        If Me.m_sPlageSelect.Length = 0 Then Exit Sub
        Me.ucT.SelectionnerPlage(Me.m_sPlageSelect)
        AfficherMessage("Plage restaurée : " & Me.m_sPlageSelect)
        Exit Sub
    End If

    If Me.m_sMinColVisible.Length = 0 Then Exit Sub
    If Me.m_sMinLigneVisible.Length = 0 Then Exit Sub
    If Not IsNumeric(Me.m_sMinLigneVisible) Then Exit Sub

    Dim sPlageUtilisee$ = Me.ucT.sPlageUtilisee
    Dim iMaxColPlageUtil% = Me.ucT.iColFinPlage(sPlageUtilisee)
    Dim iMaxLignePlageUtil% = Me.ucT.iLigneFinPlage(sPlageUtilisee)

    Dim iMinColVisible0% = Me.ucT.iConvLettresEnNum(Me.m_sMinColVisible)
    Dim iMinLigneVisible0% = CInt(Me.m_sMinLigneVisible)

    Dim sInfo$ = "Min col visible : " & Me.m_sMinColVisible & _
        ", Min ligne visible : " & Me.m_sMinLigneVisible
    If Me.m_sPlageSelect.Length > 0 Then _
        sInfo &= ", Plage sélectionnée : " & Me.m_sPlageSelect

    ' Si la plage notée n'existe plus alors ne pas la restaurer
    If iMaxColPlageUtil < iMinColVisible0 Or _
        iMaxLignePlageUtil < iMinLigneVisible0 Then
        AfficherMessage("La plage notée n'existe plus : " & sInfo)
        Exit Sub
    End If

    AfficherMessage("Plage restaurée : " & sInfo)
    Me.ucT.sPositionPlage = Me.m_sMinColVisible & Me.m_sMinLigneVisible
    If Me.m_sPlageSelect.Length = 0 Then Exit Sub
    Me.ucT.SelectionnerPlage(Me.m_sPlageSelect)

End Sub

Private Sub Demo_Rechercher()
    If Me.ucT.bChercher("F:F", "Fincher") Then
        AfficherMessage("Fincher trouvé dans la colonne F !")
    Else
        AfficherMessage("Fincher non trouvé dans la colonne F !")
    End If
End Sub

Private Sub Demo_ODBC_XL()

    ' Charger les données du classeur Excel FilmsPatrice.xls via ODBC

    ' Pour régénérer le fichier FilmsPatrice.xls, simplement faire un export Excel,
    '  lorsque l'on importe à nouveau le fichier Excel via ODBC, il y a juste un 
    '  problème avec les dates : perturbation des heures minutes et secondes de 
    '  façon chaotique. Solution : convertir la colonne en texte sous Excel 
    '  avant l'import ODBC.

    ' Voir ici pour les options (fichiers .dsn et .sql externes, ...) :
    ' ODBCDotNet : Extraire des requêtes ODBC dans  
    '  un tableau de tableaux de String
    'http://patrice.dargenton.free.fr/CodesSources/ODBCDotNet.html

    Dim sCheminSourceODBCXL$ = Application.StartupPath & "\FilmsPatrice.xls"
    If Not bFichierExiste(sCheminSourceODBCXL, bPrompt:=True) Then Exit Sub
    Dim oODBC As New clsODBC
    oODBC.m_sChaineConnexionDirecte = _
        "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & sCheminSourceODBCXL & ";" & _
        "Extended Properties=""Excel 8.0;"";"
    oODBC.m_sListeSQL = "Select * From [ClasseurFilmsPatrice$];"
    Dim aiNbChampsAttendusSQL%() = {10}
    oODBC.m_bPrompt = False ' Pas de msgBox de confirmation
    oODBC.m_bCopierDonneesPressePapier = False
    'oODBC.m_bLireToutDUnBloc = True ' Lecture ODBC sans traitement

    ' On peut charger directement les données dans le tableur sans aucun 
    '  traitement (en utilisant oODBC.m_sbLignes au lieu de oODBC.m_aoMetaTableau),
    '  mais il y a 2 bugs :
    ' - La colonne Catégorie est boguée s'il y a un - devant : '- Nul'
    ' - Si le séparateur décimal est la virgule au lieu du point, 
    '   alors la colonne Vote est parfois boguée
    ' - Parfois les dates sont interpretées avec le format anglais : mm/jj/aaaa
    '   (forcer le mode texte en ajoutant un quote ' devant)
    'oODBC.m_bLireToutDUnBlocRapide = True

    ' Il existe aussi une alternative intéressante via les fonctions
    ' .ActiveSheet.ConnectionString et .ActiveSheet.CommandText
    ' qui permettent une requête directe : pas de bug cette fois !
    'http://www.vbfrance.com/code.aspx?ID=47972

    If Not oODBC.bLireSourceODBC(bRenvoyerContenu:=True) Then Exit Sub

    Dim sDelimiteurCol$ = vbTab
    Dim sb As System.Text.StringBuilder
    If oODBC.m_bLireToutDUnBlocRapide Then
        sb = oODBC.m_sbLignes
        sDelimiteurCol = ";"
        GoTo Ecriture
    End If

    ' Analyse du ou des tableaux résultats
    sb = New System.Text.StringBuilder
    Dim asTableau$(,)
    Dim iNbTableaux% = oODBC.m_aoMetaTableau.GetUpperBound(0) + 1
    Dim k%
    For k = 0 To iNbTableaux - 1 ' Une seule requête -> 1 seul tableau ici
        asTableau = CType(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
        Dim i%, j%, sVal$
        For j = 0 To iNbLignes - 1
            For i = 0 To iNbColonnes - 1
                sVal = asTableau(i, j)
                Select Case k
                Case 0 ' 1ère requête
                    If i = 3 Then
                        ' Bug avec la valeur '- Nul' dans OWC9 !
                        '  le signe - fait boguer l'affichage !
                        sb.Append("'" & sVal).Append(sDelimiteurCol)
                    Else
                        sb.Append(sVal).Append(sDelimiteurCol)
                    End If
                    'Select Case i
                    'Case 0 : sOeuvre = sVal
                    'Case 1 : sAnnee = sVal
                    '...
                    'End Select
                End Select
            Next i
LigneSuivante:
            sb.Append(vbLf) ' Délimiteur de lignes
        Next j
TableauSuivant:
    Next k

Ecriture:
    Effacer()
    ChargerModele()
    Me.ucT.CommencerModif()
    Me.ucT.EcrireCellules(sPlageDonneesCellDeb, sb, sDelimiteurCol)
    Me.ucT.DefinirPlageVisible(Me.ucT.sPlageUtilisee(), _
        iLigneVoletFige:=iMinLigneVisible, _
        iColVoletFige:=iMinColVisible)
    Me.ucT.FinirModif(bProteger:=bProtegerFeuille)

End Sub

Private Sub APropos()
    VerifierVersionExe(sVersionAppli)
    If Not bVerifierComposants(bPrompt:=True) Then Exit Sub
End Sub

#End Region

End Class


modUtilitaire.vb



' Fichier modUtilitaire.vb
' ------------------------

Imports Microsoft.Win32 ' Pour RegistryKey

Module Utilitaire

#Region "Convertions"

Public Function rConvStrEnReel!(ByVal sVal$, _
    Optional ByVal rDef! = 0.0!, Optional ByVal iDecimalesMax% = 0)

    ' Convertir à coup sûr un string en réel

    ' D'abord changer la , en . le cas échéant
    If sVal.Length = 0 Then rConvStrEnReel = rDef : Exit Function
    Dim sValPtDecimal$ = Replace(sVal, ",", ".")
    If glb.sSepDecimal <> "." And glb.sSepDecimal <> "," And glb.sSepDecimal <> "" Then
        ' Quelque soit le séparateur décimal, le convertir en .
        sValPtDecimal = Replace(sVal, glb.sSepDecimal, ".")
    End If

    ' Note : Val utilise toujours le . quel que soit le séparateur décimal en vigueur
    Try
        rConvStrEnReel = CSng(Val(sValPtDecimal))
        If iDecimalesMax > 0 Then
            rConvStrEnReel = CSng(Math.Round(rConvStrEnReel, iDecimalesMax))
        End If
    Catch
        rConvStrEnReel = rDef
    End Try

    ' voir aussi : sValeurPtDecimal

End Function

Public Function sValeurPtDecimal$(ByVal sVal$)

    sValeurPtDecimal = sVal
    If sVal.Length = 0 Then Exit Function
    sValeurPtDecimal = Replace(sValeurPtDecimal, ",", ".")
    Dim sSepDecimal$ = Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator()
    If sSepDecimal.Length = 0 Then Exit Function
    If sSepDecimal <> "." And sSepDecimal <> "," Then
        ' Quelque soit le séparateur décimal, le convertir en .
        sValeurPtDecimal = Replace(sValeurPtDecimal, sSepDecimal, ".")
    End If

End Function

Public Function sValeurPtDecimal$(ByVal rVal!)

    sValeurPtDecimal = CStr(rVal)
    sValeurPtDecimal = Replace(sValeurPtDecimal, ",", ".")
    Dim sSepDecimal$ = Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator()
    If sSepDecimal.Length = 0 Then Exit Function
    If sSepDecimal <> "." And sSepDecimal <> "," Then
        ' Quelque soit le séparateur décimal, le convertir en .
        sValeurPtDecimal = Replace(sValeurPtDecimal, sSepDecimal, ".")
    End If

End Function

Public Function iConv%(ByVal sVal$, Optional ByVal iValDef% = 0)

    If sVal.Length = 0 Then iConv = iValDef : Exit Function
    Try
        iConv = CInt(sVal)
    Catch
        iConv = iValDef
    End Try

End Function

#End Region

#Region "Installation"

Public Function bVerifierDllActiveX(ByVal sTitreComposant$, _
    ByVal sClasseDllActiveX$, ByVal sDllActiveX$, _
    ByVal sVersionDllActiveX$, _
    ByRef bRetester As Boolean, ByRef sVersionAct$, _
    Optional ByVal sDossierInst$ = "\Installation", _
    Optional ByVal sMsgLicence$ = "", _
    Optional ByVal bClassID As Boolean = False, _
    Optional ByVal sClasseDllActiveX2$ = "", _
    Optional ByRef sVersionAct2$ = "") As Boolean
    'Optional ByVal rVersionMin! = 0.0!, _
    'Optional ByVal rVersionMax! = 0.0!, _

    ' Vérifier et installer le cas échéant un composant Dll ActiveX

    Dim sTitreMsg$ = sNomAppli & " : Installation de " & sTitreComposant
    Dim bSignalerInstall As Boolean = False

Reverifier:
    If Not bVerifierInstallObjet(sClasseDllActiveX, sVersionAct, bClassID) Then
    ' Or Not bVerifierInstallObjet(sClasseDllActiveX2, sVersionAct2) Then

        Dim sCheminDllActiveX$ = Application.StartupPath & _
            sDossierInst & "\" & sDllActiveX
        Dim sMsg1$ = _
            "Le composant " & sTitreComposant & vbLf & _
            "n'est pas installé sur ce poste." & vbLf
        If Not bFichierExiste(sCheminDllActiveX) Then
            MsgBox(sMsg1 & "Le fichier " & sCheminDllActiveX & vbLf & _
                "est introuvable : " & sNomAppli & _
                " ne peut pas fonctionner sur ce poste" & vbLf & _
                "(procurez-vous le fichier " & sDllActiveX & _
                ", version " & sVersionDllActiveX & ")", _
                vbCritical, sTitreMsg)
            Exit Function
        End If

        If MsgBoxResult.Cancel = MsgBox(sMsg1 & sMsgLicence & _
            "Cliquez sur Ok pour installer ce composant." & vbLf & _
            "(note : cela requiert les droits Administrateur sur ce poste Windows," & vbLf & _
            " sinon vous obtiendrez un code d'erreur n°0x8002801c)", _
            vbOKCancel Or vbCritical, sTitreMsg) Then Exit Function

        If Not bEnregistrerDllActiveX(sDllActiveX, _
            Application.StartupPath & sDossierInst) Then Exit Function
        bSignalerInstall = True
        GoTo Reverifier

    Else
        If bSignalerInstall Then _
            MsgBox("Le composant " & sTitreComposant & _
            " a été installé avec succès.", _
                MsgBoxStyle.Exclamation, sTitreMsg)
        bVerifierDllActiveX = True
    End If

End Function

Public Function bCreerObjet(ByRef oObjetQcq As Object, ByRef sClasse$) As Boolean

    ' Instancier un contrôle ActiveX en liaison tardive (à l'exécution)

    Try
        oObjetQcq = CreateObject(sClasse)
        bCreerObjet = True
    Catch Err As Exception
        AfficherMsgErreur2(Err, "bCreerObjet", _
            "L'objet de classe [" & sClasse & "] ne peut pas être créé")
        oObjetQcq = Nothing
    End Try

End Function

Public Function bEnregistrerDllActiveX(ByRef sDllActiveX$, ByRef sChemin$, _
    Optional ByRef bDesenregistrer As Boolean = False) As Boolean

    ' Enregistrer une Dll ActiveX (ou un ocx) dans la base de registre :
    ' Une Dll ActiveX évite l'emploi des Declare pour les Dll
    '  mais requiert la commande :
    '  C:\Windows\System\Regsvr32.exe MaDll.dll
    ' Le désenregistrement se fait avec -u
    '  C:\Windows\System\Regsvr32.exe -u MaDll.dll
    '  (si il y a un package d'installation, l'enregistrement et le
    '   désenregistrement est assuré par le setup)

    Dim sCheminRegsvr32Exe$, sRepSystem$, sCmd$
    Dim sOption$, sGuillemet$, sCheminOCX$
    Const sFichierRegsvr32Exe$ = "\Regsvr32.exe"
    sRepSystem = Environment.SystemDirectory
    sCheminRegsvr32Exe = sRepSystem & sFichierRegsvr32Exe
    If Not bFichierExiste(sCheminRegsvr32Exe) Then Exit Function

    sOption = ""
    If bDesenregistrer Then sOption = " -u"

    sCheminOCX = sChemin & "\" & sDllActiveX
    sGuillemet = ""
    If InStr(sCheminOCX, " ") > 0 Then sGuillemet = """"
    If Not bFichierExiste(sCheminOCX, bPrompt:=True) Then Exit Function

    sCmd = sCheminRegsvr32Exe & sOption & " " & sGuillemet & sCheminOCX & sGuillemet
    Shell(sCmd, AppWinStyle.NormalFocus) ' Shell est spécifique à VB.Net
    ' Méthode générale en DotNet
    'Dim p As New Process
    'p.StartInfo = New ProcessStartInfo(sCheminRegsvr32Exe)
    'p.StartInfo.Arguments = sOption & " " & sGuillemet & sCheminOCX & sGuillemet
    'p.Start()

    ' Inutile, on va vérifier si on peut vraiment créér l'objet, c'est plus simple
    'If vbNo = MsgBox("Cliquez sur Oui si l'opération a réussie", vbYesNo, _
    '    "Enregistrement de " & sDllActiveX) Then Exit Function

    bEnregistrerDllActiveX = True

End Function

Public Function bCleRegistreLMExiste(ByVal sCle$, _
    Optional ByVal sSousCle$ = "", _
    Optional ByRef sValSousCle$ = "", _
    Optional ByVal sNouvValSousCle$ = "") As Boolean

    ' Vérifier si une clé LocalMachine existe dans la base de registre
    sValSousCle = ""
    Try
        Dim bEcriture As Boolean = False
        If sNouvValSousCle.Length > 0 Then bEcriture = True
        ' Si la clé n'existe pas, on passe dans le Catch
        Using rkLMCle As RegistryKey = Registry.LocalMachine
        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 bCleRegistreCRExiste(ByVal sCle$, _
    Optional ByVal sSousCle$ = "") As Boolean

    ' Vérifier si une clé ClassesRoot existe dans la base de registre
    Try
        ' Si la clé n'existe pas, on passe dans le Catch
        Using rkCle As RegistryKey = Registry.ClassesRoot
        Using rkSousCle As RegistryKey = rkCle.OpenSubKey(sCle & "\\" & sSousCle)
            If IsNothing(rkSousCle) Then Exit Function
            bCleRegistreCRExiste = True
        End Using
        End Using
    Catch
    End Try

End Function

Public Sub VerifierVersionExe(ByVal sVersionConst$)

    ' Vérification de la version de l'exécutable 
    ' sVersionConst  : constante chaîne dans le code
    ' sVersionAssemb : attribut AssemblyVersion
    Dim versionAssemb As System.Version = _
        Reflection.Assembly.GetExecutingAssembly.GetName().Version
    Dim sVersionAssemb$ = versionAssemb.ToString

    ' Ex.: 1.02 <=> 1.0.2  : Majeure, 0, SousVersion
    ' Ex.: 1.12 <=> 1.0.12 : Majeure, 0, SousVersion
    Dim sVersionAssembMajeure$ = versionAssemb.Major.ToString
    'Dim sVersionAssembMineure$ = versionAssemb.Minor.ToString ' 0 : pas utilisé
    Dim sVersionAssembSousVersion$ = versionAssemb.Build.ToString
    ' Ajouter 0 devant si < 10
    If versionAssemb.Build < 10 Then _
        sVersionAssembSousVersion = "0" & sVersionAssembSousVersion
    'Dim sVersionAssembRevision$ = versionAssemb.Revision.ToString ' pas utilisé

    Dim sVersionConstMajeure$ = sVersionConst.Split("."c)(0)
    Dim sVersionConstSousVersion$ = sVersionConst.Split("."c)(1)

    If sVersionAssembMajeure <> sVersionConstMajeure Or _
       sVersionAssembSousVersion <> sVersionConstSousVersion Then _
        MsgBox("Oublis version : " & _
            sVersionAssemb & " <> " & sVersionConst, _
            MsgBoxStyle.Exclamation)

End Sub

#End Region

#Region "Divers"

Public Sub LibererRessourceDotNet()

    GC.Collect()
    GC.WaitForPendingFinalizers()
    TraiterMsgSysteme_DoEvents()

End Sub

Public Sub Sablier(Optional ByRef bDesactiver As Boolean = False)

    If bDesactiver Then
        'm_curseur = Cursors.Default
        Cursor.Current = Cursors.Default
    Else
        'm_curseur = Cursors.WaitCursor
        Cursor.Current = Cursors.WaitCursor
    End If

    'm_oFrmMousePointer.Cursor = m_curseur ' Curseur de la feuille
    'Cursor.Current = m_curseur ' Curseur de l'application
    'Exit Sub

    ' Curseur de l'application : il est réinitialisé à chaque Application.DoEvents
    '  ou bien lorsque l'application ne fait rien
    '  du coup, il faut insister grave pour conserver le contrôle du curseur tout en 
    '  voulant afficher des messages de progression et vérifier les interruptions...
    'Dim ctrl As Control
    'For Each ctrl In m_oFrmMousePointer.Controls
    '    ctrl.Cursor = m_curseur ' Curseur de chaque contrôle de la feuille
    'Next ctrl

End Sub

Public Sub AfficherMsgErreur(ByRef Erreur As Microsoft.VisualBasic.ErrObject, _
    Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _
    Optional ByVal sDetailMsgErr$ = "")

    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 Erreur.Number > 0 Then
        sMsg &= vbCrLf & "Err n°" & Erreur.Number.ToString & " :"
        sMsg &= vbCrLf & Erreur.Description
    End If
    If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr
    MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg)

End Sub

Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _
    Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _
    Optional ByVal sDetailMsgErr$ = "", _
    Optional ByVal bCopierMsgPressePapier As Boolean = True, _
    Optional ByRef sMsgErrFinal$ = "")

    If Not Cursor.Current.Equals(Cursors.Default) Then _
        Cursor.Current = Cursors.Default
    Dim sMsg$ = ""
    If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct
    If sInfo <> "" Then sMsg &= vbCrLf & sInfo
    If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr
    If Ex.Message <> "" Then
        sMsg &= vbCrLf & Ex.Message.Trim
        If Not IsNothing(Ex.InnerException) Then _
            sMsg &= vbCrLf & Ex.InnerException.Message
    End If
    If bCopierMsgPressePapier Then CopierPressePapier(sMsg)
    sMsgErrFinal = sMsg
    MsgBox(sMsg, MsgBoxStyle.Critical)

End Sub

Public Sub CopierPressePapier(ByVal sInfo$)

    ' Copier des informations dans le presse-papier de Windows
    ' (elles resteront jusqu'à ce que l'application soit fermée)

    Try
        Dim dataObj As New DataObject
        dataObj.SetData(DataFormats.Text, sInfo)
        Clipboard.SetDataObject(dataObj)
    Catch ex As Exception
        ' Le presse-papier peut être indisponible
        AfficherMsgErreur2(ex, "CopierPressePapier", _
            bCopierMsgPressePapier:=False)
    End Try

End Sub

Public Sub TraiterMsgSysteme_DoEvents()

    Try
        Application.DoEvents() ' Peut planter avec OWC : Try Catch nécessaire
    Catch
    End Try

End Sub

Public Sub LibererRessourcesDotNet()

    GC.Collect()
    GC.WaitForPendingFinalizers()
    GC.Collect() ' Collecter aussi après les derniers finaliseurs
    TraiterMsgSysteme_DoEvents()

End Sub

Public Function bAppliDejaOuverte( _
    Optional ByVal bMemeExe As Boolean = True) As Boolean

    ' Détecter si l'application est déja lancée :
    ' - depuis n'importe quelle copie de l'exécutable
    '   (bMemeExe = Faux : tjrs une seule instance), ou bien seulement :
    ' - depuis le même emplacement du fichier exécutable sur le disque dur 
    '   (bMemeExe = Vrai par défaut : une seule instance au même endroit
    '    mais plusieurs instances possibles si les chemins sont distincts)

    Dim sExeProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.ModuleName
    Dim sNomProcessAct$ = IO.Path.GetFileNameWithoutExtension(sExeProcessAct)

    If Not bMemeExe Then
        ' Détecter si l'application est déja lancée depuis n'importe quel exe
        If Process.GetProcessesByName(sNomProcessAct).Length > 1 Then _
            bAppliDejaOuverte = True
        Exit Function
    End If

    ' Détecter si l'application est déja lancée depuis le même exe
    Dim sCheminProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.FileName
    Dim aProcessAct As Diagnostics.Process() = Process.GetProcessesByName(sNomProcessAct)
    Dim processAct As Diagnostics.Process
    Dim iNbApplis% = 0
    For Each processAct In aProcessAct
        Dim sCheminExe$ = processAct.MainModule.FileName
        If sCheminExe = sCheminProcessAct Then iNbApplis += 1
    Next
    If iNbApplis > 1 Then bAppliDejaOuverte = True

End Function

#End Region

End Module


modUtilLT.vb



' Module Utilitaire en liaison tardive

Option Strict Off ' Pour oObjetQcq.Version

Module modUtilLT

Public Function bExporterExcel(ByVal sCheminFichierXLModele$, ByVal sFichierModele$, _
    ByVal sPlageDonneesXL$, ByVal msgDelegue As clsMsgDelegue, _
    Optional ByVal bAjusterAuContenu As Boolean = False, _
    Optional ByVal sFichierXl$ = sFichierExportXL, _
    Optional ByVal bRelancerExcel As Boolean = True, _
    Optional ByVal bActualiserTCD As Boolean = True) As Boolean

    Dim bSuccesExportExcel As Boolean

    ' Sauver le fichier XL modèle modifié

    Dim sCheminFichierXL$ = Application.StartupPath & "\" & _
        sDossierExportExcel & "\" & sFichierXl
    ' Quand le nom changera, il faudra supprimer le fichier
    If Not bVerifierCreerDossier(Application.StartupPath & "\" & _
        sDossierExportExcel) Then GoTo Erreur

    If Not bFichierExiste(sCheminFichierXLModele, bPrompt:=True) Then GoTo Erreur
    If Not bFichierAccessible(sCheminFichierXLModele, bPromptFermer:=True) Then GoTo Erreur

    If bFichierExiste(sCheminFichierXL) Then
        ' On passe bLectureSeule pour afficher "Fermez le fichier"
        If Not bFichierAccessible(sCheminFichierXL, bPromptFermer:=True, _
            bLectureSeule:=True) Then GoTo Erreur
        If sCheminFichierXL <> sCheminFichierXLModele Then
            If Not bSupprimerFichier(sCheminFichierXL) Then GoTo Erreur
        End If
    End If

    ' Liaison tardive
    Dim oXLH As clsHebExcel = Nothing
    Dim oWkb As Object = Nothing
    Dim oSht As Object = Nothing
    ' Liaison précoce : avantage : mise au point,
    '  inconv. : Excel doit être installé à la bonne version
    'Dim oXL As Excel.Application, oWkb As Excel.Workbook, oSht As Excel.Worksheet
    'Set oXL = New Excel.Application ' Création d'une instance d'Excel

    Try

        Sablier()
        msgDelegue.AfficherMsg("Lancement d'Excel...")
        ' On n'interdit pas qu'Excel soit ouvert au préalable,
        '  mais on ferme le classeur à la fin, et on le réouvre dans 
        '  une autre instance : + sûr ainsi
        oXLH = New clsHebExcel(bInterdireAppliAvant:=False) ' 05/11/2008
        If IsNothing(oXLH.oXL) Then
            msgDelegue.AfficherMsg("Excel n'est pas installé !")
            GoTo Fin
        End If

        'oXLH.oXl.Visible = True ' Mode Debug
        oXLH.oXL.Visible = False

        msgDelegue.AfficherMsg("Ouverture du fichier modèle...")
        oWkb = oXLH.oXL.Workbooks.Open(sCheminFichierXLModele)

        msgDelegue.AfficherMsg("Copie des données...")
        oSht = oWkb.Worksheets(1)
        oSht.Activate() ' Activer la feuille XL
        oSht.Unprotect()
        oSht.Range(sPlageDonneesXL).Select()
        oXLH.oXL.DisplayAlerts = False ' Désactiver l'alerte plage <>
        oSht.Paste()
        oXLH.oXL.DisplayAlerts = True
        If bAjusterAuContenu Then oSht.Cells.EntireColumn.AutoFit()

        oSht.Cells(1, 1).Select()
        oSht.Activate()

        msgDelegue.AfficherMsg("Mise à jour des graphes...")
        If bActualiserTCD Then oWkb.RefreshAll() ' Mettre à jour tous les graphes, tcd...
        oWkb.Worksheets(1).Activate() ' Activer le premier classeur avant de sauver

        oXLH.oXL.DisplayAlerts = False ' Désactiver les messages
        msgDelegue.AfficherMsg("Sauvegarde du fichier...")
        oXLH.oXL.ActiveWorkbook.SaveAs(sCheminFichierXL) ' Sauver le fichier XL
        oXLH.oXL.DisplayAlerts = True

        msgDelegue.AfficherMsg("Le fichier suivant a été créé avec succès : " & sFichierXl)
        bSuccesExportExcel = True
        bExporterExcel = True

    Catch ex As Exception

        AfficherMsgErreur2(ex, "ExporterExcel", _
            "Impossible d'exporter le document sous Excel !", _
            "Cause possible : Excel est actuellement en cours d'édition d'un document")

    Finally

        'msgDelegue.AfficherMsg("Fermeture du classeur...")
        'oXLH.Fermer(oSht, oWkb, bQuitter:=True)
        'msgDelegue.AfficherMsg("")

        ' 12/05/2009 Quitter ou sinon seulement liberer
        Dim bQuitter As Boolean = False
        If Not bRelancerExcel Then bQuitter = True
        If bQuitter Then
            msgDelegue.AfficherMsg("Fermeture du classeur...")
            oXLH.Fermer(oSht, oWkb, bQuitter:=True)
            msgDelegue.AfficherMsg("")
        Else ' Liberer
            ' Penser à rendre l'instance visible
            oXLH.oXL.Visible = True
            LibererObjetCom(oSht)
            LibererObjetCom(oWkb)
            LibererObjetCom(oXLH.oXL)
            LibererObjetCom(oXLH.m_oApp) '15/05/2009
            ' Ne pas oublier car sinon ne quitte Excel que lorsqu'on quitte l'appli :
            oXLH = Nothing
            ' Ne pas attendre le recyclage pour fermer Excel, maintenant
            msgDelegue.AfficherMsg("Libération des ressources allouées...")
            LibererRessourceDotNet()
            msgDelegue.AfficherMsg("")
        End If

    End Try

    ' 12/05/2009
    'If bSuccesExportExcel And bRelancerExcel Then
    '    msgDelegue.AfficherMsg("Relancement d'Excel...")
    '    OuvrirAppliAssociee(sCheminFichierXL)
    'End If
    msgDelegue.AfficherMsg("Export terminé.")

Fin:
    Sablier(bDesactiver:=True)
    Exit Function

Erreur:
    msgDelegue.AfficherMsg("Erreur lors de l'export Excel !")

End Function

Public Function bResauverFichierExcel(ByVal sCheminFichierXL$, _
    ByVal msgDelegue As clsMsgDelegue, _
    Optional ByVal bRelancerExcel As Boolean = True) As Boolean

    Dim bSuccesExportExcel As Boolean

    ' Resauver le fichier XL sous Excel cette fois 
    ' (à cause du problème de l'export Spreadsheet Gear s'il y a des formules :
    '  "Microsoft Office Excel recalcule les formules à l'ouverture des fichiers
    '   dont le dernier enregistrement a été effectué sur une version antérieure 
    '   de Microsoft Office Excel")

    ' Liaison tardive
    Dim oXLH As clsHebExcel = Nothing
    Dim oWkb As Object = Nothing
    Dim oSht As Object = Nothing

    Try

        Sablier()
        msgDelegue.AfficherMsg("Lancement d'Excel...")
        ' On n'interdit pas qu'Excel soit ouvert au préalable,
        '  mais on ferme le classeur à la fin, et on le réouvre dans 
        '  une autre instance : + sûr ainsi
        oXLH = New clsHebExcel(bInterdireAppliAvant:=False) ' 05/11/2008
        If IsNothing(oXLH.oXL) Then
            msgDelegue.AfficherMsg("Excel n'est pas installé !")
            GoTo Fin
        End If

        oXLH.oXL.Visible = False

        msgDelegue.AfficherMsg("Ouverture du fichier...")
        oWkb = oXLH.oXL.Workbooks.Open(sCheminFichierXL)

        oXLH.oXL.DisplayAlerts = False ' Désactiver les messages
        msgDelegue.AfficherMsg("Sauvegarde du fichier...")
        oXLH.oXL.ActiveWorkbook.SaveAs(sCheminFichierXL) ' Sauver le fichier XL
        oXLH.oXL.DisplayAlerts = True

        msgDelegue.AfficherMsg("Le fichier suivant a été créé avec succès : " & _
            IO.Path.GetFileName(sCheminFichierXL))
        bSuccesExportExcel = True
        bResauverFichierExcel = True

    Catch ex As Exception

        AfficherMsgErreur2(ex, "bResauverFichierExcel", _
            "Impossible d'exporter le document sous Excel !", _
            "Cause possible : Excel est actuellement en cours d'édition d'un document")

    Finally

        'msgDelegue.AfficherMsg("Fermeture du classeur...")
        'oXLH.Fermer(oSht, oWkb, bQuitter:=True)
        'msgDelegue.AfficherMsg("")

        ' 12/05/2009 Quitter ou sinon seulement liberer
        Dim bQuitter As Boolean = False
        If Not bRelancerExcel Then bQuitter = True
        If bQuitter Then
            msgDelegue.AfficherMsg("Fermeture du classeur...")
            oXLH.Fermer(oSht, oWkb, bQuitter:=True)
            msgDelegue.AfficherMsg("")
        Else ' Liberer
            ' Penser à rendre l'instance visible
            oXLH.oXL.Visible = True
            LibererObjetCom(oSht)
            LibererObjetCom(oWkb)
            LibererObjetCom(oXLH.oXL)
            LibererObjetCom(oXLH.m_oApp) '15/05/2009
            ' Ne pas oublier car sinon ne quitte Excel que lorsqu'on quitte l'appli :
            oXLH = Nothing
            ' Ne pas attendre le recyclage pour fermer Excel, maintenant
            msgDelegue.AfficherMsg("Libération des ressources allouées...")
            LibererRessourceDotNet()
            msgDelegue.AfficherMsg("")
        End If

    End Try

    ' 12/05/2009
    'If bSuccesExportExcel And bRelancerExcel Then
    '    msgDelegue.AfficherMsg("Relancement d'Excel...")
    '    OuvrirAppliAssociee(sCheminFichierXL)
    'End If
    msgDelegue.AfficherMsg("Export terminé.")

Fin:
    Sablier(bDesactiver:=True)

End Function

Private Sub LibererObjetCom(ByRef oCom As Object) ' 15/05/2009 ByRef

    ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing

    ' Pour Excel :
    ' Quit Excel and clean up.
    ' oBook.Close(false, oMissing, oMissing);
    ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBook);
    ' oBook = null;
    ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBooks);
    ' oBooks = null;
    ' oExcel.Quit();
    ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oExcel);
    ' oExcel = null;

    If IsNothing(oCom) Then Exit Sub
    Try
        Runtime.InteropServices.Marshal.ReleaseComObject(oCom)
    Catch
    Finally
        oCom = Nothing
    End Try

End Sub

Public Function bVerifierInstallObjet(ByVal sClasse$, _
    Optional ByRef sVersion$ = "", _
    Optional ByVal bClassID As Boolean = False, _
    Optional ByVal bLireVersion As Boolean = True) As Boolean
    'Optional ByRef sMajorVersion$ = "", _
    'Optional ByRef sMinorVersion$ = ""

    ' Vérifier si le composant est bien installé
    ' Pour les serveurs com/ActiveX mono-instance comme Outlook
    '  il faut utiliser une autre version qui teste GetObject avant 
    '  CreateObject (sinon cette fonction risque de provoquer 
    '  la fermeture du composant s'il est déjà ouvert)

    If bClassID Then
        ' Si c'est une ClassID au lieu d'un ProgID
        '  on lit simplement la clé
        If bCleRegistreCRExiste("TypeLib", sClasse) Then
            bVerifierInstallObjet = True
        End If
        Exit Function
    End If

    Dim oObjetQcq As Object = Nothing
    Try
        oObjetQcq = CreateObject(sClasse) ' sClasse = ProgID
        bVerifierInstallObjet = True
    Catch 'ex As Exception
        bVerifierInstallObjet = False
    End Try
    If bVerifierInstallObjet And bLireVersion Then
        Try
            sVersion = oObjetQcq.Version.ToString
            'sVersion = CStr(oObjetQcq.Version)
            'sMajorVersion = oObjetQcq.MajorVersion
            'sMinorVersion = oObjetQcq.MinorVersion
        Catch
        End Try
    End If
    oObjetQcq = Nothing

End Function

Public Sub ExporterWord(ByVal msgDelegue As clsMsgDelegue, _
    Optional ByVal sFichierWord$ = sFichierExportWord, _
    Optional ByVal bRelancerWord As Boolean = True, _
    Optional ByVal sCheminFichierModele$ = "", _
    Optional ByVal bInterdireWordAvant As Boolean = True)

    If sCheminFichierModele.Length > 0 AndAlso _
        Not bFichierExiste(sCheminFichierModele, bPrompt:=True) Then Exit Sub

    Dim bSuccesExportWord As Boolean

    Dim sCheminFichierWord$ = Application.StartupPath & "\" & _
        sDossierExport & "\" & sFichierWord
    ' Quand le nom changera, il faudra supprimer le fichier
    If Not bVerifierCreerDossier(Application.StartupPath & "\" & _
        sDossierExport) Then Exit Sub
    If bFichierExiste(sCheminFichierWord) Then
        If Not bSupprimerFichier(sCheminFichierWord) Then
            MsgBox("Veuillez fermer le fichier :" & vbLf & _
                sCheminFichierWord, MsgBoxStyle.Exclamation, "Export Word")
            Exit Sub
        End If
    End If

    Sablier()

    msgDelegue.AfficherMsg("Lancement de Word...")
    Dim oWrdH As New clsHebWord(bInterdireWordAvant)
    If IsNothing(oWrdH.oWrd) Then
        If oWrdH.m_bAppliDejaOuverte Then
            msgDelegue.AfficherMsg("Veuillez fermer Word S.V.P. !")
        Else
            msgDelegue.AfficherMsg("Word n'est pas installé !")
        End If
        GoTo Fin
    End If

    Try

        If sCheminFichierModele.Length > 0 Then
            msgDelegue.AfficherMsg("Ouverture du fichier modèle...")
            oWrdH.oWrd.Documents.Open(sCheminFichierModele)
            ' Aller à la fin du document
            oWrdH.oWrd.Selection.EndKey(Unit:=6) 'wdStory
        Else
            oWrdH.oWrd.Documents.Add() ' Créer un nouveau document
            ' Passage en mode paysage : wdOrientLandscape = 1
            oWrdH.oWrd.ActiveDocument.PageSetup.Orientation = 1
            ' Ajouter une ligne avant le tableau
            oWrdH.oWrd.Selection.TypeParagraph()
        End If

        msgDelegue.AfficherMsg("Copie des données...")
        oWrdH.oWrd.Selection.Paste()

        msgDelegue.AfficherMsg("Sauvegarde du fichier...")
        oWrdH.oWrd.DisplayAlerts = False ' Désactiver les messages
        ' Sauver le fichier Word
        oWrdH.oWrd.ActiveDocument.SaveAs(sCheminFichierWord)
        oWrdH.oWrd.DisplayAlerts = True

        bSuccesExportWord = True

    Catch ex As Exception

        AfficherMsgErreur2(ex, "ExporterWord", _
            "Impossible d'exporter le document sous Word !", _
            "Cause possible : Word est actuellement en cours d'édition d'un document")

    Finally

        Try
            ' Fermer Word en évitant tout risque d'instance orpheline
            msgDelegue.AfficherMsg("Fermeture de Word...")
            oWrdH.oWrd.Quit()
            LibererObjetCom(oWrdH.oWrd)
        Catch
        End Try

        Try
            ' Fermer Word en évitant tout risque d'instance orpheline
            msgDelegue.AfficherMsg("Libération de Word...")
            oWrdH.Quitter()
        Catch
        End Try
        oWrdH = Nothing

        ' Libérer la mémoire DotNet pour éviter les verrous sur Word
        LibererRessourcesDotNet()

    End Try

    If bSuccesExportWord And bRelancerWord Then
        ' Réouvrir Word de façon indépendante de DotNet cette fois
        msgDelegue.AfficherMsg("Réouverture de Word...")
        OuvrirAppliAssociee(sCheminFichierWord)
    End If
    'msgDelegue.AfficherMsg("Export terminé.")
    If bSuccesExportWord Then msgDelegue.AfficherMsg( _
        "Le fichier suivant a été créé avec succès : " & sFichierWord)

Fin:
    Sablier(bDesactiver:=True)

End Sub

End Module


modUtilOWC.vb



Module modUtilOWC

#Region "Gestion du séparateur décimal"

Public Declare Function SetLocaleInfo% Lib "kernel32" Alias "SetLocaleInfoA" ( _
    ByVal Locale%, ByVal LCType%, ByVal lpLCData$)
Public Declare Function GetSystemDefaultLCID% Lib "kernel32" ()

Public Function bChangerSeparateurDecimal(Optional ByVal sSepDecimalImpose$ = ".", _
    Optional ByVal bRetablir As Boolean = False) As Boolean

    ' On peut lire le sép decimal au lancement du programme, 
    '  mais NumberDecimalSeparator() n'est pas mis à jour ensuite
    Dim sSepDecimalActuel$ = _
        Globalization.NumberFormatInfo.CurrentInfo.NumberDecimalSeparator()

    Dim lCodePage_LCID%, lRet% ' Long en VB6
    ' Code du séparateur décimal : decimal separator
    Const lLOCALE_SDECIMAL% = 14

    ' Conserver le séparateur décimal actuel
    Static bChangementEffectif As Boolean
    Static sPrecedentSepDecimal$
    If sPrecedentSepDecimal = "" Then _
        sPrecedentSepDecimal = sSepDecimalActuel

    ' Forcer le séparateur décimal (par exemple ".")
    Dim lFalse& = 0
    If Not bRetablir And sSepDecimalActuel <> sSepDecimalImpose Then
        lCodePage_LCID = GetSystemDefaultLCID() ' Lire le code page actuel
        lRet = SetLocaleInfo(lCodePage_LCID, lLOCALE_SDECIMAL, sSepDecimalImpose)
        If lRet = lFalse Then Exit Function
        bChangementEffectif = True
    End If

    ' Rétablir le précédent séparateur décimal avant l'appel à cette fonction
    If bRetablir And bChangementEffectif Then
        lCodePage_LCID = GetSystemDefaultLCID() ' Lire le code page actuel
        lRet = SetLocaleInfo(lCodePage_LCID, lLOCALE_SDECIMAL, sPrecedentSepDecimal)
        If lRet = lFalse Then Exit Function
        bChangementEffectif = False
    End If

    bChangerSeparateurDecimal = True

End Function

#End Region

#Region "Vérifications"

Public Function bVerifierFichiers(ByVal sCheminDLL$) As Boolean

    If Not bFichierExiste(sCheminDLL & _
        "\ADODB.dll", bPrompt:=True) Then Exit Function

    ' Vérification OWC9
    If ucTableur.iOWC = ucTableur.iOWC9 Or _
      (bGraphiques And ucGraphe.iOWC = ucGraphe.iOWC9) Then
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllOWC9AxInterop, bPrompt:=True) Then Exit Function
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllOWC9Interop, bPrompt:=True) Then Exit Function

        If bGraphiques And ucGraphe.iOWC = ucGraphe.iOWC9 Then
            ' Cette dll doit être présente aussi en OWC9 s'il y a des graphiques
            If Not bFichierExiste(sCheminDLL & _
                "\" & ucTableur.sDllMSDataSrcOWC9, bPrompt:=True) Then Exit Function
        End If

    End If

    ' Vérification OWC10
    If ucTableur.iOWC = ucTableur.iOWC10 Or _
        (bGraphiques And ucGraphe.iOWC = ucGraphe.iOWC10) Then
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllOWC10AxInterop, bPrompt:=True) Then Exit Function
        ' Cette dll doit être présente aussi en OWC9 s'il y a des graphiques
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllMSDataSrcOWC10, bPrompt:=True) Then Exit Function
        ' Ne pas confondre cette dll (456 Ko) avec la dll du même nom
        '  contenant les composants OWC10(XP) : 7083 Ko
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllOWC10Interop, bPrompt:=True) Then Exit Function
    End If

    ' Vérification OWC11
    If ucTableur.iOWC = ucTableur.iOWC11 Or _
        (bGraphiques And ucGraphe.iOWC = ucGraphe.iOWC11) Then
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllOWC11AxInterop, bPrompt:=True) Then Exit Function
        ' Cette dll doit être présente aussi en OWC9 s'il y a des graphiques
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllMSDataSrcOWC11, bPrompt:=True) Then Exit Function
        If Not bFichierExiste(sCheminDLL & _
            "\" & ucTableur.sDllOWC11Interop, bPrompt:=True) Then Exit Function
    End If

    bVerifierFichiers = True

End Function

Public Function bVerifierComposants( _
    Optional ByVal bPrompt As Boolean = False, _
    Optional ByRef bRetester As Boolean = False) As Boolean

    Dim rVersionADOAct! = 0
    Dim sVersionOWCAct$ = ""
    Dim sVersionOWCGrAct$ = ""
    If Not bVerifierADO(bRetester, rVersionADOAct) Then Exit Function
    If Not bVerifierOWC(bRetester, sVersionOWCAct, sVersionOWCGrAct) Then Exit Function

    bVerifierComposants = True

    If Not bPrompt Then Exit Function

    ' vbCrLf : retour à la ligne qui marche dans un MsgBox 
    '  et aussi dans le presse-papier !
    ' sNomAppli & " version " & sVersionAppli & " du " & sDateVersionAppli & vbCrLf
    Dim sInfo$ = _
        sNomAppli & " " & sVersionAppli & _
            " (" & sDateVersionAppli & ")" & vbCrLf & _
        "Les composants suivants sont installés :" & vbCrLf & _
        "ADO version : [" & rVersionADOAct & "]" & vbCrLf & _
        "OWC version : [" & sVersionOWCAct & "]" & vbCrLf
    If sVersionOWCGrAct.Length > 0 And _
       sVersionOWCGrAct <> sVersionOWCAct Then
        sInfo &= _
            "OWC Gr. version : [" & sVersionOWCGrAct & "]" & vbCrLf
    End If
    sInfo &= _
        "Framework .Net version : [" & Environment.Version.ToString & "]"

    CopierPressePapier(sInfo)

    MsgBox(sInfo & vbCrLf & _
        "(ces informations ont été copiées dans le presse-papier)", _
        MsgBoxStyle.Information, _
        sTitreMsg & " " & sVersionAppli & _
        " (" & sDateVersionAppli & ")")

End Function

Public Function bVerifierADO(ByRef bRetester As Boolean, _
    ByRef rVersionADO!) As Boolean

    Dim bPbADO As Boolean, sVersionADO$, sMsgPbADO$
    Const sTitreADO$ = _
        "Installation des 'Microsoft Data Access Components' (MDAC)"
    Const sClasseObjetADODBConnection$ = "ADODB.Connection"
    Const sClasseObjetADODBRecordset$ = "ADODB.Recordset"

    rVersionADO = 0 : sVersionADO = "" : sMsgPbADO = ""
    If Not bVerifierInstallObjet(sClasseObjetADODBConnection, sVersionADO) Or _
       Not bVerifierInstallObjet(sClasseObjetADODBRecordset, bLireVersion:=False) Then
        bPbADO = True
        sMsgPbADO = "Les composants d'accès aux données ne sont pas installés sur ce poste."
    End If

    If sVersionADO <> "" Then
        rVersionADO = rConvStrEnReel(sVersionADO)
        If rVersionADO < 2.6! Then ' Ne pas oublier 2.6 single !!!
            sMsgPbADO = "La version des composants d'accès aux données est trop ancienne :" & vbLf & _
                rVersionADO & " au lieu de 2.6 requis au minimum pour la plateforme .Net"
            bPbADO = True
        End If
    End If

    If Not bPbADO Then bVerifierADO = True : Exit Function

    Dim sCheminMDac$ = Application.StartupPath & "\Installation\MDAC_TYP.EXE"
    If Not bFichierExiste(sCheminMDac) Then
        MsgBox(sMsgPbADO & vbLf & _
            "Vous pouvez les télécharger gratuitement sur le site de Microsoft France :" & vbLf & _
            "www.microsoft.com/france/ : MDAC_TYP.EXE (actuellement en version 2.8 : 5.447 Mo)", _
            MsgBoxStyle.Critical, sTitreADO)
        ' Pour ADO, autoriser la poursuite du programme, on verra bien
        bVerifierADO = True : Exit Function
    End If

    Dim iReponse% = MsgBox(sMsgPbADO & vbLf & _
        "Voulez-vous installer la version 2.6 ?" & vbLf & _
        sCheminMDac & vbLf & _
        "(note : cela requiert les droits Administrateur sur ce poste Windows)", _
        MsgBoxStyle.YesNoCancel Or MsgBoxStyle.Critical, _
        "Installation des composants d'accès aux données ADO 2.6")
    If iReponse <> MsgBoxResult.Yes Then bRetester = True
    ' Pour ADO, autoriser la poursuite du programme, on verra bien
    If iReponse = MsgBoxResult.Cancel Then
        bVerifierADO = True : Exit Function
    End If
    If iReponse = MsgBoxResult.Yes Then
        Shell(sCheminMDac)
        Exit Function
    End If

End Function

Public Function bVerifierOWC(ByRef bRetester As Boolean, _
    ByRef sVersionOWCAct$, _
    Optional ByRef sVersionOWCGrAct$ = "") As Boolean

    ' Vérification et installation d'OWC, le cas échéant 
    ' (en mode release seulement)

    Const sMsgLicenceOWC$ = _
        "Si vous avez une licence MS-Office version >=2000," & vbLf

    bVerifierOWC = bVerifierDllActiveX( _
        ucTableur.sCompOWC, ucTableur.sClasseOWCSS, _
        ucTableur.sDllOWC, ucTableur.sVersionOWC, _
        bRetester, sVersionOWCAct, , sMsgLicence:=sMsgLicenceOWC)
    sVersionOWCAct = sVersionOWCAct.Trim
    If Not bVerifierOWC Then Exit Function

    If bGraphiques Then
        bVerifierOWC = bVerifierDllActiveX( _
            ucGraphe.sCompOWC, ucGraphe.sClasseOWCChart, _
            ucGraphe.sDllOWC, ucGraphe.sVersionOWC, _
            bRetester, sVersionOWCGrAct, , sMsgLicence:=sMsgLicenceOWC)
        sVersionOWCGrAct = sVersionOWCGrAct.Replace("WebChart:", "")
        sVersionOWCGrAct = sVersionOWCGrAct.Replace("Chart:", "")
        sVersionOWCGrAct = sVersionOWCGrAct.Trim
    End If

    If Not ucTableur.iOWC > ucTableur.iOWC9 Then Exit Function

    Dim sVersionMSComCtlAct$ = "" ' On ne peut pas lire la version
    bVerifierOWC = bVerifierDllActiveX( _
        ucTableur.sMSComCTL, ucTableur.sClasseMSComCTL, _
        ucTableur.sOcxMSComCTL, ucTableur.sVersionMSComCTL, _
        bRetester, sVersionMSComCtlAct, , , bClassID:=True)

    ' 3 versions possibles ! risque d'alerte trop elevé : mieux vaut éviter
    'If Not (sVersionOWCAct = ucTableur.sVersionOWC10_Exacte Or _
    '        sVersionOWCAct = ucTableur.sVersionOWC10_Exacte2 Or _
    '        sVersionOWCAct = ucTableur.sVersionOWC10_Exacte3) Then
    '    MsgBox("Le SP3 d'Office 2003 n'est pas installé : Consultez le site" & vbLf & _
    '        "'Microsoft Office Update' si 'Windows Update' ne vous le propose pas." & vbLf & _
    '        "Version OWC10 actuelle : " & sVersionOWCAct & vbLf & _
    '        "Version OWC10 attendue : " & ucTableur.sVersionOWC10_Exacte, _
    '        MsgBoxStyle.Exclamation, sTitreMsg)
    '    ' Ne pas quitter pour pouvoir faire les maj !
    '    'bVerifierOWC = False
    '    'Exit Function
    'End If

End Function

#End Region

End Module


ucTableur.vb



' Fichier ucTableur.vb
' --------------------
' Version 1.07 du 18/06/2009 ' Gestion Scroll + nouvelles fonctions utiles
' Version 1.06 du 17/10/2008 ' fct AnnulerEdition()
' Version 1.05 du 11/07/2008 ' OWC11 + nouvelles fonctions utiles
' Version 1.04 du 02/04/2008
' Version 1.03 du 11/03/2007

' Les constantes conditionnelles sont privées au module 
' (sinon les mettre dans les options du projet pour les rendre globales
'  ou bien utiliser tout simplement une constante déclarée
'  dans chaque cas si le code spécifique se compile sans erreur)

' Attention : risque de confusion des fichiers ressources :
'#Const bOWC = True ' Sinon XmlSS
'#If bOWC Then ' Jusqu'à la fin du fichier

' Liaison tardive pour certaines opérations, 
'  par ex. Cell.Value ou .Text : pas d'intellisense pour ces 2 fonctions
'  qui pourtant existent
Option Strict Off

#Const iOWC9 = 9
#Const iOWC10 = 10
#Const iOWC11 = 11 ' 11 et 12 sous Vista
'#Const iSpreadSheetXml = 0
#Const iSpreadSheetGear = 1
#Const iOWC = iOWC11

#If iOWC = iOWC9 Then
    Imports OWC     ' cf. sDllOWC9Interop
    Imports AxOWC   ' cf. sDllOWC9AxInterop
#ElseIf iOWC = iOWC10 Then
    Imports OWC10   ' cf. sDllOWC10Interop
    Imports AxOWC10 ' cf. sDllOWC10AxInterop
#ElseIf iOWC = iOWC11 Then
    'Imports Microsoft.Office.Interop.Owc11 
    'Imports AxMicrosoft.Office.Interop.Owc11 
    Imports OWC11   ' cf. sDllOWC11Interop
    Imports AxOWC11 ' cf. sDllOWC11AxInterop
#End If

Public Class ucTableur : Inherits UserControl

#Region "Déclarations"

Public Const iSpreadSheetGear% = 1
Public Const sExtModele$ = ".htm"

Public Const sCompOWC9$ = "'Office Web Components' version 9 (2000)"
Public Const sDllOWC9$ = "MSOWC.DLL"
Public Const sDllOWC9Interop$ = "Interop.OWC.dll"
Public Const sDllOWC9AxInterop$ = "AxInterop.OWC.dll"
Public Const sClasseOWC9SS$ = "OWC.Spreadsheet.9"
Public Const sClasseOWC9Chart$ = "OWC.Chart.9"
Public Const sVersionOWC9$ = "9.0.0.3821 du 22/02/2000 : 3Mo"
Public Const sDllMSDataSrcOWC9$ = "MSDATASRC.dll" ' 7.0.9466.0

Public Const sCompOWC10$ = "'Office XP Web Components' version 10 (2002)"
' Ne pas confondre la dll interop (424 Ko en version 2621,
'  ou 456 Ko en version 6765) avec la dll du même nom contenant 
'  les composants OWC10 (XP) : 7262 Ko (2621) ou 7083 Ko (6765)
Public Const sDllOWC10$ = "OWC10.DLL" ' 7083 Ko
Public Const sDllOWC10Interop$ = "OWC10.DLL" ' 424 Ko (2621) ou 456 Ko (6765)
Public Const sDllOWC10AxInterop$ = "axowc10.dll" ' 148 Ko
Public Const sClasseOWC10SS$ = "OWC10.Spreadsheet.10"
Public Const sClasseOWC10Chart$ = "OWC10.ChartSpace.10"
'Public Const sVersionOWC10$ = "10.0.2621.0 du 24/02/2001 : 7Mo"
Public Const sVersionOWC10$ = "10.0.6765.0 du 03/06/2005 : 7Mo" ' SP3
'Public Const sVersionOWC10_Exacte$ = "10.0.0.6765" ' SP3
'Public Const sVersionOWC10_Exacte2$ = "10.0.0.6619" ' SP3
'Public Const sVersionOWC10_Exacte3$ = "10.0.0.6829" ' SP3 du 12/12/2007 : ne plus vérifier !
Public Const sDllMSDataSrcOWC10$ = "MSDATASRC.dll" ' 7.0.9466.0

Public Const sCompOWC11$ = "'Office 2003 Web Components' version 11 & 12"
Public Const sDllOWC11$ = "OWC11.DLL" ' 6878 Ko (11.0.0.8166)
Public Const sDllOWC11Interop$ = "Interop.OWC11.dll" ' 444 Ko (8166)
Public Const sDllOWC11AxInterop$ = "AxInterop.OWC11.dll" ' 148 Ko
Public Const sClasseOWC11SS$ = "OWC11.Spreadsheet.11"
Public Const sClasseOWC11Chart$ = "OWC11.ChartSpace.11"
'Public Const sVersionOWC11$ = "11.0.0.8166 de 2003 : 7Mo" ' 7881 Ko V11 11.0.8166.0
Public Const sVersionOWC11$ = "12.0.0.4518 du 10/11/2006 : 7Mo" ' 6878 Ko 12.0.4518.1014 
Public Const sDllMSDataSrcOWC11$ = "MSDATASRC.dll" ' 7.0.9466.0
' Note : une référence à la DLL Interop.MSComctlLib.dll est requise pour le mode design

' Contrairement à OWC9, OWC10 requiert que le contrôle MSComCTL.OCX
'  soit enregistré pour que la barre d'outils soit visible
' (sinon la barre n'est pas visible, mais cela ne plante pas)
'Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCTL.OCX 
'HKEY_CLASSES_ROOT\TypeLib\{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}
'MSComctlLib mscomctl
' = Microsoft Windows Common Controls 6.0 (SP6) Version PIA = 10.0.4504.0 
Public Const sMSComCTL$ = "Windows Common Controls" ' ActiveX Control DLL
Public Const sClasseMSComCTL$ = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}" ' ClassID et non ProgID
Public Const sVersionMSComCTL$ = "6.01.9782 du 09/03/2004 : 1057 Ko"
Public Const sOcxMSComCTL$ = "MSComCTL.OCX" ' 1057 Ko 6.1.97.82 09/03/2004

Public Const iOWC9% = 9
Public Const iOWC10% = 10
Public Const iOWC11% = 11

#If iOWC = iOWC11 Then
    Public Const iOWC% = 11
    Public Const sCompOWC$ = sCompOWC11
    Public Const sVersionOWC$ = sVersionOWC11
    Public Const sClasseOWCSS$ = sClasseOWC11SS
    'Public Const sClasseOWCChart$ = sClasseOWC11Chart
    Public Const sDllOWC$ = sDllOWC11
#ElseIf iOWC = iOWC10 Then
    Public Const iOWC% = 10
    Public Const sCompOWC$ = sCompOWC10
    Public Const sVersionOWC$ = sVersionOWC10
    Public Const sClasseOWCSS$ = sClasseOWC10SS
    'Public Const sClasseOWCChart$ = sClasseOWC10Chart
    Public Const sDllOWC$ = sDllOWC10
#ElseIf iOWC = iOWC9 Then
    Public Const iOWC% = 9
    Public Const sCompOWC$ = sCompOWC9
    Public Const sVersionOWC$ = sVersionOWC9
    Public Const sClasseOWCSS$ = sClasseOWC9SS
    'Public Const sClasseOWCChart$ = sClasseOWC9Chart
    Public Const sDllOWC$ = sDllOWC9
#ElseIf iOWC = iSpreadSheetGear Then
    Public Const iOWC% = iSpreadSheetGear
    Public Const sCompOWC$ = ""
    Public Const sVersionOWC$ = ""
    Public Const sClasseOWCSS$ = ""
    Public Const sDllOWC$ = ""
#End If

Public Const sCodeCouleurBlanc$ = "16777215"

' Seules certaines couleurs html fonctionnent
'  si on reprend le code dans le fichier modele html, ça passe ! par exemple Ivoire : #FFFF99
'http://www.computerhope.com/htmcolor.htm
'http://www.mvps.org/dmcritchie/excel/colors.htm
Public Const sCouleurMarron$ = "Brown" 'Pas vraiment marron, sorte de rouge
Public Const sCouleurViolet$ = "Purple"
Public Const sCouleurIvoire$ = "#FFFF99"
Public Const sCouleurGrisTresClair$ = "#EAEAEA"

Public Const sCouleurRouge$ = "Red"
Public Const sCouleurBlanc$ = "White"
Public Const sCouleurNoir$ = "Black"
Public Const sCouleurOrange$ = "Orange"
Public Const sCouleurGris$ = "Gray" 'LightGray n'existe pas : Silver
Public Const sCouleurGrisClair$ = "Silver"
Public Const sCouleurVertFonce$ = "Green"
Public Const sCouleurVert$ = "LightGreen" ' "Green" 
Public Const sCouleurBleu$ = "Blue"
Public Const sCouleurBleuClair$ = "LightBlue"
Public Const sCouleurCyan$ = "Cyan"
Public Const sCouleurJaune$ = "Yellow"
Public Const sCouleurRose$ = "Pink"

Public Const iCodeCouleurBleu% = 16711680   ' Blue   RGB(0, 0, 255)     &HFF
Public Const iCodeCouleurCyan% = 16776960   ' Cyan   RGB(0, 255, 255)
Public Const iCodeCouleurVertFonce% = 32768 ' Green  RGB(0, 128, 0)
Public Const iCodeCouleurJaune% = 65535     ' Yellow RGB(255, 255, 0)
Public Const iCodeCouleurRose% = 13619199   ' Pink   RGB(255, 207, 207)
Public Const iCodeCouleurOrange% = 39423    ' Orange RGB(255, 153, 0)
Public Const iCodeCouleurRouge% = 255       ' Red    RGB(255, 0, 0)

Public Const iBordHaut% = 0
Public Const iBordBas% = 1
Public Const iBordGauche% = 2
Public Const iBordDroite% = 3
Public Const iBordTous% = 4

Public Event EvCelluleDblClic(ByVal iCol%, ByVal iLigne%, ByVal sValeur$)
' Changement de la sélection en cours des cellules par l'utilisateur :
Public Event EvSelectionChange(ByVal iCol%, ByVal iLigne%, ByVal sValeur$)
' Changement du contenu d'une cellule à la suite d'une saisie par l'utilisateur :
Public Event EvCelluleChange(ByVal iCol%, ByVal iLigne%, ByVal sAncienneValeur$)
Public Event EvCelluleClic(ByVal iCol%, ByVal iLigne%, ByVal sValeur$)
' Pas encore utilisé :
Public Event EvCelluleTouchePress(ByVal iCol%, ByVal iLigne%, ByVal sValeur$)

Private Const sFormatTexteOWC$ = "@"

Public m_bEdition As Boolean ' Passage en Public le 02/10/2008
Private m_bLectureSeule As Boolean
Private m_bCollageInterdit As Boolean
Private m_bModifierStructureInterdit As Boolean
Private m_bAfficherMsgErr As Boolean
Private m_bActivationSimpleClic As Boolean ' Simple clic = double clic

Private m_iLigneEdition%
Private m_iColEdtion%
Private m_sValEditionOrig$ ', m_sFormuleEditionOrig$

Private m_dDateDblClic As Date

#End Region

#Region " Code généré par le Concepteur Windows Form "

    Public Sub New()
        MyBase.New()

        'Cet appel est requis par le Concepteur Windows Form.
        InitializeComponent()

        'Ajoutez une initialisation quelconque après l'appel InitializeComponent()
        Initialisation()

    End Sub

    'La méthode substituée Dispose du UserControl pour nettoyer la liste des composants.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        'Try
            MyBase.Dispose(disposing)
        'Catch
        'End Try
    End Sub

    'Requis par le Concepteur Windows Form
    Private components As System.ComponentModel.IContainer

    'REMARQUE : la procédure suivante est requise par le Concepteur Windows Form
    'Elle peut être modifiée en utilisant le Concepteur Windows Form.  
    'Ne la modifiez pas en utilisant l'éditeur de code.
    Friend WithEvents oXL As AxSpreadsheet
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
Dim resources As System.ComponentModel.ComponentResourceManager = New System.ComponentModel.ComponentResourceManager(GetType(ucTableur))
Me.oXL = New AxSpreadsheet
CType(Me.oXL, System.ComponentModel.ISupportInitialize).BeginInit()
Me.SuspendLayout()
'
'oXL
'
Me.oXL.DataSource = Nothing
Me.oXL.Dock = System.Windows.Forms.DockStyle.Fill
Me.oXL.Enabled = True
Me.oXL.Location = New System.Drawing.Point(3, 3)
Me.oXL.Margin = New System.Windows.Forms.Padding(0)
Me.oXL.Name = "oXL"
Me.oXL.OcxState = CType(resources.GetObject("oXL.OcxState"), System.Windows.Forms.AxHost.State)
Me.oXL.Size = New System.Drawing.Size(443, 319)
Me.oXL.TabIndex = 0
'
'ucTableur
'
Me.Controls.Add(Me.oXL)
Me.Margin = New System.Windows.Forms.Padding(0)
Me.Name = "ucTableur"
Me.Padding = New System.Windows.Forms.Padding(3)
Me.Size = New System.Drawing.Size(449, 325)
CType(Me.oXL, System.ComponentModel.ISupportInitialize).EndInit()
Me.ResumeLayout(False)

End Sub

#End Region

#Region "Propriétés du tableur"

Public Property bAfficherMsgErr() As Boolean
' On affichera les erreurs qu'en mode debug. Pour trouver la ligne qui provoque
'  une erreur, il faut tout cocher (Thrown) dans le menu Debug : Exceptions... 
'  mais à ce moment là, toutes les erreurs stopperont le débogueur (on peut alors
'  ne cocher que l'erreur qu'on cherche, mais il faut la trouver dans la liste)
'  Cette technique permet d'améliorer la qualité de programmation (éviter les 
'  erreurs plutôt que de les traiter, c'est + rapide à l'éxécution et + fiable).
' Autre possibilité : utiliser un "On Error Resume X" débrayable :
'  If bTrapErr Then On Error Resume X Else On Error Goto 0
'  mais pour cela il faudrait enlever tous les try catch ! 
' Autre possibilité : propriété bRenvoyerErr et Raise ou Throw ex 
'  mais cela n'apporterait pas grand chose, autant traiter l'erreur au plus près
Get
    bAfficherMsgErr = Me.m_bAfficherMsgErr
End Get
Set(ByVal bValeur As Boolean)
    Me.m_bAfficherMsgErr = bValeur
End Set
End Property

Public Property bAfficherQuadrillage() As Boolean
Get
    ' Lire l'état de l'option "Afficher le Quadrillage"
    Try
        bAfficherQuadrillage = CBool(Me.oXL.DisplayGridlines)
    Catch
    End Try
End Get
Set(ByVal bValeur As Boolean)
    ' Vérrouiller ou pas une plage de cellules
    Try
        Me.oXL.DisplayGridlines = bValeur
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then _
            AfficherMsgErreur2(ex, "bAfficherQuadrillage.Set")
    End Try
End Set
End Property

Public Property bAfficherBarreDefilV() As Boolean
Get
    bAfficherBarreDefilV = CBool(Me.oXL.DisplayVerticalScrollBar)
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.DisplayVerticalScrollBar = bValeur
End Set
End Property

Public Property bAfficherBarreDefilH() As Boolean
Get
    bAfficherBarreDefilH = CBool(Me.oXL.DisplayHorizontalScrollBar)
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.DisplayHorizontalScrollBar = bValeur
End Set
End Property

#If iOWC = iOWC9 Then

Public Property bActiverCalculAuto() As Boolean
Get
    Try
        bActiverCalculAuto = CBool(Me.oXL.EnableAutoCalculate)
    Catch
    End Try
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.EnableAutoCalculate = bValeur
End Set
End Property

Public Property bAfficherEntetesColonne() As Boolean
Get
    bAfficherEntetesColonne = CBool(Me.oXL.DisplayColHeaders)
    'bAfficherEntetesColonne = CBool(Me.oXL.ActiveWindow.DisplayColumnHeadings) ' OWC10
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.DisplayColHeaders = bValeur
    ' Ne marche plus en OWC10 que lorsque le tableur est déjà affiché
    'Me.oXL.ActiveWindow.DisplayColumnHeadings = bValeur ' OWC10
End Set
End Property

Public Property bAfficherEntetesLigne() As Boolean
Get
    bAfficherEntetesLigne = CBool(Me.oXL.DisplayRowHeaders)
    'bAfficherEntetesLigne = CBool(Me.oXL.ActiveWindow.DisplayRowHeadings) ' OWC10
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.DisplayRowHeaders = bValeur
    'Me.oXL.ActiveWindow.DisplayRowHeadings = bValeur ' OWC10
End Set
End Property

Public Property bAfficherOngletFeuille() As Boolean
Get
    bAfficherOngletFeuille = False
    'bAfficherOngletFeuille = CBool(Me.oXL.DisplayTitleBar) ' OWC10
End Get
Set(ByVal bValeur As Boolean)
    ' N'existe pas en OWC9
    ' Ne marche que si le tableur OWC10 est déjà affichée
    'Me.oXL.ActiveWindow.DisplayWorkbookTabs = bValeur ' OWC10
End Set
End Property

#End If

#If iOWC >= iOWC10 Then

Public Property bActiverCalculAuto() As Boolean
Get
    bActiverCalculAuto = True
    ' EnableAutoCalculate n'existe plus en OWC10
    'Try
    '    bActiverCalculAuto = CBool(Me.oXL.EnableAutoCalculate) ' OWC9
    'Catch
    'End Try
    Try
        bActiverCalculAuto = CBool( _
            Me.oXL.Calculation = XlCalculation.xlCalculationAutomatic) ' OWC10
    Catch
    End Try
End Get
Set(ByVal bValeur As Boolean)
    'Me.oXL.EnableAutoCalculate = bValeur ' OWC9
    ' OWC10 :
    If bValeur Then
        Me.oXL.Calculation = XlCalculation.xlCalculationAutomatic
    Else
        Me.oXL.Calculation = XlCalculation.xlCalculationManual
    End If
End Set
End Property

Public Property bAfficherEntetesColonne() As Boolean
Get
    'bAfficherEntetesColonne = CBool(Me.oXL.DisplayColHeaders) ' OWC9
    bAfficherEntetesColonne = CBool(Me.oXL.ActiveWindow.DisplayColumnHeadings)
End Get
Set(ByVal bValeur As Boolean)
    'Me.oXL.DisplayColHeaders = bValeur ' OWC9
    ' Ne marche plus que lorsque le tableur est déjà affiché
    Me.oXL.ActiveWindow.DisplayColumnHeadings = bValeur
End Set
End Property

Public Property bAfficherEntetesLigne() As Boolean
Get
    'bAfficherEntetesLigne = CBool(Me.oXL.DisplayRowHeaders) ' OWC9
    bAfficherEntetesLigne = CBool(Me.oXL.ActiveWindow.DisplayRowHeadings)
End Get
Set(ByVal bValeur As Boolean)
    'Me.oXL.DisplayRowHeaders = bValeur ' OWC9
    Me.oXL.ActiveWindow.DisplayRowHeadings = bValeur
End Set
End Property

Public Property bAfficherOngletFeuille() As Boolean
Get
    bAfficherOngletFeuille = CBool(Me.oXL.DisplayTitleBar)
End Get
Set(ByVal bValeur As Boolean)
    ' Ne marche que si le tableur est déjà affichée
    Me.oXL.ActiveWindow.DisplayWorkbookTabs = bValeur
End Set
End Property

#End If

Public Property bAfficherBarreOutils() As Boolean
Get
    bAfficherBarreOutils = CBool(Me.oXL.DisplayToolbar)
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.DisplayToolbar = bValeur
End Set
End Property

Public Property bAfficherBarreTitre() As Boolean
Get
    'Dim sTitre$ = Me.oXL.TitleBar.Caption
    bAfficherBarreTitre = CBool(Me.oXL.DisplayTitleBar)
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.DisplayTitleBar = bValeur
End Set
End Property

Public Property sTitre$()
Get
    sTitre = Me.oXL.TitleBar.Caption
End Get
Set(ByVal sValue$)
    Me.oXL.TitleBar.Caption = sValue
End Set
End Property

Public Property bLectureSeule() As Boolean
Get
    bLectureSeule = Me.m_bLectureSeule
End Get
Set(ByVal bValeur As Boolean)
    Me.m_bLectureSeule = bValeur
End Set
End Property

Public Property bCollageInterdit() As Boolean
Get
    bCollageInterdit = Me.m_bCollageInterdit
End Get
Set(ByVal bValeur As Boolean)
    Me.m_bCollageInterdit = bValeur
End Set
End Property

Public Property bModifierStructureInterdit() As Boolean
Get
    bModifierStructureInterdit = Me.m_bModifierStructureInterdit
End Get
Set(ByVal bValeur As Boolean)
    Me.m_bModifierStructureInterdit = bValeur
End Set
End Property

Public Property bActivationSimpleClic() As Boolean
Get
    bActivationSimpleClic = Me.m_bActivationSimpleClic
End Get
Set(ByVal bValeur As Boolean)
    Me.m_bActivationSimpleClic = bValeur
End Set
End Property

#End Region

#Region "Propriétés de la feuille active"

Public Property bProtegerFeuille() As Boolean
Get
    bProtegerFeuille = Me.oXL.ActiveSheet.Protection.Enabled
End Get
Set(ByVal bValeur As Boolean)
    Me.oXL.ActiveSheet.Protection.Enabled = bValeur
End Set
End Property

Public Property bVerrouillerPlage(ByVal sPlage$) As Boolean
Get
    ' Lire l'état Vérrouillé ou pas d'une plage de cellules
    Try
        bVerrouillerPlage = CBool(Me.oXL.ActiveSheet.Range(sPlage).Locked)
    Catch
    End Try
End Get
Set(ByVal bValeur As Boolean)
    ' Vérrouiller ou pas une plage de cellules
    Try
        Me.oXL.ActiveSheet.Range(sPlage).Locked = bValeur
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then _
            AfficherMsgErreur2(ex, "bVerrouillerPlage.Set")
    End Try
End Set
End Property

Public Property bVerrouillerCellule(ByVal iLigne%, ByVal iCol%) As Boolean

Get
    ' Lire l'état Vérrouillé ou pas d'une plage de cellules
    Try
        Dim sPlage$ = sConvEnPlage(iLigne, iCol)
        bVerrouillerCellule = CBool(Me.oXL.ActiveSheet.Range(sPlage).Locked)
    Catch
    End Try
End Get
Set(ByVal bValeur As Boolean)
    ' Vérrouiller ou pas une plage de cellules
    Try
        Dim sPlage$ = sConvEnPlage(iLigne, iCol)
        Me.oXL.ActiveSheet.Range(sPlage).Locked = bValeur
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then _
            AfficherMsgErreur2(ex, "bVerrouillerCellule.Set")
    End Try
End Set
End Property

#If iOWC = iOWC9 Then

Public Property iScrollH%()
Get
    iScrollH = 0 ' OWC10 : iScrollH = Me.oXL.ActiveWindow.ScrollColumn
End Get
Set(ByVal iValScrollH%)
End Set
End Property
Public Property iScrollV%()
Get
    iScrollV = 0 ' OWC10 : iScrollV = Me.oXL.ActiveWindow.ScrollRow
End Get
Set(ByVal iValScrollV%)
End Set
End Property

Public ReadOnly Property iPositionHPlage%(ByVal sPlage$)
Get
    iPositionHPlage = Me.oXL.ActiveSheet.Range(sPlage).Left
End Get
End Property
Public ReadOnly Property iPositionVPlage%(ByVal sPlage$)
Get
    iPositionVPlage = Me.oXL.ActiveSheet.Range(sPlage).Top
End Get
End Property
Public WriteOnly Property sPositionPlage$()
Set(ByVal sPlage$)
    Me.oXL.ActiveSheet.Scroll(Me.oXL.ActiveSheet.Range(sPlage))
    'SelectionnerPlage(sPlage)
End Set
End Property

Public ReadOnly Property sMinColVisible$(Optional ByVal iMinColVisible% = 1)
Get
    ' Renvoyer la première colonne actuellement visible à l'écran
    ' (pour connaitre la position du défilement horizontal)
    ' Note : s'il y a un volet figé, il faut indiquer 
    '  la première colonne pouvant être masquée dans iMinColVisible
    ' Note : sPlageUtilisee est liée à la feuille active
    sMinColVisible = ""
    Dim iMinCol% = iMinColVisible + 1
    Dim iMaxCol% = Me.iColFinPlage(Me.sPlageUtilisee())
    Dim iPosCol%(iMaxCol)
    Dim sMemNomColonne$ = Me.sConvNumEnLettres(iMinCol - 1)
    Dim iCol%
    Dim iPosRef% = 0
    If Me.bAfficherEntetesLigne Then iPosRef += 24
    iPosCol(iMinCol - 1) = Me.iPositionHPlage( _
        sMemNomColonne & ":" & sMemNomColonne)
    For iCol = iMinCol To iMaxCol
        Dim sNomColonne$ = Me.sConvNumEnLettres(iCol)
        iPosCol(iCol) = Me.iPositionHPlage(sNomColonne & ":" & sNomColonne)
        Dim k% = iPosCol(iCol)
        Dim j% = iPosCol(iCol - 1)
        If iPosCol(iCol) > iPosCol(iCol - 1) And _
           iPosCol(iCol - 1) > iPosRef Then
            sMinColVisible = sMemNomColonne
            Exit For
        ElseIf iCol = iMaxCol Then
            sMinColVisible = sNomColonne
            Exit For
        End If
        sMemNomColonne = sNomColonne
    Next iCol
End Get
End Property

Public ReadOnly Property sMinLigneVisible$(Optional ByVal iMinLigneVisible% = 1)
Get
    ' Renvoyer la première ligne actuellement visible à l'écran
    ' (pour connaitre la position du défilement vertical)
    ' Note : s'il y a un volet figé, il faut indiquer 
    '  la première ligne pouvant être masquée dans iMinLigneVisible
    ' Note : sPlageUtilisee est liée à la feuille active
    sMinLigneVisible = ""
    Dim iMinLigne% = iMinLigneVisible + 1
    Dim iMaxLigne% = Me.iLigneFinPlage(Me.sPlageUtilisee())
    Dim iPosLigne%(iMaxLigne)
    Dim sMemNomLigne$ = CStr(iMinLigne - 1)
    Dim iLigne%
    Dim iPosRef% = 0
    If Me.bAfficherEntetesColonne Then iPosRef += 16
    If Me.bAfficherBarreOutils Then iPosRef += 22
    iPosLigne(iMinLigne - 1) = Me.iPositionVPlage( _
        "L" & iMinLigne - 1)
    For iLigne = iMinLigne To iMaxLigne
        Dim sNomLigne$ = CStr(iLigne)
        iPosLigne(iLigne) = Me.iPositionVPlage("L" & sNomLigne)
        Dim k% = iPosLigne(iLigne)
        Dim j% = iPosLigne(iLigne - 1)
        If iPosLigne(iLigne) > iPosLigne(iLigne - 1) And _
           iPosLigne(iLigne - 1) > iPosRef Then
            sMinLigneVisible = sMemNomLigne
            Exit For
        ElseIf iLigne = iMaxLigne Then
            sMinLigneVisible = sNomLigne
            Exit For
        End If
LigneSuivante:
        sMemNomLigne = sNomLigne
    Next iLigne
End Get
End Property

#End If

#If iOWC >= iOWC10 Then

Public Property iScrollH%()
Get
    iScrollH = Me.oXL.ActiveWindow.ScrollColumn
End Get
Set(ByVal iValScrollH%)
    If Me.oXL.ActiveWindow.ScrollColumn <> iValScrollH Then _
        Me.oXL.ActiveWindow.ScrollColumn = iValScrollH
End Set
End Property
Public Property iScrollV%()
Get
    iScrollV = Me.oXL.ActiveWindow.ScrollRow
End Get
Set(ByVal iValScrollV%)
    If Me.oXL.ActiveWindow.ScrollRow <> iValScrollV Then _
        Me.oXL.ActiveWindow.ScrollRow = iValScrollV
End Set
End Property

' Ces fonctions ne marchent plus en OWC 10 et 11 :
Public ReadOnly Property iPositionHPlage%(ByVal sPlage$)
Get
    iPositionHPlage = 0 'Me.oXL.ActiveSheet.Range(sPlage).Left
End Get
End Property
Public ReadOnly Property iPositionVPlage%(ByVal sPlage$)
Get
    iPositionVPlage = 0 'Me.oXL.ActiveSheet.Range(sPlage).Top
End Get
End Property
Public WriteOnly Property sPositionPlage$()
Set(ByVal sPlage$)
    SelectionnerPlage(sPlage) ' Paliatif OWC10 et 11
    ' OWC9 : Me.oXL.ActiveSheet.Scroll(Me.oXL.ActiveSheet.Range(sPlage))
End Set
End Property

Public ReadOnly Property sMinColVisible$(Optional ByVal iMinColVisible% = 1)
Get
    ' Renvoyer la première colonne actuellement visible à l'écran
    ' (pour connaitre la position du défilement horizontal)
    sMinColVisible = ""
End Get
End Property

Public ReadOnly Property sMinLigneVisible$(Optional ByVal iMinLigneVisible% = 1)
Get
    ' Renvoyer la première ligne actuellement visible à l'écran
    ' (pour connaitre la position du défilement vertical)
    sMinLigneVisible = ""
End Get
End Property

#End If

#End Region

#Region "Initialisations"

Private Sub Initialisation()

    ' Valeurs par défaut
    ' Procédure appelée depuis le New()
    bAfficherBarreTitre = False
    'bAfficherOngletFeuille = False ' Trop tot !
    bCollageInterdit = True
    bModifierStructureInterdit = True
    bActivationSimpleClic = glb.bActivationSimpleClic

End Sub

Public Function bInitFeuilleXL(ByVal sCheminFichierHTML$, _
    Optional ByVal bProteger As Boolean = True, _
    Optional ByVal bActiver As Boolean = True) As Boolean

    If Not bFichierExiste(sCheminFichierHTML) Then
        MsgBox("bInitFeuilleXL : Impossible de trouver le fichier :" & vbLf & _
            sCheminFichierHTML, MsgBoxStyle.Critical, sTitreMsg)
        Exit Function
    End If

    CommencerModif()

    Try
        Me.oXL.HTMLURL = "file://" & sCheminFichierHTML
        bInitFeuilleXL = True
    Catch Err As Exception
        AfficherMsgErreur2(Err, "bInitFeuilleXL")
    End Try

    ' True : Activer le verrouillage de la feuille
    ' False : Permettre les modifications de la feuille (filtrage)
    'Me.bProtegerFeuille = bProteger
    If bActiver Then FinirModif(bProteger)

    ' En OWC10, il faut faire ce choix ici, et non dans Initialisation()
    ' (le tableur doit être affiché au préalable)
    bAfficherOngletFeuille = False

End Function

Public Sub CommencerModif(Optional ByVal bProtectionSeule As Boolean = False)
    If Not bProtectionSeule Then
        Me.oXL.ScreenUpdating = False ' Commencer par désactiver le rafraichissement
        Me.oXL.EnableUndo = False
        Me.oXL.EnableEvents = False
        'Me.oXL.ScreenUpdating = False
        Me.bActiverCalculAuto = False
    End If
    ' Permettre les modifications de la feuille
    Me.bProtegerFeuille = False
End Sub

Public Sub FinirModif(Optional ByVal bProteger As Boolean = True)
    ' Si on veut verrouiller certaines cellules, on est obligé de proteger la feuille 
    '  mais on ne peut plus trier alors !
    Me.bProtegerFeuille = bProteger
    Me.oXL.EnableUndo = True
    Me.bActiverCalculAuto = True
    Me.oXL.EnableEvents = True
    Me.oXL.ScreenUpdating = True ' Réafficher en dernier seulement
End Sub

#End Region

#Region "Lecture et écriture dans une cellule"

Public Sub DefinirPlageVisible(ByVal sPlage$, _
    Optional ByVal iLigneVoletFige% = 2, _
    Optional ByVal iColVoletFige% = 2)

    ' Attention, cela ne suffit pas à délimiter un export Excel

    Try
        ' Attention : à faire AVANT FinirModif()
        '  (en fait avant de proteger la feuille, sinon on le fait ici)
        ' De plus le tableur doit être visible actuellement
        Dim bProtege As Boolean = Me.bProtegerFeuille()
        If bProtege Then Me.bProtegerFeuille = False

        ' Attention lorsqu'il y a un volet figé sur la première ligne
        '  à ne pas définir la plage visible à une ligne seulement,
        '  car cela le désactiverait. Par exemple si une liste d'article
        '  ne contient aucun article, afficher quand même 1 ligne
        '  en plus de l'entête, soit 2 lignes en tout et non 1 seule
        Dim iLigneFinPlage% = Me.iLigneFinPlage(sPlage)
        Dim iColFinPlage% = Me.iColFinPlage(sPlage)
        If iLigneFinPlage < iLigneVoletFige Or _
           iColFinPlage < iColVoletFige Then
            If iLigneFinPlage < iLigneVoletFige Then _
                iLigneFinPlage = iLigneVoletFige
            If iColFinPlage < iColVoletFige Then _
                iColFinPlage = iColVoletFige
            Dim sDebPlage$ = (sPlage.Split(":"c))(0)
            sPlage = sDebPlage & ":" & _
                sConvNumEnLettres(iColFinPlage) & iLigneFinPlage
        End If

        Me.oXL.ViewableRange = sPlage
        If bProtege Then Me.bProtegerFeuille = True

    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then _
            AfficherMsgErreur2(ex, "DefinirPlageVisible")
    End Try

End Sub

Public Sub EffacerPlage(ByVal sPlage$)

    ' La feuille ne doit pas être protégée, sinon on la libère ici
    Dim bProtege As Boolean = Me.bProtegerFeuille()
    If bProtege Then Me.bProtegerFeuille = False
    If sPlage.Length = 0 Then

        ' Effacer tout : contenu et format, 
        '  y-compris les volets figés le cas échéant
        ' Ne fonctionne pas : plantage complet !
        ' Solution possible : charger un autre modèle, 
        '  même vide si nécessaire !
        'Me.oXL.ActiveSheet.Range(sPlage).DeleteRows()
        'Me.oXL.ActiveSheet.Range(sPlage).DeleteColumns()
        'Me.oXL.HTMLURL = ""

        Me.oXL.ActiveSheet.Cells.Clear()
        '.ClearContents() ' Effacer le contenu 
        '.Clear()         ' Effacer tout : contenu et format

        ' Petit bug : le controle ne s'efface pas bien ! refresh ne suffit pas !
        'Me.oXL.Refresh()
        'Me.Refresh()

        ' Bon, c'est un peu du bricolage tout ça !
        'Me.oXL.DisplayHorizontalScrollBar = False
        'Me.oXL.DisplayHorizontalScrollBar = True
        bAfficherBarreDefilH = Not bAfficherBarreDefilH
        bAfficherBarreDefilH = Not bAfficherBarreDefilH

    Else
        Me.oXL.ActiveSheet.Range(sPlage).Clear() ' ClearContents()
    End If

    ' Rétablir la protection
    If bProtege Then Me.bProtegerFeuille = True

End Sub

Public Sub EffacerContenuPlage(ByVal sPlage$)

    ' Effacer le contenu, mais pas le format de présentation

    ' Bug : en OWC11, ClearContents() prend parfois 1 seconde pile !
    ' Désactiver cette fct ? Pas besoin, il y a une solution : .Cells.Value = ""
    'If iOWC = iOWC11 Then Exit Sub
    ' Même bug avec ActiveSheet.Range(sPlage).ParseText
    '  solution : il faut écrire au moins 2 lignes

    ' La feuille ne doit pas être protégée, sinon on la libère ici
    Dim bProtege As Boolean = Me.bProtegerFeuille()
    If bProtege Then Me.bProtegerFeuille = False
    If sPlage.Length = 0 Then
        If iOWC = iOWC11 Then
            Me.oXL.ActiveSheet.Cells.Value = ""
        Else
            Me.oXL.ActiveSheet.Cells.ClearContents()
        End If
    Else
        If iOWC = iOWC11 Then
            ' 12/05/2009 on pourrait copier le format et les formules ?
            '  mais seulement via copy/paste : pas très rapide ?
            '  non : on ne peut coller que la totalité
            '  mais il y a une meilleure solution :
            Me.oXL.ActiveSheet.Range(sPlage).Cells.Value = ""
            'Me.oXL.ActiveSheet.Range(sPlage).Copy()
            'Me.oXL.ActiveSheet.Range(sPlage).Clear() ' OK
            'Me.oXL.ActiveSheet.Range(sPlage).Paste() ' Inutile
            ' Bug : en OWC11, ClearContents prend parfois 1 seconde pile !
            '  au lieu de qq millisec. (pareil pour Cells(,).ClearContents()
            'Me.oXL.ActiveSheet.Range(sPlage).ClearContents() 
        Else
            Me.oXL.ActiveSheet.Range(sPlage).ClearContents()
        End If
    End If
    ' Rétablir la protection
    If bProtege Then Me.bProtegerFeuille = True

End Sub

Public Sub SupprimerLignes(ByVal sPlage$, Optional ByVal bEffacer As Boolean = True)

    If bEffacer Then
        ' Ok, cela suffit à effacer le contenu précédent
        Me.oXL.ActiveSheet.Range(sPlage).Rows.Clear() ' EffacerLignes
        Exit Sub
    End If

    ' Fonctionne en OWC10 par exemple avec "2:2" pour supprimer la ligne n°2
    Me.oXL.ActiveSheet.Range(sPlage).Rows.Delete()
    'Me.oXL.ActiveSheet.Range(sPlage).Rows.DeleteRows()

End Sub

Private Function bPlageInvalide(ByVal iLigne%, ByVal iCol%) As Boolean
    If iCol < 1 Or iLigne < 1 Then bPlageInvalide = True
End Function

Public Sub EcrireCellule(ByVal iLigne%, ByVal iCol%, ByVal sVal$, _
    Optional ByVal bReel As Boolean = True, _
    Optional ByVal bRisqueErr As Boolean = False)
    If bPlageInvalide(iLigne, iCol) Then Exit Sub
    If IsNothing(sVal) Then sVal = ""
    ' Vrai par défaut, pour compatibilité du code
    If bReel Then sVal = sValeurPtDecimal(sVal)
    If bRisqueErr Then
        Try
            ' L'écriture de texte libre peut provoquer des erreurs inattendues
            Me.oXL.Cells(iLigne, iCol) = sVal
        Catch
        ' Erreur 0xE0040021 : .CommencerModif a été oublié
        'Catch ex As Exception
            'If Me.m_bAfficherMsgErr Then AfficherMsgErreur2(ex, "EcrireCellule")
        End Try
    Else
        Me.oXL.Cells(iLigne, iCol) = sVal
        'Const sDelimiteurCol$ = vbTab
        'Dim sPlage$ = sConvEnPlage(iLigne, iCol)
        'Me.oXL.ActiveSheet.Range(sPlage).ParseText(sVal, sDelimiteurCol)
    End If
End Sub

Public Sub EcrireCellule(ByVal iLigne%, ByVal iCol%, ByVal oVal As Object)
    ' Ecrire une cellule en mode brut, par exemple une date
    If bPlageInvalide(iLigne, iCol) Then Exit Sub
    Me.oXL.Cells(iLigne, iCol) = oVal
End Sub

Public Sub EcrireCellules(ByVal sPlage$, ByVal sbContenu As System.Text.StringBuilder, _
    Optional ByVal sDelimiteurCol$ = vbTab)
    ' Ecrire directement une plage de cellules via un tableau délimité 
    '  par vbTab (par défaut pour les colonnes) et vbLf pour les lignes
    ' (même fonctionnement que la fonction LireEnregistrements, mais avec un tableau
    '  de String à la place de la requête AdoDb sur la base de données)
    ' Sur certains postes (avec par ex. 1 Go de RAM ?), l'affichage cellule par cellule 
    '  est très lente (OWC9) : l'écriture en mode tableau permet de contourner ce bug
    ' Toutes les versions OWC9 ont ce bug, qui est corrigé dans la version 10
    '  mais la version 10 a d'autres bugs : par exemple il faut toujours écrire au
    '  moins 2 lignes sinon l'écriture prend parfois 1 seconde (au lieu de qq msec.)
    '  même bug qu'avec ActiveSheet.Range(sPlage).ClearContents()
    Me.oXL.ActiveSheet.Range(sPlage).ParseText( _
        sbContenu.ToString, sDelimiteurCol)
    ' Worksheets(1) = ActiveSheet si une seule feuille, même bug.
    'Me.oXL.Worksheets(1).Range(sPlage).ParseText( _
    '    sbContenu.ToString, sDelimiteurCol)
End Sub

Private Function sLireCelluleActive$()
    sLireCelluleActive = CStr(Me.oXL.ActiveCell.Value)
    'sLireCelluleActive = Me.oXL.ActiveCell.Text 
    If IsNothing(sLireCelluleActive) Then sLireCelluleActive = ""
End Function

Public Function sLireCellule$(ByVal iLigne%, ByVal iCol%, _
    Optional ByVal bDate As Boolean = False)
    sLireCellule = sLireCellule2(iLigne, iCol, "", bDate:=bDate)
End Function

Public Function sLireCellule2$(ByVal iLigne%, ByVal iCol%, _
    Optional ByVal sValDef$ = "?", _
    Optional ByVal bAutoriserVide As Boolean = False, _
    Optional ByVal bDate As Boolean = False)

    ' Lire une valeur dans une cellule

    ' bAutoriserVide : permettre une cellule vide, sans pour autant appliquer
    '  la valeur par défaut, qui correspond seulement à une valeur erronée

    ' La date est utile pour SS Gear, pas pour OWC

    Try
        Dim oVal As Object = Me.oXL.Cells(iLigne, iCol).Value
        'Dim oVal As Object = Me.oXL.Cells(iLigne, iCol).Text
        'Dim oVal As Object = Me.oXL.Cells(iLigne, iCol).Value2 ' OWC10
        Dim sVal$ = CStr(oVal) ' Tentative de conversion en string
        If String.IsNullOrEmpty(sVal) Then
            If bAutoriserVide Then sVal = "" Else sVal = sValDef
        End If
        sLireCellule2 = sVal
    Catch
        ' Echec de la conversion
        sLireCellule2 = sValDef
    End Try

End Function

Public Function rLireCellule!(ByVal iLigne%, ByVal iCol%, _
    ByVal sValPreced$, ByVal rValDef!)

    ' Lire un réel dans une cellule, et corriger la cellule le cas échéant
    Dim oVal As Object = Me.oXL.Cells(iLigne, iCol).Value
    Dim bRetablir As Boolean = False
    ' S'il n'y a rien dans la cellule, rétablir la valeur précédente
    Dim sVal$ = ""
    If oVal Is Nothing Then bRetablir = True : GoTo Retablir
    Try
        Dim rVal! = CSng(oVal) ' Tentative de conversion en réel
        rLireCellule = rVal : Exit Function ' Ok
    Catch
        ' Echec de la conversion : 2ème essai
        Try
            sVal = CStr(oVal)
            Dim rVal! = rConvStrEnReel(sVal) ' Tentative de conversion en réel
            rLireCellule = rVal : Exit Function ' Ok
        Catch
            ' Echec de la conversion : Rétablir la valeur précédente
            bRetablir = True
        End Try
    End Try

Retablir:
    If bRetablir Then
        rLireCellule = rValDef
        ' La valeur précédente se trouve déjà dans la cellule
        If (Not IsNothing(sVal)) AndAlso sVal = sValPreced Then Exit Function ' OWC10
        EcrireCellule(iLigne, iCol, sValPreced, bReel:=True, bRisqueErr:=True)
    End If

End Function

Public Function sLireFormule$(ByVal iLigne%, ByVal iCol%)

    ' Lire la formule contenue dans une cellule, le cas échéant
    sLireFormule = ""
    Try
        Dim oVal As Object = Me.oXL.Cells(iLigne, iCol).Formula
        Dim sVal$ = CStr(oVal) ' Tentative de conversion en string
        If String.IsNullOrEmpty(sVal) Then Exit Function
        If sVal.Chars(0) <> "=" Then Exit Function
        sLireFormule = sVal
    Catch
        ' Echec de la conversion
    End Try

End Function

Public Sub LireEnregistrements(ByVal sPlage$, ByVal oRqAdoDb As Object, _
    Optional ByVal bGestionSepDecimal As Boolean = True)

    ' Il y a un bug avec OWC : 
    '  Parse ne marche qu'avec le . pour séparateur décimal 
    '  donc s'il y a des nombres réels,
    '  il faut activer la gestion du séparateur décimal
    '  il sera modifié à la volée si et seulement si 
    '  le séparateur en vigueur n'est pas le .
    ' Attention : ce code n'est pas multitache !
    If bGestionSepDecimal Then bChangerSeparateurDecimal()
    Const sDelimiteurCol$ = vbTab
    Me.oXL.ActiveSheet.Range(sPlage).ParseText( _
        oRqAdoDb.GetString(, , sDelimiteurCol), sDelimiteurCol)

    'Dim ls As Object = Me.oXL.LanguageSettings
    'Dim i1% = ls.LanguageID(1) ' Tjrs 1036 en français : de 1 à 5 :
    'Public Enum MsoAppLanguageID
    '    msoLanguageIDExeMode = 4
    '    msoLanguageIDHelp = 3
    '    msoLanguageIDInstall = 1
    '    msoLanguageIDUI = 2
    '    msoLanguageIDUIPrevious = 5
    'End Enum

    ' Le contenu ne dépend pas du séparateur décimal : tjrs .
    'oRqAdoDb.MoveFirst()
    'Dim sContenu$ = oRqAdoDb.GetString(, , sDelimiteurCol)
    'Dim sChemin$ = Application.StartupPath & "\Test.txt"
    'bEcrireFichier(sChemin, sContenu)

    ' Rétablir le séparateur en vigueur avant le changement
    If bGestionSepDecimal Then bChangerSeparateurDecimal(bRetablir:=True)

    'Dim dr As OleDb.OleDbDataReader
    'dr.GetString() ' Ne peut lire qu'une seule colonne à la fois

End Sub

'Public Sub RecopierFormule(ByVal sPlageFormule$)

'    ' Recopier la formule en début de plage jusqu'en fin de plage
'    ' ne fonctionne pas !? dommage !
'    ' Solution : mettre les formules dans la rq source, c'est un peu difficile, mais efficace
'    '  (si on met les formules à l'infini dans le modèle, il gonfle jusqu'à 32 Mo !)
'    Try
'        Me.bProtegerFeuille = False
'        Me.oXL.ActiveSheet.Range(sPlageFormule).Select()
'        Me.oXL.ActiveSheet.Range(sPlageFormule).FillDown()
'        'Me.oXL.Selection.FillDown()
'    Catch ex As Exception
'        If Me.m_bAfficherMsgErr Then AfficherMsgErreur2(ex, "RecopierFormule")
'    End Try

'End Sub

Public Sub EcrireFormule(ByVal iLigne%, ByVal iCol%, ByVal sFormule$)

    ' Ecrire une formule dans une cellule
    Try
        Me.oXL.Cells(iLigne, iCol).Formula = sFormule
    Catch
    End Try

End Sub

#End Region

#Region "Gestion des formats de présentation"

Public Sub HauteurLigne(ByVal sPlage$, ByVal iHauteur%)
    Me.oXL.ActiveSheet.Range(sPlage).RowHeight = iHauteur
End Sub

Public Sub LargeurColonne(ByVal sPlage$, ByVal iLarg%)
    If iOWC >= iOWC10 Then
        Me.oXL.ActiveSheet.Range(sPlage).ColumnWidth = iLarg / 7.5
        Exit Sub
    End If
    Me.oXL.ActiveSheet.Range(sPlage).ColumnWidth = iLarg
End Sub

Public Sub TaillePolice(ByVal sPlage$, ByVal iTaille%)
    ' Les modifications doivent être autorisées : cf. fct CommencerModif()
    If iTaille < 1 Then Exit Sub
    Me.oXL.ActiveSheet.Range(sPlage).Font.Size = iTaille
End Sub

Public Sub FormatNumerique(ByVal iLigne%, ByVal iCol%, ByVal sFormat$)
    Me.oXL.Cells(iLigne, iCol).NumberFormat = sFormat
End Sub

Public Sub FormatNumeriquePlage(ByVal sPlage$, ByVal sFormat$)
    Me.oXL.ActiveSheet.Range(sPlage).NumberFormat = sFormat
End Sub

Public Sub AffichageLigne(ByVal iLigne%, Optional ByVal bMasquer As Boolean = False)
    Me.oXL.ActiveSheet.Rows(iLigne).Hidden = bMasquer
End Sub

Public Sub AffichageColonne(ByVal iCol%, Optional ByVal bMasquer As Boolean = False)
    Me.oXL.ActiveSheet.Columns(iCol).Hidden = bMasquer
End Sub

Public Sub ChangerCouleurFondCellule(ByVal iLigne%, ByVal iCol%, ByVal sCouleur$, _
    Optional ByVal bNePasRetablirGrilleStdr As Boolean = False)

    ' Attention : les constantes Excels xlEdgeLeft et compagnie 
    '  (par exemple .Borders(xlEdgeLeft)) ne sont plus valables pour OWC !!!
    '  et xlNone correspond tout simplement à "" !
    '  ColorIndex ne fonctionne pas avec OWC, mais Color si !
    '  et en automation Excel, c'est l'inverse !
    ' Solution : faire un WinDiff d'un fichier html : on arrive à trouver le code couleur

    Try
        Me.oXL.Cells(iLigne, iCol).Interior.Color = sCouleur

        ' On peut rétablir la grille standard avec ces deux lignes :
        If Not bNePasRetablirGrilleStdr Then
'#If iOWC = iOWC10 Then
'            Me.oXL.Cells(iLigne, iCol).Borders.Weight = LineWeightEnum.owcLineWeightThin
'#ElseIf bOWC9 Then
            Me.oXL.Cells(iLigne, iCol).Borders.Weight = LineWeightEnum.owcLineWeightThin
'#End If
            Me.oXL.Cells(iLigne, iCol).Borders.Color = sCouleurGrisClair
        End If

    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then _
            AfficherMsgErreur2(ex, "ChangerCouleurFondCellule", _
                "Couleur : " & sCouleur)
    End Try

End Sub

Public Sub ChangerCouleurFondCellules(ByVal sPlage$, ByVal sCouleur$)

    Try
        Me.oXL.ActiveSheet.Range(sPlage).Interior.Color = sCouleur
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then _
            AfficherMsgErreur2(ex, "ChangerCouleurFondCellules", _
                "Couleur : " & sCouleur)
    End Try

End Sub

Public Function sLireCouleurFondCellule$(ByVal iLigne%, ByVal iCol%)

    sLireCouleurFondCellule = CStr(Me.oXL.Cells(iLigne, iCol).Interior.Color)

End Function

Public Sub ChangerCouleurBordCellule(ByVal iLigne%, ByVal iCol%, _
    ByVal iBord%, ByVal iEpaisseur%, ByVal sCouleur$)

    ' Changer la couleur et l'épaisseur d'un des bords d'une cellule
    ' n° bord : 0 : Haut, 1 : Bas, 2 : Gauche et 3 : Droite (4 : tous)
    ' Epaisseur : de 0 (owcLineWeightHairline) à 3 (owcLineWeightThick)
    If iBord < 0 Or iBord > 4 Then iBord = 4
    If iEpaisseur < 0 Then iEpaisseur = 0
    If iEpaisseur > 3 Then iEpaisseur = 3

#If iOWC = iOWC9 Then

    If iBord = 4 Then
        Me.oXL.Cells(iLigne, iCol).Borders.Weight = iEpaisseur
        Me.oXL.Cells(iLigne, iCol).Borders.Color = sCouleur
    Else
        Me.oXL.Cells(iLigne, iCol).Borders(iBord).Weight = iEpaisseur
        Me.oXL.Cells(iLigne, iCol).Borders(iBord).Color = sCouleur
    End If

#ElseIf iOWC >= iOWC10 Then

    'OWC10.XlBordersIndex :
    ' xlEdgeBottom = 9
    ' xlEdgeLeft = 7
    ' xlEdgeRight = 10
    ' xlEdgeTop = 8
    ' xlInsideHorizontal = 12
    ' xlInsideVertical = 11

    'OWC10.XlBorderWeight :
    ' xlHairline = 1
    ' xlMedium = -4138
    ' xlThick = 4
    ' xlThin = 2

    If iBord = 4 Then
        Me.oXL.Cells(iLigne, iCol).Borders.Weight = iEpaisseur
        Me.oXL.Cells(iLigne, iCol).Borders.Color = sCouleur
    Else
        Dim iBordOWC10% = 0
        If iBord = 0 Then iBordOWC10 = XlBordersIndex.xlEdgeTop
        If iBord = 1 Then iBordOWC10 = XlBordersIndex.xlEdgeBottom
        If iBord = 2 Then iBordOWC10 = XlBordersIndex.xlEdgeLeft
        If iBord = 3 Then iBordOWC10 = XlBordersIndex.xlEdgeRight
        Dim iEpaisseurOWC10% = 0
        If iEpaisseur = 0 Then iEpaisseurOWC10 = XlBorderWeight.xlHairline
        If iEpaisseur = 1 Then iEpaisseurOWC10 = XlBorderWeight.xlThin
        If iEpaisseur = 2 Then iEpaisseurOWC10 = XlBorderWeight.xlMedium
        If iEpaisseur = 3 Then iEpaisseurOWC10 = XlBorderWeight.xlThick
        Me.oXL.Cells(iLigne, iCol).Borders(iBordOWC10).Weight = iEpaisseurOWC10
        Me.oXL.Cells(iLigne, iCol).Borders(iBordOWC10).Color = sCouleur
    End If

#End If

End Sub

Public Sub ChangerCouleurBordCellules(ByVal sPlage$, _
    ByVal iBord%, ByVal iEpaisseur%, ByVal sCouleur$)

    ' Changer la couleur et l'épaisseur d'un des bords d'une cellule
    ' n° bord : 0 : Haut, 1 : Bas, 2 : Gauche et 3 : Droite (4 : tous)
    ' Epaisseur : de 0 (owcLineWeightHairline) à 3 (owcLineWeightThick)
    If iBord < 0 Or iBord > 4 Then iBord = 4
    If iEpaisseur < 0 Then iEpaisseur = 0
    If iEpaisseur > 3 Then iEpaisseur = 3

#If iOWC = iOWC9 Then

    If iBord = 4 Then
        Me.oXL.ActiveSheet.Range(sPlage).Borders.Weight = iEpaisseur
        Me.oXL.ActiveSheet.Range(sPlage).Borders.Color = sCouleur
    Else
        Me.oXL.ActiveSheet.Range(sPlage).Borders(iBord).Weight = iEpaisseur
        Me.oXL.ActiveSheet.Range(sPlage).Borders(iBord).Color = sCouleur
    End If

#ElseIf iOWC >= iOWC10 Then

    'OWC10.XlBordersIndex :
    ' xlEdgeBottom = 9
    ' xlEdgeLeft = 7
    ' xlEdgeRight = 10
    ' xlEdgeTop = 8
    ' xlInsideHorizontal = 12
    ' xlInsideVertical = 11

    'OWC10.XlBorderWeight :
    ' xlHairline = 1
    ' xlMedium = -4138
    ' xlThick = 4
    ' xlThin = 2

    If iBord = 4 Then
        Me.oXL.ActiveSheet.Range(sPlage).Borders.Weight = iEpaisseur
        Me.oXL.ActiveSheet.Range(sPlage).Borders.Color = sCouleur
    Else
        Dim iBordOWC10% = 0
        If iBord = 0 Then iBordOWC10 = XlBordersIndex.xlEdgeTop
        If iBord = 1 Then iBordOWC10 = XlBordersIndex.xlEdgeBottom
        If iBord = 2 Then iBordOWC10 = XlBordersIndex.xlEdgeLeft
        If iBord = 3 Then iBordOWC10 = XlBordersIndex.xlEdgeRight
        Dim iEpaisseurOWC10% = 0
        If iEpaisseur = 0 Then iEpaisseurOWC10 = XlBorderWeight.xlHairline
        If iEpaisseur = 1 Then iEpaisseurOWC10 = XlBorderWeight.xlThin
        If iEpaisseur = 2 Then iEpaisseurOWC10 = XlBorderWeight.xlMedium
        If iEpaisseur = 3 Then iEpaisseurOWC10 = XlBorderWeight.xlThick
        Me.oXL.ActiveSheet.Range(sPlage).Borders(iBordOWC10).Weight = iEpaisseurOWC10
        Me.oXL.ActiveSheet.Range(sPlage).Borders(iBordOWC10).Color = sCouleur
    End If

#End If

End Sub

Public Sub ChangerCouleurFonteCellule(ByVal iLigne%, ByVal iCol%, ByVal sCouleur$)

    Try
        Me.oXL.Cells(iLigne, iCol).Font.Color = sCouleur
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then AfficherMsgErreur2(ex, _
            "ChangerCouleurFonteCellule", "Couleur : " & sCouleur)
    End Try

End Sub

Public Sub ChangerEpaisseurFonteCellule(ByVal iLigne%, ByVal iCol%, _
    ByVal bGras As Boolean)

    ' Cela fonctionne si la taille de la police est suffisante 
    '  pour afficher le résultat
    Me.oXL.Cells(iLigne, iCol).Font.Bold = IIf(bGras, 1, 0)
    'Me.oXL.Cells(iLigne, iCol).Font.set_Bold(bGras)

End Sub

Public Sub AjusterCellulesAuContenu()

#If iOWC = iOWC9 Then
    Try
        Me.oXL.ActiveSheet.UsedRange.AutoFitRows()
    Catch ex As Exception
        ' On peut obtenir l'erreur HRESULT 0xE0040020 ???
        If Me.m_bAfficherMsgErr Then AfficherMsgErreur2(ex, _
            "AjusterCellulesAuContenu", "AutoFitRows")
    End Try
    Try
        Me.oXL.ActiveSheet.UsedRange.AutoFitColumns()
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then AfficherMsgErreur2(ex, _
            "AjusterCellulesAuContenu", "AutoFitColumns")
    End Try
#Else 'If bOWC10 Then
    'Me.oXL.ActiveSheet.UsedRange.AutoFit() ' Plante
    Dim bProtege As Boolean = Me.bProtegerFeuille()
    If bProtege Then Me.bProtegerFeuille = False
    Try
        Me.oXL.ActiveSheet.UsedRange.Rows.AutoFit()
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then AfficherMsgErreur2(ex, _
            "AjusterCellulesAuContenu", "Rows.AutoFit")
    End Try
    Try
        Me.oXL.ActiveSheet.UsedRange.Columns.AutoFit()
    Catch ex As Exception
        If Me.m_bAfficherMsgErr Then AfficherMsgErreur2(ex, _
            "AjusterCellulesAuContenu", "Columns.AutoFit")
    End Try
    If bProtege Then Me.bProtegerFeuille = True
#End If

End Sub

Public Sub EcrireEnTexte(ByVal iLigne%, ByVal iCol%, ByVal sValeur$)

    ' Ecrire dans une cellule en tant que texte (en forçant le texte), 
    '  ce qui est utile pour les dates (sinon le format de date anglais 
    '  est appliqué de façon intempestive)
    '  et parfois aussi pour les numériques
    If sValeur.Length = 0 Then EcrireCellule(iLigne, iCol, "") : Exit Sub
    EcrireCellule(iLigne, iCol, "'" & sValeur, bReel:=False)
    ' Fixer le format texte
    FormatNumerique(iLigne, iCol, sFormatTexteOWC)

End Sub

#End Region

#Region "Sélection des cellules"

Public Function iLigneEnCours%()
    iLigneEnCours = Me.oXL.ActiveCell.Row()
End Function

Public Function iColEnCours%()
    iColEnCours = Me.oXL.ActiveCell.Column()
End Function

Public Sub SelectionnerCellule(ByVal iLigne%, ByVal iCol%)
    If iLigne < 1 Then iLigne = 1
    If iCol < 1 Then iCol = 1
    Me.oXL.Cells(iLigne, iCol).Select()
End Sub

' Attribut pour éviter que l'IDE s'interrompt en cas d'exception
<System.Diagnostics.DebuggerStepThrough()> _
Public Sub SelectionnerPlage(ByVal sPlage$)
    Try
        Me.oXL.ActiveSheet.Range(sPlage).Select()
    Catch
        ' On ne peut plus sélectionner les colonnes (???), sélectionner tout alors
        ' Erreur : 0xE0040037 3758358583 dans Export Excel parfois
        'SelectionnerCellule(1, 1) : ne marche pas ?
        'Me.oXL.Cells.Select() : provoque aussi l'erreur
        'Me.oXL.ActiveSheet.UsedRange.Select()
        SelectionnerContenu()
    End Try
End Sub

Public Sub SelectionnerContenu()
    Try
        'Me.oXL.ActiveSheet.Cells(1, 1).Select ' Sélectionner tout
        Me.oXL.ActiveSheet.UsedRange.Select()
    Catch 'ex As Exception
        'Debug.WriteLine("!")
    End Try
End Sub

Public Function sPlageUtilisee$()
    sPlageUtilisee = Me.oXL.ActiveSheet.UsedRange.Address.ToString()
    ' En OWC10, on a des $ autour des lettres, par ex.: "$A$1:$J$603"
    If iOWC >= iOWC10 Then sPlageUtilisee = sPlageUtilisee.Replace("$", "")
End Function

Public Function iColPlage%(ByVal sPlage$, Optional ByVal iNumChamp% = 0)

    ' Renvoyer la première colonne d'une plage
    ' Voir aussi : iConvLettresEnNum
    If sPlage.Length = 0 Then Exit Function

    Dim asTab$() = sPlage.Split(":"c)
    Dim sDeb$ = ""
    If iNumChamp > asTab.GetUpperBound(0) Then
        ' Si la plage est par exemple A1 alors C=1 et L=1
        sDeb = asTab(0)
        GoTo Suite
    End If
    sDeb = asTab(iNumChamp)
Suite:
    Dim iValA% = Asc("A") ' 65
    ' Si la plage ne définie que les colonnes, il n'y a qu'un caractère
    If sDeb.Length = 1 Then
        Dim sCol$ = sDeb.Chars(0)
        iColPlage = 1 + Asc(sCol.Chars(0)) - iValA
        Exit Function
    End If
    iColPlage = 1
    'Dim sCar2Deb$ = sDeb.Chars(1)
    'If IsNumeric(sCar2Deb) Then
    If Char.IsNumber(sDeb.Chars(1)) Then
        ' Soit le début de la plage est du type A9 ou A99
        Dim sCol$ = sDeb.Chars(0)
        iColPlage = 1 + Asc(sCol.Chars(0)) - iValA
    Else
        ' Soit le début de la plage est du type AA9 ou AA99
        Dim sCol$ = sDeb.Substring(0, 2)
        iColPlage = 26 * (1 + Asc(sCol.Chars(0)) - iValA) + 1 + Asc(sCol.Chars(1)) - iValA
    End If

End Function

Public Function iColFinPlage%(ByVal sPlage$)

    ' Renvoyer la dernière colonne d'une plage
    iColFinPlage = iColPlage(sPlage, iNumChamp:=1)

End Function

Public Function iLignePlage%(ByVal sPlage$, Optional ByVal iNumChamp% = 0)

    ' Renvoyer la première ligne d'une plage
    If sPlage.Length = 0 Then Exit Function

    Dim asTab$() = sPlage.Split(":"c)
    Dim sDeb$ = ""
    If iNumChamp > asTab.GetUpperBound(0) Then
        ' Si la plage est par exemple A1 alors C=1 et L=1
        sDeb = asTab(0)
        GoTo Suite
    End If
    sDeb = asTab(iNumChamp)
    ' Si la plage ne définie que les colonnes, il n'y a qu'un caractère
    If sDeb.Length = 1 Then
        If iNumChamp = 0 Then
            iLignePlage = 1 '  La première ligne est donc 1
        ElseIf iNumChamp = 1 Then
            iLignePlage = 65535 ' Renvoyer la dernière ligne dans ce cas
        End If
        Exit Function
    End If
Suite:
    iLignePlage = 1
    'Dim sCar2Deb$ = sDeb.Chars(1)
    'If IsNumeric(sCar2Deb) Then
    If Char.IsNumber(sDeb.Chars(1)) Then
        ' Soit le début de la plage est du type A9 ou A99
        Dim sLigne$ = sDeb.Substring(1)
        iLignePlage = CInt(sLigne)
    Else
        ' Soit le début de la plage est du type AA9 ou AA99
        Dim sLigne$ = sDeb.Substring(2)
        iLignePlage = CInt(sLigne)
    End If

End Function

Public Function iLigneFinPlage%(ByVal sPlage$)

    ' Renvoyer la dernière ligne d'une plage
    iLigneFinPlage = iLignePlage(sPlage, iNumChamp:=1)

End Function

Public Function iConvLettresEnNum%(ByVal sLettres$)

    ' Convertir par exemple A en 1 ou bien AA en 27
    Dim iValA% = Asc("A") ' 65
    If sLettres.Length = 0 Then
        Exit Function
    ElseIf sLettres.Length = 1 Then
        ' Une lettre : entre 1 et 26
        iConvLettresEnNum = 1 + Asc(sLettres.Chars(0)) - iValA
    ElseIf sLettres.Length = 2 Then
        ' Deux lettres : à partir de 27
        iConvLettresEnNum = 26 * (1 + Asc(sLettres.Chars(0)) - iValA) + _
            1 + Asc(sLettres.Chars(1)) - iValA
    Else
        ' Possible ?
        If bDebug Then Stop
    End If

End Function

Public Function sConvNumEnLettres$(ByVal iCol%)

    Dim iValA% = Asc("A") ' 65
    If iCol <= 26 Then
        sConvNumEnLettres = Chr(iValA + iCol - 1)
    Else
        Dim iMult26% = iCol \ 26 ' CInt(iCol / 26)
        Dim iReste% = iCol Mod 26 ' iCol - iMult26 * 26
        sConvNumEnLettres = Chr(iValA + iMult26 - 1) & Chr(iValA + iReste - 1)
    End If

End Function

Public Function sConvEnPlage$(ByVal iLigne%, ByVal iCol%)
    Dim sPlage$ = sConvNumEnLettres(iCol) & iLigne
    sConvEnPlage = sPlage & ":" & sPlage
End Function

Public Function bPlusieursLignesSelectionnees() As Boolean

    If Me.oXL.Selection.Rows.Count > 1 Then bPlusieursLignesSelectionnees = True

End Function

Public Function iPremiereLigneSelectionnee%()

    If Not bPlusieursLignesSelectionnees() Then Exit Function

    ' Recherche du n° de la première ligne sélectionnée
    Dim sPlage$ = Me.sPlageSelectionnee()
    Dim asTab$() = sPlage.Split(":"c)
    Dim sDeb$ = asTab(0)
    iPremiereLigneSelectionnee = 1
    'Dim sCar2Deb$ = sDeb.Chars(1)
    'If IsNumeric(sCar2Deb) Then
    If Char.IsNumber(sDeb.Chars(1)) Then
        ' Soit le début de la plage est du type A9 ou A99
        Dim sLigne$ = sDeb.Substring(1)
        iPremiereLigneSelectionnee = CInt(sLigne)
    Else
        ' Soit le début de la plage est du type AA9 ou AA99
        Dim sLigne$ = sDeb.Substring(2)
        iPremiereLigneSelectionnee = CInt(sLigne)
    End If

End Function

Public Function iDerniereLigneSelectionnee%()
    iDerniereLigneSelectionnee = iPremiereLigneSelectionnee() + _
        Me.oXL.Selection.Rows.Count - 1
End Function

Public Function sPlageSelectionnee$()
    sPlageSelectionnee = Me.oXL.Selection.Address
    ' En OWC10, on a des $ autour des lettres, par ex.: "$A$1:$J$603"
    If iOWC >= iOWC10 Then sPlageSelectionnee = sPlageSelectionnee.Replace("$", "")
End Function

Public Function bChercher(ByVal sPlage$, ByVal sValeur$) As Boolean

    Try
        Me.oXL.ActiveSheet.Range(sPlage).Find(sValeur).Select()
#If iOWC = iOWC9 Then
        Me.oXL.ActiveSheet.Scroll(Me.oXL.ActiveSheet.Range(sPlage).Find(sValeur))
#End If
#If iOWC >= iOWC10 Then
        Me.oXL.ActiveSheet.Range(sPlage).Find(sValeur).Select()
#End If
        bChercher = True
    Catch
    End Try

End Function

#End Region

#Region "Gestion des évènements OWC9"

#If iOWC = iOWC9 Then

Private Function sValEvInfo$(ByVal eventInfo As OWC.SpreadsheetEventInfo)

    ' Lire le contenu d'une cellule dans l'argument de l'événement

    Try
        ' Il faut trapper l'erreur lorsque la cellule est vide
        If IsNothing(eventInfo.Range.Value) Then
            sValEvInfo = ""
        Else
            sValEvInfo = eventInfo.Range.Value.ToString()
        End If
    Catch
        sValEvInfo = ""
    End Try

End Function

Private Sub oXL_ClickEvent(ByVal sender As Object, _
    ByVal e As AxOWC.IWebCalcEventSink_MouseUpEvent) _
    Handles oXL.MouseUpEvent

    ' Pareil : Si on déplace la souris, on sélectionne une plage : pas jolie
    'IWebCalcEventSink_ClickEvent : ClickEvent
    'IWebCalcEventSink_SelectionChangeEvent : SelectionChange
    'IWebCalcEventSink_MouseUpEvent : MouseUpEvent

    Dim iLigne% = e.eventInfo.Range.Row
    Dim iCol% = e.eventInfo.Range.Column
    Dim sVal$ = sValEvInfo(e.eventInfo)

    ' Si activation simple clic, on envoie aussi l'ev. clic après le dbl
    If Me.m_bActivationSimpleClic Then _
        RaiseEvent EvCelluleDblClic(iCol, iLigne, sVal)
    RaiseEvent EvCelluleClic(iCol, iLigne, sVal)

End Sub

Private Sub oXL_DblClick(ByVal sender As Object, _
    ByVal e As AxOWC.IWebCalcEventSink_DblClickEvent) Handles oXL.DblClick

    ' Transfert de l'event dblclic sur cellule

    Dim iLigne% = e.eventInfo.Range.Row
    Dim iCol% = e.eventInfo.Range.Column
    Dim sVal$ = sValEvInfo(e.eventInfo)
    RaiseEvent EvCelluleDblClic(iCol, iLigne, sVal)
    Me.m_dDateDblClic = Now

End Sub

Public Sub AnnulerEdition()
    ' Annuler une édition suite à un double-clic, 
    '  car le double-clic a géré une autre action que l'édition de la cellule
    Me.m_dDateDblClic = Now
End Sub

Private Sub oXL_StartEdit(ByVal sender As Object, _
    ByVal e As AxOWC.IWebCalcEventSink_StartEditEvent) Handles oXL.StartEdit

    ' Cancel StartEdit = Lecture seule
    If Me.m_bLectureSeule Then GoTo Annuler

    ' On ne récupère pas la fin de l'édition dans ce cas, mieux vaut l'annuler
    If bPlusieursLignesSelectionnees() Then GoTo Annuler

    ' S'il y a eu un doucle-clic il y a moins d'une seconde, on annule le mode édition
    If DateDiff(DateInterval.Second, Me.m_dDateDblClic, Now()) < 1 Then _
        GoTo Annuler

    Me.m_bEdition = True
    Me.m_iLigneEdition = e.eventInfo.Range.Row
    Me.m_iColEdtion = e.eventInfo.Range.Column
    Me.m_sValEditionOrig = sValEvInfo(e.eventInfo)
    ' Voir OWC10 pour la gestion de l'édition avec une formule : Me.m_sFormuleEditionOrig
    ' (entre commentaire : pas activé de toutes façons)
    Exit Sub

Annuler:
    e.eventInfo.ReturnValue = False

End Sub

Private Sub oXL_SelectionChange(ByVal sender As Object, _
    ByVal e As AxOWC.IWebCalcEventSink_SelectionChangeEvent) _
    Handles oXL.SelectionChange

    'Debug.WriteLine("oXL_SelectionChange : " & _
    '    Now() & ", Ed : " & Me.m_bEdition)

EvSelCh:
    If Not Me.m_bEdition Then
        ' Evénement sélection d'une autre cellule, y-compris au clavier
        Dim iLigne% = e.eventInfo.Range.Row
        Dim iCol% = e.eventInfo.Range.Column
        Dim sVal$ = sValEvInfo(e.eventInfo)
        RaiseEvent EvSelectionChange(iCol, iLigne, sVal)
        Exit Sub
    End If

    ' Evénement modification du contenu d'une cellule : 
    '  EndEdit ne marche pas à la première édition ! (pb de focus ?)
    '  comme EndEdit ne marche pas tjrs, on utilise le fait
    '  que si une édition est en cours et que la sélection change
    '  alors il s'agit de la fin du mode édition
    ' Comme la ligne et la colonne sont celles de destination et non d'origine,
    '  on la sauvegarde au préalable, de même pour la valeur
    ' Note : ne fonctionne pas sur la dernière ligne avec entrée, 
    '  il faut faire flèche D ou G
    Me.m_bEdition = False

    RaiseEvent EvCelluleChange(Me.m_iColEdtion, Me.m_iLigneEdition, _
        Me.m_sValEditionOrig)

    GoTo EvSelCh ' 20/05/2008 Envoyer aussi l'év. Sel.Ch. dans ce cas

End Sub

Private Sub oXL_KeyPressEvent(ByVal sender As Object, _
    ByVal e As AxOWC.IWebCalcEventSink_KeyPressEvent) _
    Handles oXL.KeyPressEvent

    ' KeyPressEvent : se produit qd on presse une touche dans une cellule, 
    '  mais pas pour les fleches de direction ! voir SelectionChange pour cela

    Dim iLigne% = e.eventInfo.Range.Row
    Dim iCol% = e.eventInfo.Range.Column
    Dim sVal$ = sValEvInfo(e.eventInfo)
    RaiseEvent EvCelluleTouchePress(iCol, iLigne, sVal)

End Sub

'Private Sub oXL_ViewChange(ByVal sender As Object, _
'    ByVal e As AxOWC.IWebCalcEventSink_ViewChangeEvent) Handles oXL.ViewChange
'    Debug.WriteLine("ViewChange")
'End Sub

Private Sub oXL_BeforeCommand(ByVal sender As Object, _
    ByVal e As AxOWC.IWebCalcEventSink_BeforeCommandEvent) _
    Handles oXL.BeforeCommand

    ' Evénement avant une opération de l'utilisateur via la barre d'outil
    Dim cmd As OWC.SheetCommandEnum = e.eventInfo.Command

    'Debug.WriteLine("oXL_BeforeCommand : " & _
    '    Now() & ", cmd : " & cmd)

    If Me.m_bCollageInterdit And cmd = OWC.SheetCommandEnum.ssPaste Then
        ' Annuler le collage dans le tableur
        e.eventInfo.ReturnValue = False
        MsgBox("Le collage n'est pas autorisé dans ce tableur", _
            MsgBoxStyle.Exclamation, sTitreMsg)
    End If
    If Me.m_bModifierStructureInterdit And _
        (cmd = OWC.SheetCommandEnum.ssInsertColumns Or _
         cmd = OWC.SheetCommandEnum.ssInsertRows Or _
         cmd = OWC.SheetCommandEnum.ssDeleteColumns Or _
         cmd = OWC.SheetCommandEnum.ssDeleteRows) Then
        ' Annuler l'opération dans le tableur
        e.eventInfo.ReturnValue = False
        MsgBox("La modification de structure n'est pas autorisée dans ce tableur", _
            MsgBoxStyle.Exclamation, sTitreMsg)
    End If

    ' Si on efface le contenu de la cellule, alors indiquer qu'on passe
    '  en mode édition pour bien recevoir l'événement
    If cmd = OWC.SheetCommandEnum.ssClear Then 
        Me.m_bEdition = True
        Me.m_iLigneEdition = Me.oXL.ActiveCell.Row ' 19/05/2008
        Me.m_iColEdtion = Me.oXL.ActiveCell.Column
        Me.m_sValEditionOrig = sLireCelluleActive()
    End if

End Sub

#End If

#End Region

#Region "Gestion des évènements OWC10"

#If iOWC >= iOWC10 Then

Private Sub oXL_MouseDownEvent(ByVal sender As Object, _
    ByVal e As ISpreadsheetEventSink_MouseDownEvent) Handles oXL.MouseDownEvent
    ' Ici on recoit aussi le bouton 2 droit, mais impossible de désactiver 
    '  le menu popup ?
    'Debug.WriteLine("Button : " & e.button)
    'If e.button = 2 Then
    '    Me.oXL.EnableEvents = False
    'Else
    '    Me.oXL.EnableEvents = True
    'End If
End Sub

Private Sub oXL_MouseUpEvent(ByVal sender As Object, _
    ByVal e As ISpreadsheetEventSink_MouseUpEvent) Handles oXL.MouseUpEvent

    Dim iLigne% = Me.oXL.ActiveCell.Row
    Dim iCol% = Me.oXL.ActiveCell.Column
    Dim sVal$ = sLireCelluleActive()
    If Me.m_bActivationSimpleClic Then _
        RaiseEvent EvCelluleDblClic(iCol, iLigne, sVal)
    ' On ne recoit jamais le bouton 2 droit à cause du menu popup, cf. MouseDownEvent
    'Debug.WriteLine("Button : " & e.button)
    RaiseEvent EvCelluleClic(iCol, iLigne, sVal)

End Sub

Private Sub oXL_DblClick(ByVal sender As Object, _
    ByVal e As System.EventArgs) Handles oXL.DblClick

    ' Transfert de l'event dblclic sur cellule
    Dim iLigne% = Me.oXL.ActiveCell.Row
    Dim iCol% = Me.oXL.ActiveCell.Column
    Dim sVal$ = sLireCelluleActive()
    RaiseEvent EvCelluleDblClic(iCol, iLigne, sVal)
    Me.m_dDateDblClic = Now

End Sub

Public Sub AnnulerEdition()
    ' Annuler une édition suite à un double-clic, 
    '  car le double-clic a géré une autre action que l'édition de la cellule
    Me.m_dDateDblClic = Now
End Sub

Private Sub oXL_StartEdit(ByVal sender As Object, ByVal e As  _
    ISpreadsheetEventSink_StartEditEvent) Handles oXL.StartEdit

    ' Lecture seule -> Cancel StartEdit
    If Me.m_bLectureSeule Then GoTo Annuler

    ' On ne récupère pas la fin de l'édition dans ce cas, mieux vaut l'annuler
    If bPlusieursLignesSelectionnees() Then GoTo Annuler

    ' S'il y a eu un doucle-clic il y a moins d'une seconde, on annule le mode édition
    If DateDiff(DateInterval.Second, Me.m_dDateDblClic, Now()) < 1 Then _
        GoTo Annuler

    Me.m_bEdition = True
    Me.m_iLigneEdition = Me.oXL.ActiveCell.Row
    Me.m_iColEdtion = Me.oXL.ActiveCell.Column
    Me.m_sValEditionOrig = sLireCelluleActive()
    'Me.m_sFormuleEditionOrig = sLireFormule(Me.m_iLigneEdition, Me.m_iColEdtion)
    'If Me.m_sFormuleEditionOrig.Length > 0 Then
    '    ' Si on édite une formule, enlever la formule, et la rétablir après
    '    EcrireFormule(Me.m_iLigneEdition, Me.m_iColEdtion, "")
    '    ' Ecrire la valeur en littéral cette fois
    '    EcrireCellule(Me.m_iLigneEdition, Me.m_iColEdtion, Me.m_sValEditionOrig)
    'End If
    Exit Sub

Annuler:
    e.cancel.Value = True ' e.eventInfo.ReturnValue = False

End Sub

Private Sub oXL_SelectionChange(ByVal sender As Object, _
    ByVal e As System.EventArgs) Handles oXL.SelectionChange

EvSelCh:
    If Not Me.m_bEdition Then
        ' Evénement sélection d'une autre cellule, y-compris au clavier
        Dim iLigne% = Me.oXL.ActiveCell.Row
        Dim iCol% = Me.oXL.ActiveCell.Column
        Dim sVal$ = sLireCelluleActive()
        RaiseEvent EvSelectionChange(iCol, iLigne, sVal)
        Exit Sub
    End If

    ' Evénement modification du contenu d'une cellule : 
    '  EndEdit ne marche pas à la première édition ! (pb de focus ?)
    '  comme EndEdit ne marche pas tjrs, on utilise le fait
    '  que si une édition est en cours et que la sélection change
    '  alors il s'agit de la fin du mode édition
    ' Comme la ligne et la colonne sont celles de destination et non d'origine,
    '  on la sauvegarde au préalable, de même pour la valeur
    ' Note : ne fonctionne pas sur la dernière ligne avec entrée, 
    '  il faut faire flèche D ou G
    Me.m_bEdition = False

    RaiseEvent EvCelluleChange(Me.m_iColEdtion, Me.m_iLigneEdition, _
        Me.m_sValEditionOrig)

    GoTo EvSelCh ' 20/05/2008 Envoyer aussi l'év. Sel.Ch. dans ce cas

End Sub

Private Sub oXL_KeyPressEvent(ByVal sender As Object, _
    ByVal e As ISpreadsheetEventSink_KeyPressEvent) _
    Handles oXL.KeyPressEvent

    ' KeyPressEvent : se produit qd on presse une touche dans une cellule, 
    '  mais pas pour les fleches de direction ! voir SelectionChange pour cela

    Dim iLigne% = Me.oXL.ActiveCell.Row
    Dim iCol% = Me.oXL.ActiveCell.Column
    Dim sVal$ = sLireCelluleActive()
    RaiseEvent EvCelluleTouchePress(iCol, iLigne, sVal)

End Sub

Private Sub oXL_CommandBeforeExecute(ByVal sender As Object, _
    ByVal e As ISpreadsheetEventSink_CommandBeforeExecuteEvent) _
    Handles oXL.CommandBeforeExecute

    ' Evénement avant une opération de l'utilisateur via le menu contextuel

    Dim iCmd% = CInt(e.command)

    'Debug.WriteLine("oXL_CommandBeforeExecute : " & _
    '    Now() & ", cmd : " & iCmd)

    'Const iCmdCopier% = 1002
    Const iCmdColler% = 1003
    Const iCmdEffacerCellule% = 10002
    Const iCmdSupprLigne% = 10006
    Const iCmdSupprCol% = 10007
    Const iCmdInsertLigne% = 10008
    Const iCmdInsertCol% = 10009
    If Me.m_bCollageInterdit And iCmd = iCmdColler Then
        ' Annuler le collage dans le tableur
        e.cancel.Value = True
        MsgBox("Le collage n'est pas autorisé dans ce tableur", _
            MsgBoxStyle.Exclamation, sTitreMsg)
    End If
    If Me.m_bModifierStructureInterdit And _
        (iCmd = iCmdSupprLigne Or _
         iCmd = iCmdSupprCol Or _
         iCmd = iCmdInsertLigne Or _
         iCmd = iCmdInsertCol) Then
        ' Annuler l'opération dans le tableur
        e.cancel.Value = True
        MsgBox("La modification de structure n'est pas autorisée dans ce tableur", _
            MsgBoxStyle.Exclamation, sTitreMsg)
    End If

    ' Si on efface le contenu de la cellule, alors indiquer qu'on passe
    '  en mode édition pour bien recevoir l'événement
    If iCmd = iCmdEffacerCellule Then
        Me.m_bEdition = True
        Me.m_iLigneEdition = Me.oXL.ActiveCell.Row ' 19/05/2008
        Me.m_iColEdtion = Me.oXL.ActiveCell.Column
        Me.m_sValEditionOrig = sLireCelluleActive()
    End If

End Sub

#End If

#End Region

#Region "Export Excel : CopierPressePapier"

Public Sub CopierPressePapier(ByVal sPlageDonneesXL$)

    ' Copier une plage de données dans le presse-papier pour un export Excel

    SelectionnerPlage(sPlageDonneesXL)
    Me.oXL.Selection.Copy()
    ' Déselectionner la plage
    Me.oXL.Cells(1, 1).Select()

    ' Repositionner au début de la feuille
#If iOWC = iOWC9 Then
    ' Non trouvé en OWC10
    Me.oXL.ActiveSheet.Scroll(Me.oXL.ActiveSheet.Range("A1"))
#End If

End Sub

Public Function bExporterExcel( _
    Optional ByVal bFormules As Boolean = False, _
    Optional ByVal sFichierXl$ = sFichierExportXL, _
    Optional ByVal sPlageDonneesXL$ = "", _
    Optional ByVal sCheminFichierXLModele$ = "", _
    Optional ByVal sFichierModele$ = "", _
    Optional ByVal bProtegerTableur As Boolean = True, _
    Optional ByVal bAjusterAuContenu As Boolean = False) As Boolean

    ' Export Excel via OWC
    ' 2 1ers prm : pour SS Gear
    ' 5 derniers prm : pour OWC

    CommencerModif()
    CopierPressePapier(sPlageDonneesXL)
    SelectionnerCellule(1, 1)
    FinirModif(bProtegerTableur)
    bExporterExcel = modUtilLT.bExporterExcel(sCheminFichierXLModele, sFichierModele, _
        sPlageDonneesXL, glb.msgDelegue, bAjusterAuContenu, sFichierXl)
    CopierPressePapier("")

End Function

#End Region

End Class

'#End If ' #If bOWC Then 


ucGraphe.vb



' Fichier ucGraphe.vb
' -------------------

Option Strict Off ' Pour les graphes OWC

#Const iOWC9 = 9
#Const iOWC10 = 10
#Const iOWC11 = 11 ' 11 et 12 sous Vista
#Const iOWC = iOWC11

#If iOWC = iOWC9 Then
    Imports OWC     ' cf. sDllOWC9Interop
    Imports AxOWC   ' cf. sDllOWC9AxInterop
    Imports c1 = OWC.ChartDimensionsEnum
    Imports c2 = OWC.ChartSpecialDataSourcesEnum
    Imports c3 = OWC.ChartChartTypeEnum
    Imports c4 = OWC.ChartMarkerStyleEnum
#ElseIf iOWC = iOWC10 Then
    Imports OWC10   ' cf. sDllOWC10Interop
    Imports AxOWC10 ' cf. sDllOWC10AxInterop
    Imports c1 = OWC10.ChartDimensionsEnum
    Imports c2 = OWC10.ChartSpecialDataSourcesEnum
    Imports c3 = OWC10.ChartChartTypeEnum
    Imports c4 = OWC10.ChartMarkerStyleEnum
#ElseIf iOWC = iOWC11 Then
    'Imports Microsoft.Office.Interop.Owc11 
    'Imports AxMicrosoft.Office.Interop.Owc11 
    Imports OWC11   ' cf. sDllOWC11Interop
    Imports AxOWC11 ' cf. sDllOWC11AxInterop
    Imports c1 = OWC11.ChartDimensionsEnum
    Imports c2 = OWC11.ChartSpecialDataSourcesEnum
    Imports c3 = OWC11.ChartChartTypeEnum
    Imports c4 = OWC11.ChartMarkerStyleEnum
#End If

Public Class ucGraphe : Inherits UserControl

#Region "Déclarations"

Public Const sCompOWC9$ = "'Office Web Components' version 9 (2000)"
Public Const sDllOWC9$ = "MSOWC.DLL"
Public Const sDllOWC9Interop$ = "Interop.OWC.dll"
Public Const sDllOWC9AxInterop$ = "AxInterop.OWC.dll"
Public Const sClasseOWC9SS$ = "OWC.Spreadsheet.9"
Public Const sClasseOWC9Chart$ = "OWC.Chart.9"
Public Const sVersionOWC9$ = "9.0.0.3821 du 22/02/2000 : 3Mo"
Public Const sDllMSDataSrcOWC9$ = "MSDATASRC.dll" ' 7.0.9466.0

Public Const sCompOWC10$ = "'Office XP Web Components' version 10 (2002)"
' Ne pas confondre la dll interop (424 Ko en version 2621,
'  ou 456 Ko en version 6765) avec la dll du même nom contenant 
'  les composants OWC10 (XP) : 7262 Ko (2621) ou 7083 Ko (6765)
Public Const sDllOWC10$ = "OWC10.DLL" ' 7083 Ko
Public Const sDllOWC10Interop$ = "OWC10.DLL" ' 424 Ko (2621) ou 456 Ko (6765)
Public Const sDllOWC10AxInterop$ = "axowc10.dll" ' 148 Ko
Public Const sClasseOWC10SS$ = "OWC10.Spreadsheet.10"
Public Const sClasseOWC10Chart$ = "OWC10.ChartSpace.10"
'Public Const sVersionOWC10$ = "10.0.2621.0 du 24/02/2001 : 7Mo"
Public Const sVersionOWC10$ = "10.0.6765.0 du 03/06/2005 : 7Mo" ' SP3
'Public Const sVersionOWC10_Exacte$ = "10.0.0.6765"  ' SP3
'Public Const sVersionOWC10_Exacte2$ = "10.0.0.6619" ' SP3
'Public Const sVersionOWC10_Exacte3$ = "10.0.0.6829" ' SP3 du 12/12/2007 : ne plus vérifier !
Public Const sDllMSDataSrcOWC10$ = "MSDATASRC.dll" ' 7.0.9466.0

Public Const sCompOWC11$ = "'Office 2003 Web Components' version 11 & 12"
Public Const sDllOWC11$ = "OWC11.DLL" ' 6878 Ko (11.0.0.8166)
Public Const sDllOWC11Interop$ = "Interop.OWC11.dll" ' 444 Ko (8166)
Public Const sDllOWC11AxInterop$ = "AxInterop.OWC11.dll" ' 148 Ko
Public Const sClasseOWC11SS$ = "OWC11.Spreadsheet.11"
Public Const sClasseOWC11Chart$ = "OWC11.ChartSpace.11"
'Public Const sVersionOWC11$ = "11.0.0.8166 de 2003 : 7Mo" ' 7881 Ko V11 11.0.8166.0
Public Const sVersionOWC11$ = "12.0.0.4518 du 10/11/2006 : 7Mo" ' 6878 Ko 12.0.4518.1014 
Public Const sDllMSDataSrcOWC11$ = "MSDATASRC.dll" ' 7.0.9466.0

Public Const iOWC9% = 9
Public Const iOWC10% = 10
Public Const iOWC11% = 11

#If iOWC = iOWC11 Then
    Public Const iOWC% = 11
    Public Const sCompOWC$ = sCompOWC11
    Public Const sVersionOWC$ = sVersionOWC11
    Public Const sClasseOWCChart$ = sClasseOWC11Chart
    Public Const sDllOWC$ = sDllOWC11
#ElseIf iOWC = iOWC10 Then
    Public Const iOWC% = 10
    Public Const sCompOWC$ = sCompOWC10
    Public Const sVersionOWC$ = sVersionOWC10
    Public Const sClasseOWCChart$ = sClasseOWC10Chart
    Public Const sDllOWC$ = sDllOWC10
#ElseIf iOWC = iOWC9 Then
    Public Const iOWC% = 9 
    Public Const sCompOWC$ = sCompOWC9
    Public Const sVersionOWC$ = sVersionOWC9
    Public Const sClasseOWCChart$ = sClasseOWC9Chart
    Public Const sDllOWC$ = sDllOWC9
#End If

Public m_colCourbes As Collection
Public m_bLegende As Boolean
Public m_sCouleur$, m_iTaillePoliceAxe%

#End Region

#Region " Code généré par le Concepteur Windows Form "

    Public Sub New()
        MyBase.New()

        'Cet appel est requis par le Concepteur Windows Form.
        InitializeComponent()

        'Ajoutez une initialisation quelconque après l'appel InitializeComponent()

    End Sub

    'La méthode substituée Dispose du UserControl pour nettoyer la liste des composants.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If

        ' Maintenant il n'y a plus jamais d'erreur rencontrée ici depuis que
        '  les conditions suivantes sont respectées :
        ' - Fermer le formulaire frmLogo avant d'ouvrir le frmMain
        ' - Editer un seul uc à la fois, régénérer tout à chaque édition
        'Try
            MyBase.Dispose(disposing)
        'Catch
        'End Try
    End Sub

    'Requis par le Concepteur Windows Form
    Private components As System.ComponentModel.IContainer

    'REMARQUE : la procédure suivante est requise par le Concepteur Windows Form
    'Elle peut être modifiée en utilisant le Concepteur Windows Form.  
    'Ne la modifiez pas en utilisant l'éditeur de code.
    Private WithEvents oGr As AxChartSpace
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(ucGraphe))
Me.oGr = New AxChartSpace
CType(Me.oGr, System.ComponentModel.ISupportInitialize).BeginInit()
Me.SuspendLayout()
'
'oGr
'
Me.oGr.DataSource = Nothing
Me.oGr.Dock = System.Windows.Forms.DockStyle.Fill
Me.oGr.Enabled = True
Me.oGr.Location = New System.Drawing.Point(10, 10)
Me.oGr.Name = "oGr"
Me.oGr.OcxState = CType(resources.GetObject("oGr.OcxState"), System.Windows.Forms.AxHost.State)
Me.oGr.Size = New System.Drawing.Size(372, 308)
Me.oGr.TabIndex = 45
'
'ucGraphe
'
Me.Controls.Add(Me.oGr)
Me.DockPadding.All = 10
Me.Name = "ucGraphe"
Me.Size = New System.Drawing.Size(392, 328)
CType(Me.oGr, System.ComponentModel.ISupportInitialize).EndInit()
Me.ResumeLayout(False)

    End Sub

#End Region

Public Sub InitCourbes()

    m_colCourbes = New Collection

    ' Plante :
    'If bOWC10 Then Me.oGr.DisplayOfficeLogo = False
    ' Solution : tracer un graphique vide dans Effacer graphique

End Sub

Public Sub EffacerGraphique()

    If iOWC >= iOWC10 Then
        ' Tracer un graphique vide pour cacher le logo Office
        ' (car Me.oGr.DisplayOfficeLogo = False Plante)
        'AjouterCourbe(New clsCourbe)
        'TracerGraphique() ' Ne pas appeler EffacerGraphique
        'm_colCourbes = New Collection
        Me.oGr.Clear()
        Me.oGr.Charts.Add()
        Me.oGr.Charts(0).SeriesCollection.Add()
        Exit Sub
    End If

    Me.oGr.Clear()

End Sub

Public Sub AjouterCourbe(ByVal oCourbe As clsCourbe)

    m_colCourbes.Add(oCourbe)

End Sub

Public Sub TracerGraphique()

    ' Autre solution pour éviter les warnings en dotnet2 :
    'Imports c = ChartDimensionsEnum
    'Imports c2 = ChartSpecialDataSourcesEnum
    'Imports c3 = ChartChartTypeEnum
    'Imports c4 = ChartMarkerStyleEnum

    'Dim c As ChartDimensionsEnum
    'Dim c2 As ChartSpecialDataSourcesEnum
    'Dim c3 As ChartChartTypeEnum
    'Dim c4 As ChartMarkerStyleEnum

    Const chChartTypeColumnStacked% = 1 ' ChartChartTypeEnum.chChartTypeColumnStacked

    Me.oGr.Clear()
    Me.oGr.Charts.Add()
    Me.oGr.Charts(0).HasLegend = False 'True
    Dim oCourbe As clsCourbe
    If m_colCourbes.Count > 0 Then
        oCourbe = DirectCast(m_colCourbes(1), clsCourbe)
        ' En OWC10 et 11, le type ChartChartTypeEnum.chChartTypeColumnStacked
        '  ne doit plus s'appliquer à la courbe mais au graphique dans son ensemble
        If oCourbe.m_iTypeGraphique = chChartTypeColumnStacked Then _
            Me.oGr.Charts(0).Type = chChartTypeColumnStacked
    End If
    If m_sCouleur <> "" Then _
        Me.oGr.Charts(0).PlotArea.Interior.Color = m_sCouleur
    If m_iTaillePoliceAxe <> 0 Then
        Me.oGr.Charts(0).Axes(0).Font.Size = m_iTaillePoliceAxe
        Me.oGr.Charts(0).Axes(1).Font.Size = m_iTaillePoliceAxe
    End If

    Dim oSerie As Object = Nothing
    For Each oCourbe In m_colCourbes
        oSerie = Me.oGr.Charts(0).SeriesCollection.Add
        If oCourbe.m_sTitre <> "" Then _
           oSerie.Caption = oCourbe.m_sTitre
        If oCourbe.m_sLabels <> "" Then _
           oSerie.SetData(c1.chDimCategories, c2.chDataLiteral, oCourbe.m_sLabels)
        If oCourbe.m_sValeurs <> "" Then _
            oSerie.SetData(c1.chDimValues, c2.chDataLiteral, oCourbe.m_sValeurs)
        ' En OWC10 et 11, le type ChartChartTypeEnum.chChartTypeColumnStacked
        '  ne doit plus s'appliquer à la courbe mais au graphique dans son ensemble
        If oCourbe.m_iTypeGraphique <> 0 And _
           oCourbe.m_iTypeGraphique <> chChartTypeColumnStacked Then _
           oSerie.Type = oCourbe.m_iTypeGraphique
        'If oCourbe.m_iTypeGraphique <> 0 Then _
        '   oSerie.Type = oCourbe.m_iTypeGraphique
        If oCourbe.m_sTraitCouleur <> "" Then _
           oSerie.Line.Color = oCourbe.m_sTraitCouleur
        If oCourbe.m_iTraitEpaisseurPixels <> 0 Then _
           oSerie.Line.Weight = oCourbe.m_iTraitEpaisseurPixels
        If oCourbe.m_iMotifType <> 0 Then _
           oSerie.Marker.Style = oCourbe.m_iMotifType
        If oCourbe.m_iMotifTaillePixels <> 0 Then _
           oSerie.Marker.Size = oCourbe.m_iMotifTaillePixels
       If oCourbe.m_iCouleurInterieur <> 0 Then _
           oSerie.Interior.Color = oCourbe.m_iCouleurInterieur
        If oCourbe.m_sCouleurInterieur <> "" Then _
           oSerie.Interior.Color = oCourbe.m_sCouleurInterieur
    Next
    Me.oGr.Visible = True

End Sub

End Class


clsCourbe.vb



Public Class clsCourbe

Public m_sTitre$, m_sLabels$, m_sValeurs$
'Public m_bLegende As Boolean
Public m_iTypeGraphique%, m_sCouleurInterieur$, m_iCouleurInterieur%
Public m_iTraitEpaisseurPixels%, m_sTraitCouleur$, m_iTraitCouleur%
Public m_iMotifTaillePixels%, m_iMotifType%

End Class


Settings.vb



Namespace My
    
'Cette classe vous permet de gérer des événements spécifiques dans la classe de paramètres :
' L'événement SettingChanging est déclenché avant la modification d'une valeur de paramètre.
' L'événement PropertyChanged est déclenché après la modification d'une valeur de paramètre.
' L'événement SettingsLoaded est déclenché après le chargement des valeurs de paramètre.
' L'événement SettingsSaving est déclenché avant l'enregistrement des valeurs de paramètre.
Partial Friend NotInheritable Class MySettings
End Class

End Namespace


clsAfficherMsg.vb



' Fichier clsAfficherMsg.vb : Classes de gestion des messages via des délégués
' -------------------------

Public Class clsTickEventArgs : Inherits EventArgs
    ' Classe pour l'événement Tick : avancement d'une unité de temps : TIC-TAC
    '  utile pour mettre à jour l'heure en cours, ou pour scruter une annulation
    Public Sub New()
    End Sub
End Class

Public Class clsMsgEventArgs : Inherits EventArgs
    ' Classe pour l'événement Message
    Private m_sMsg$ = "" 'Nothing
    Public Sub New(ByVal sMsg$)
        'If sMsg Is Nothing Then Throw New NullReferenceException
        If sMsg Is Nothing Then sMsg = ""
        Me.m_sMsg = sMsg
    End Sub
    Public ReadOnly Property sMessage$()
        Get
            Return Me.m_sMsg
        End Get
    End Property
End Class

Public Class clsFECEventArgs : Inherits EventArgs
    ' Classe pour l'événement Fichier En Cours (FEC)
    Private m_iNumFichierEnCours% = 0
    Public Sub New(ByVal iNumFichierEnCours%)
        Me.m_iNumFichierEnCours = iNumFichierEnCours
    End Sub
    Public ReadOnly Property iNumFichierEnCours%()
        Get
            Return Me.m_iNumFichierEnCours
        End Get
    End Property
End Class

Public Class clsAvancementEventArgs : Inherits EventArgs

    ' Classe pour l'événement Avancement

    Private m_sMsg$ = ""
    Private m_lAvancement& = 0

    Public Sub New(ByVal sMsg$)
        If sMsg Is Nothing Then sMsg = ""
        Me.m_sMsg = sMsg
    End Sub
    Public Sub New(ByVal lAvancement&)
        Me.m_lAvancement = lAvancement
    End Sub
    Public Sub New(ByVal lAvancement&, ByVal sMsg$)
        Me.m_lAvancement = lAvancement
        If sMsg Is Nothing Then sMsg = ""
        Me.m_sMsg = sMsg
    End Sub
    Public ReadOnly Property sMessage$()
        Get
            Return Me.m_sMsg
        End Get
    End Property
    Public ReadOnly Property lAvancement&()
        Get
            Return Me.m_lAvancement
        End Get
    End Property
End Class

Public Class clsSablierEventArgs : Inherits EventArgs
    ' Classe pour l'événement Sablier
    Private m_bDesactiver As Boolean = False
    Public Sub New(ByVal bDesactiver As Boolean)
        Me.m_bDesactiver = bDesactiver
    End Sub
    Public ReadOnly Property bDesactiver() As Boolean
        Get
            Return Me.m_bDesactiver
        End Get
    End Property
End Class

Public Class clsMsgDelegue

    ' Classe de gestion des messages via des délégués

    Public Delegate Sub GestEvTick(ByVal sender As Object, _
        ByVal e As clsTickEventArgs)
    Public Event EvTick As GestEvTick

    Public Delegate Sub GestEvAfficherMessage(ByVal sender As Object, _
        ByVal e As clsMsgEventArgs)
    Public Event EvAfficherMessage As GestEvAfficherMessage

    Public Delegate Sub GestEvAfficherFEC(ByVal sender As Object, _
        ByVal e As clsFECEventArgs)
    Public Event EvAfficherNumFichierEnCours As GestEvAfficherFEC

    Public Delegate Sub GestEvAfficherAvancement(ByVal sender As Object, _
        ByVal e As clsAvancementEventArgs)
    Public Event EvAfficherAvancement As GestEvAfficherAvancement

    Public Delegate Sub GestEvSablier(ByVal sender As Object, _
        ByVal e As clsSablierEventArgs)
    Public Event EvSablier As GestEvSablier

    Public m_bAnnuler As Boolean

    Public Sub New()
    End Sub

    Public Sub AfficherMsg(ByVal sMsg$)
        Dim e As New clsMsgEventArgs(sMsg)
        RaiseEvent EvAfficherMessage(Me, e)
        TraiterMsgSysteme_DoEvents()
    End Sub

    Public Sub AfficherFichierEnCours(ByVal iNumFichierEnCours%)
        Dim e As New clsFECEventArgs(iNumFichierEnCours)
        RaiseEvent EvAfficherNumFichierEnCours(Me, e)
        TraiterMsgSysteme_DoEvents()
    End Sub

    Public Sub AfficherAvancement(ByVal lAvancement&, ByVal sMsg$)
        Dim e As New clsAvancementEventArgs(lAvancement, sMsg)
        RaiseEvent EvAfficherAvancement(Me, e)
        TraiterMsgSysteme_DoEvents()
    End Sub

    Public Sub Tick()
        Dim e As New clsTickEventArgs()
        RaiseEvent EvTick(Me, e)
        TraiterMsgSysteme_DoEvents()
    End Sub

    Public Sub Sablier(Optional ByVal bDesactiver As Boolean = False)
        Dim e As New clsSablierEventArgs(bDesactiver)
        RaiseEvent EvSablier(Me, e)
        TraiterMsgSysteme_DoEvents()
    End Sub

End Class


clsHebOffice.vb



Option Strict Off ' Pour oWkb.Close()

' clsHebOffice : classe pour héberger une application Office (Word, Excel, ...)
'  basée sur clsExcelHost, cf. XLDOTNET :

' XLDOTNET : QUITTER EXCEL SANS LAISSER D'INSTANCE EN RAM
' http://www.vbfrance.com/code.aspx?id=27541

#Region "Informations"

' D'après :

'   ======================================================================================
'   clsExcelHost : Classe pour héberger Excel
'   ============

' Title: EXCEL.EXE Process Killer
' Description: After many weeks of trying to figure out why the EXCEL.EXE Process 
'  does not want to go away from the Task Manager, I wrote this class that will ensure 
'  that the correct EXCEL.EXE Process is closed. This is after using Excel.Application 
'  via Automation from a VB.NET/ASP.NET application.
' This file came from Planet-Source-Code.com... the home millions of lines of source code
' You can view comments on this code/and or vote on it at: 
' http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=1998&lngWId=10

' The author may have retained certain copyrights to this code...
'  please observe their request and the law by reviewing all copyright conditions 
'  at the above URL.

'   Author: I.W Coetzer 2004/01/22
'   *Thanks Dan for the process idea.
'   Classe commentée et légèrement modifiée par Patrice Dargenton le 05/11/2004
'   *Solution to the EXCEL.EXE Process that does not want to go away from task manager.
'
'   ======================================================================================

#End Region

#Region "clsHebOffice"

Public Class clsHebOffice

Public m_oApp As Object = Nothing 'Protected

Private m_iIdProcess% = 0
Public m_bAppliDejaOuverte As Boolean = False
Public m_bInterdireAppliAvant As Boolean = True
Public m_sNomProcess$ = ""

Public Sub New(ByVal sNomProcess$, ByVal sClasseObjet$, _
    Optional ByVal bInterdireAppliAvant As Boolean = True, _
    Optional ByVal bReutiliserInstance As Boolean = False)

    ' Exemple :
    'Private Const sClasseObjetWord$ = "Word.Application"
    'Private Const sNomProcessWord$ = "Word"

    'Private Const sClasseObjetExcel$ = "Excel.Application"
    'Private Const sNomProcessExcel$ = "Excel"

    Me.m_iIdProcess = 0
    Me.m_bAppliDejaOuverte = False
    Me.m_bInterdireAppliAvant = bInterdireAppliAvant
    Me.m_sNomProcess = sNomProcess
    Dim sNomProcessMaj$ = sNomProcess.ToUpper

    ' Liste des processus avant le mien
    Dim aProcessAv() As Process = Process.GetProcesses()

    Dim j%
    For j = 0 To aProcessAv.GetUpperBound(0)
        If aProcessAv(j).ProcessName = sNomProcessMaj Then
            Me.m_bAppliDejaOuverte = True
            Exit For
        End If
    Next j
    If bInterdireAppliAvant And Me.m_bAppliDejaOuverte Then Exit Sub

    ' Créer le processus demandé
    Try

        If Me.m_bAppliDejaOuverte And bReutiliserInstance Then
            ' Pb : on récupère n'importe quelle instance
            '  il faudrait plutôt conserver l'instance qu'on a créée
            Me.m_oApp = GetObject(, sClasseObjet)
        Else
            Me.m_oApp = CreateObject(sClasseObjet)
        End If

    Catch Ex As Exception
        'AfficherMsgErreur2(Ex, "clsHebOffice:New", _
        '    sNomProcess & " n'est pas installé !")
        MsgBox(sClasseObjet & " n'est pas installé !" & vbLf & _
            Ex.Message, MsgBoxStyle.Critical, _
            "Lancement de " & sNomProcess)
        Me.m_oApp = Nothing
        Exit Sub
    End Try

    ' Liste des processus après le mien : la différence me donnera l'Id du mien
    Dim aProcessAp() As Process = Process.GetProcesses()

    Dim i%
    Dim bMonProcess As Boolean
    For j = 0 To aProcessAp.GetUpperBound(0)
        If aProcessAp(j).ProcessName = sNomProcessMaj Then
            bMonProcess = True
            ' Parcours des processus avant le mien
            For i = 0 To aProcessAv.GetUpperBound(0)
                If aProcessAv(i).ProcessName = sNomProcessMaj Then
                    If aProcessAp(j).Id = aProcessAv(i).Id Then
                        ' S'il existait avant, ce n'était pas le mien
                        bMonProcess = False
                        Exit For
                    End If
                End If
            Next i
            If bMonProcess = True Then
                ' Maintenant que j'ai son Id, je pourrai le tuer
                '  cette méthode marche toujours !
                Me.m_iIdProcess = aProcessAp(j).Id
                Exit For
            End If
        End If
    Next j

End Sub

Public Sub Quitter()

    If Me.m_iIdProcess = 0 Then Exit Sub

    'Process.GetProcessById(Me.m_iIdProcess).Kill()

    Dim monProc As Process = Process.GetProcessById(Me.m_iIdProcess)
    ' Même si l'instance a été fermée, monProc est toujours valide :
    '  ce test n'est pas suffisant
    If Not IsNothing(monProc) Then
        Try

            ' 15/05/2009 Libérer avant de tuer le processus
            ' Pour Excel l'objet oXL a déjà été libéré,
            '  mais il faut aussi libérer m_oApp ? c'est pourtant le même pointeur !?
            LibererObjetCom(Me.m_oApp)
            Me.m_oApp = Nothing

            ' Si l'instance ne nous appartient pas, on ne peut pas la fermer
            '  mais on ne reçoit aucune exception !
            monProc.Kill()
            ' On ne peut pas interroger immédiatement ExitCode, seule solution :
            '  vérifier si l'appli est toujours ouverte avec l'iIdProcess
            'If monProc.ExitCode = -1 Then
            '    ' MainModule vaut alors {"Accès refusé"}
            '    Debug.WriteLine("Impossible de fermer " & _
            '        Me.m_sNomProcess & " : " & monProc.MainModule.ToString)
            'End If
        Catch ex As Exception
            Debug.WriteLine(ex)
        End Try
    End If

End Sub

Public Function bMonInstanceOuverte() As Boolean

    ' Vérifier si l'instance que j'ai utilisée est encore ouverte
    '  (elle a pu être fermée par l'utilisateur si on l'autorise)
    If Me.m_iIdProcess = 0 Then Exit Function
    Dim monProc As Process = Process.GetProcessById(Me.m_iIdProcess)

    ' Même si l'instance a été fermée, monProc est toujours valide :
    '  cette fonction n'est pas suffisante
    'If IsNothing(monProc) Then Exit Function
    'bMonInstanceOuverte = True

    ' 15/05/2009
    Try
        bMonInstanceOuverte = Not monProc.HasExited()
    Catch 'ex As Exception
        ' On vient juste de fermer
    End Try

End Function

Public Shared Function bOuvert(ByVal sNomProcess$) As Boolean

    ' Vérifier si l'application est déjà ouverte 
    ' (pour le cas où cela poserait problème, faire la vérification au départ)

    Dim sNomProcessMaj$ = sNomProcess.ToUpper

    ' Liste des processus avant le mien
    Dim aProcessAv() As Process = Process.GetProcesses()

    Dim j%
    For j = 0 To aProcessAv.GetUpperBound(0)
        If aProcessAv(j).ProcessName = sNomProcessMaj Then bOuvert = True : Exit Function
    Next j

End Function

Public Shared Sub LibererObjetCom(ByRef oCom As Object)
    ' ByRef car on fait oCom = Nothing)

    ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing

    ' Pour Excel :
    ' Quit Excel and clean up.
    ' oBook.Close(false, oMissing, oMissing);
    ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBook);
    ' oBook = null;
    ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oBooks);
    ' oBooks = null;
    ' oExcel.Quit();
    ' System.Runtime.InteropServices.Marshal.ReleaseComObject (oExcel);
    ' oExcel = null;

    If IsNothing(oCom) Then Exit Sub
    Try
        Runtime.InteropServices.Marshal.ReleaseComObject(oCom)
    Catch ex As Exception
        Debug.WriteLine(ex)
    Finally
        oCom = Nothing
    End Try

End Sub

End Class

#End Region

#Region "clsHebExcel"

Public Class clsHebExcel : Inherits clsHebOffice

' clsHebExcel : classe pour héberger Excel, basée sur clsHebOffice

Private Const sClasseObjetExcel$ = "Excel.Application"
Private Const sNomProcessExcel$ = "Excel"

Public oXL As Object = Nothing

Public Sub New(Optional ByVal bInterdireAppliAvant As Boolean = True, _
    Optional ByVal bReutiliserInstance As Boolean = False)
    MyBase.New(sNomProcessExcel, sClasseObjetExcel, _
        bInterdireAppliAvant, bReutiliserInstance)
    Me.oXL = Me.m_oApp
End Sub

Public Overloads Shared Function bOuvert() As Boolean
    bOuvert = clsHebOffice.bOuvert(sNomProcessExcel)
End Function

Public Sub Fermer(ByRef oSht As Object, ByRef oWkb As Object, ByVal bQuitter As Boolean, _
    Optional ByVal bFermerClasseur As Boolean = True, _
    Optional ByVal bLibererXLSiResteOuvert As Boolean = True)

    ' Liberer correctement le classeur, et le femer si demandé, 
    '  et quitter Excel si demandé

    If bFermerClasseur AndAlso Not IsNothing(oWkb) Then
        'msgDelegue.AfficherMsg("Fermeture du classeur...")
        Try
            oWkb.Close()
        Catch ex As Exception
            Debug.WriteLine(ex)
        End Try
    End If
    LibererObjetCom(oSht)
    LibererObjetCom(oWkb)

    ' Conserver Excel ouvert (par exemple pour visualiser l'actualisation d'un classeur)
    '  on libère oXL dans le cas général (sauf si on doit continuer d'utiliser l'instance
    '  par ex. pour effectuer d'autres traitements)
    If Not bQuitter Then
        If bLibererXLSiResteOuvert Then LibererObjetCom(Me.oXL)
        Exit Sub
    End If

    If Not IsNothing(Me.oXL) Then
        Try
            'msgDelegue.AfficherMsg("Fermeture d'Excel...")
            If Me.bMonInstanceOuverte() Then Me.oXL.Quit()
        Catch ex As Exception
            ' L'application a été fermée par l'utilisateur, on n'y a plus accès
            '  ou bien on tente d'utiliser l'objet Me.oXL qui a déjà été libéré
            '  "Un objet COM qui a été séparé de son RCW sous-jacent ne peut pas être utilisé."
            Debug.WriteLine(ex)
        End Try
         'msgDelegue.AfficherMsg("Libération d'Excel...")
        LibererObjetCom(Me.oXL)
    End If

    Me.Quitter()

End Sub

End Class

#End Region

#Region "clsHebWord"

Public Class clsHebWord : Inherits clsHebOffice

' clsHebWord : classe pour héberger Word, basée sur clsHebOffice

Private Const sClasseObjetWord$ = "Word.Application"
Private Const sNomProcessWrd$ = "Winword" '"Word"

Public oWrd As Object = Nothing

Public Sub New(Optional ByVal bInterdireAppliAvant As Boolean = True)
    MyBase.New(sNomProcessWrd, sClasseObjetWord, bInterdireAppliAvant)
    oWrd = Me.m_oApp
End Sub

Public Overloads Shared Function bOuvert() As Boolean
    bOuvert = clsHebOffice.bOuvert(sNomProcessWrd)
End Function

End Class

#End Region

#Region "clsHebNav"

Public Class clsHebNav

' clsHebNav : classe pour héberger un navigateur (Internet Explorer ou Firefox)

Private Const sNomProcessIE$ = "iexplore"
Private Const sNomProcessFireFox$ = "firefox"

Public oAppNav As Object = Nothing
Private m_iIdProcess%

Public Sub New(ByVal sURL$)

    Me.m_iIdProcess = 0
    ' Liste des processus avant le mien
    Dim aProcessAv() As Process = Process.GetProcesses()

    OuvrirAppliAssociee(sURL, bVerifierFichier:=False)

    ' Liste des processus après le mien : la différence me donnera l'Id du mien
    Dim aProcessAp() As Process = Process.GetProcesses()

    Dim i%, j%
    Dim bMonProcessNav As Boolean
    For j = 0 To aProcessAp.GetUpperBound(0)
        Dim sNomProcess$ = aProcessAp(j).ProcessName
        If sNomProcess = sNomProcessIE Or sNomProcess = sNomProcessFireFox Then
            bMonProcessNav = True
            ' Parcours des processus avant le mien
            For i = 0 To aProcessAv.GetUpperBound(0)
                Dim sNomProcess1$ = aProcessAv(i).ProcessName
                If sNomProcess1 = sNomProcessIE Or _
                   sNomProcess1 = sNomProcessFireFox Then
                    If aProcessAp(j).Id = aProcessAv(i).Id Then
                        ' S'il existait avant, ce n'était pas le mien
                        bMonProcessNav = False
                        Exit For
                    End If
                End If
            Next i
            If bMonProcessNav = True Then
                ' Maintenant que j'ai son Id, je pourrai le controler
                Me.m_iIdProcess = aProcessAp(j).Id
                Exit For
            End If
        End If
    Next j

End Sub

Public Function bOuvert() As Boolean

    ' On peut savoir si l'utilisateur a fermé le navigateur ouvert 
    '  par l'application 
    If Me.m_iIdProcess = 0 Then Exit Function
    Try
        bOuvert = Not Process.GetProcessById(Me.m_iIdProcess).HasExited()
    Catch 'ex As Exception
        ' On vient juste de fermer
    End Try

End Function

Public Sub Quitter()

    If Me.m_iIdProcess = 0 Then Exit Sub

    'Process.GetProcessById(Me.m_iIdProcess).Kill()

    Dim monProc As Process = Process.GetProcessById(Me.m_iIdProcess)
    ' Même si l'instance a été fermée, monProc est toujours valide :
    '  ce test n'est pas suffisant
    If Not IsNothing(monProc) Then
        Try

            ' 15/05/2009 Libérer avant de tuer le processus
            LibererObjetCom(Me.oAppNav)
            Me.oAppNav = Nothing

            ' Si l'instance ne nous appartient pas, on ne peut pas la fermer
            '  mais on ne reçoit aucune exception !
            monProc.Kill()
            ' On ne peut pas interroger immédiatement ExitCode, seule solution :
            '  vérifier si l'appli est toujours ouverte avec l'iIdProcess
            'If monProc.ExitCode = -1 Then
            '    ' MainModule vaut alors {"Accès refusé"}
            '    Debug.WriteLine("Impossible de fermer " & _
            '        Me.m_sNomProcess & " : " & monProc.MainModule.ToString)
            'End If
        Catch ex As Exception
            Debug.WriteLine(ex)
        End Try
    End If

End Sub

Public Shared Sub LibererObjetCom(ByRef oCom As Object)
    ' ByRef car on fait oCom = Nothing)

    ' D'abord Quitter ou Fermer, puis ReleaseComObject puis oCom = Nothing

    If IsNothing(oCom) Then Exit Sub
    Try
        Runtime.InteropServices.Marshal.ReleaseComObject(oCom)
    Catch
    Finally
        oCom = Nothing
    End Try

End Sub

End Class

#End Region


clsODBC.vb



' Fichier clsODBC.vb
' ------------------
' Version 1.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
                        asTableau(iNumChamp, iNumEnreg) = sValChamp0
                        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

    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


modUtilFichier.vb



' Fichier modUtilFichier.vb : Module de gestion des fichiers
' -------------------------

Imports System.Text ' Pour StringBuilder
'Imports System.IO ' Pour Path, File, Directory...

Module modUtilFichier

Public Const sCauseErrPoss$ = _
    "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application"
Public Const sCauseErrPossDossier$ = _
    "Le dossier est peut-être protégé en écriture" & vbLf & _
    "ou bien un fichier est verrouillé par une autre application"

#Region "Gestion des fichiers"

Public Function bChoisirFichier(ByRef sCheminFichier$, ByVal sFiltre$, ByVal sExtDef$, _
    ByVal sTitre$, Optional ByVal sInitDir$ = "", _
    Optional ByVal bDoitExister As Boolean = True) As Boolean

    ' Afficher une boite de dialogue pour choisir un fichier
    ' Exemple de filtre : "|Fichiers texte (*.txt)|*.txt|Tous les fichiers (*.*)|*.*"
    ' On peut indiquer le dossier initial via InitDir, ou bien via le chemin du fichier

    Static bInit As Boolean = False

    Dim ofd As New OpenFileDialog
    With ofd
        If Not bInit Then
            bInit = True
            If sInitDir.Length = 0 Then
                If sCheminFichier.Length = 0 Then
                    .InitialDirectory = Application.StartupPath
                Else
                    .InitialDirectory = IO.Path.GetDirectoryName(sCheminFichier)
                End If
            Else
                .InitialDirectory = sInitDir
            End If
        End If
        If Not String.IsNullOrEmpty(sCheminFichier) Then .FileName = sCheminFichier
        .CheckFileExists = bDoitExister ' 14/10/2007
        .DefaultExt = sExtDef
        .Filter = sFiltre
        .Multiselect = False
        .Title = sTitre
        .ShowDialog()
        If .FileName <> "" Then bChoisirFichier = True : sCheminFichier = .FileName
    End With

End Function

Public Function bFichierExiste(ByVal sCheminFichier$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean

    ' Retourne True si un fichier correspondant est trouvé
    ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt
    bFichierExiste = IO.File.Exists(sCheminFichier)

    If Not bFichierExiste And bPrompt Then _
        MsgBox("Impossible de trouver le fichier :" & vbLf & sCheminFichier, _
            MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable")

End Function

Public Function bFichierExisteFiltre(ByVal sCheminFiltre$, ByVal sFiltre$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean

    ' Retourne True si au moins un fichier correspondant au filtre est trouvé
    '  dans le répertoire indiqué, ex.: C:\Tmp avec *.txt
    Dim di As New IO.DirectoryInfo(sCheminFiltre)
    Dim afi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers trouvés
    Dim iNbFichiers% = afi.GetLength(0)
    bFichierExisteFiltre = (iNbFichiers > 0)

    If Not bFichierExisteFiltre And bPrompt Then _
        MsgBox("Impossible de trouver des fichiers du type :" & vbLf & sCheminFiltre, _
            MsgBoxStyle.Critical, sTitreMsg & " - Fichiers introuvables")

End Function

Public Function 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 fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives
    Dim iNbFichiers% = fi.GetLength(0)
    Dim i%
    For i = 0 To iNbFichiers - 1
        Dim sFichier$ = IO.Path.GetFileName(fi(i).Name)
        Dim sSrc$ = sCheminSrc & "\" & sFichier
        Dim sDest$ = sCheminDest & "\" & sFichier

        ' Option possible : changer l'extension du fichier
        '  par exemple rename *.csv *.txt
        If bChExt Then sDest = sCheminDest & "\" & sPrefixe & _
            IO.Path.GetFileNameWithoutExtension(sFichier) & sExtDest

        If Not bRenommerFichier(sSrc, sDest, bConserverDest) Then Exit Function
    Next i

    bDeplacerFichiers3 = True

End Function

' Attribut pour éviter que l'IDE s'interrompt en cas d'exception
<System.Diagnostics.DebuggerStepThrough()> _
Public Function bFichierAccessible(ByVal sCheminFichier$, _
    Optional ByVal bPrompt As Boolean = False, _
    Optional ByVal bPromptFermer As Boolean = False, _
    Optional ByVal bInexistOk As Boolean = False, _
    Optional ByVal bPromptRetenter As Boolean = False, _
    Optional ByVal bLectureSeule As Boolean = False) As Boolean
    'Optional ByVal bEcriture As Boolean = False) As Boolean

    ' Vérifier si un fichier est accessible en écriture (non verrouillé par Excel par exemple)
    ' Simple lecture : ne marche pas : IO.FileMode.Open échoue par ex. avec l'attribut 
    '  Lecture seule sur le fichier (lorsque l'option existera on proposera simple lecture 
    '  par défaut ou bien en écriture avec l'option bEcriture)

    If bInexistOk Then
        ' Avec cette option, ne pas renvoyer Faux si le fichier n'existe pas
        If Not bFichierExiste(sCheminFichier) Then ' Et ne pas alerter non plus
            bFichierAccessible = True
            Exit Function
        End If
    Else
        If Not bFichierExiste(sCheminFichier, bPrompt) Then
            Exit Function
        End If
    End If

Retenter:
    Dim reponse As MsgBoxResult = MsgBoxResult.Cancel
    Try
        ' Si Excel a verrouillé le fichier, même une simple ouverture n'est pas permise
        Dim mode As IO.FileMode = IO.FileMode.Open
        'If bEcriture Then mode = IO.FileMode.Create
        Using fs As New IO.FileStream(sCheminFichier, mode)
            fs.Close()
        End Using
        bFichierAccessible = True
    Catch ex As Exception
        Dim msgbs As MsgBoxStyle = MsgBoxStyle.Exclamation
        If bPrompt Then
            AfficherMsgErreur2(ex, "bFichierAccessible", _
                "Impossible d'accéder au fichier :" & vbLf & _
                sCheminFichier, sCauseErrPoss)
        ElseIf bPromptFermer Then
            Dim sQuestion$ = ""
            If bPromptRetenter Then
                msgbs = msgbs Or MsgBoxStyle.RetryCancel
                sQuestion = vbLf & "Voulez-vous réessayer ?"
            End If
            ' Attention : le fichier peut aussi être en lecture seule pour diverses raisons !
            ' Certains fichiers peuvent aussi être inaccessibles pour une simple lecture
            '  par ex. certains fichiers du dossier 
            '  \Documents and Settings\All Users\Application Data\Microsoft\Crypto\RSA\MachineKeys\
            If bLectureSeule Then
                ' Le verrouillage Excel peut ralentir une lecture ODBC,
                '  mais sinon la lecture directe n'est pas possible, même avec
                '  IO.FileMode.Open, IO.FileAccess.Read et IO.FileShare.Read
                '  (sauf si le fichier a l'attribut lecture seule)
                reponse = MsgBox( _
                    "Veuillez fermer S.V.P. le fichier :" & vbLf & _
                    sCheminFichier & sQuestion, msgbs, sTitreMsg)
            Else
                reponse = MsgBox("Le fichier n'est pas accessible en écriture :" & vbLf & _
                    sCheminFichier & vbLf & _
                    "Le cas échéant, veuillez le fermer, ou bien changer" & vbLf & _
                    "ses attributs de protection, ou alors les droits d'accès." & _
                    sQuestion, msgbs, sTitreMsg)
            End If
        End If
    End Try

    If Not bFichierAccessible And reponse = MsgBoxResult.Retry Then GoTo Retenter

End Function

Public Sub 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

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)

    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"

' Le code page 1252 correspond à FileOpen de VB .NET, l'équivalent en VB6 de
'  Open sCheminFichier For Input As #1
' Mettre & pour Long en DotNet1 et % pour Integer en DotNet2
Public Const iCodePageWindowsLatin1252% = 1252 ' windows-1252 = msoEncodingWestern

Public Function sLireFichier$(ByVal sCheminFichier$)

    ' Lire et renvoyer le contenu d'un fichier

    sLireFichier = ""
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function

    Dim fs As IO.FileStream = Nothing
    Dim sr As IO.StreamReader = Nothing
    Dim sbContenu As New StringBuilder
    Dim bDebut As Boolean = False
    Try
        ' Même avec IO.FileShare.Read, impossible de lire un fichier verrouillé par Excel
        fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _
            IO.FileAccess.Read)
        ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv
        sr = New IO.StreamReader(fs, _
            Encoding.GetEncoding(iCodePageWindowsLatin1252))
        Do
            Dim sLigne$ = sr.ReadLine()
            If IsNothing(sLigne) Then Exit Do
            If bDebut Then sbContenu.Append(vbCrLf)
            bDebut = True
            sbContenu.Append(sLigne)
        Loop While True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "sLireFichier")
        Exit Function
    Finally
        If Not (sr Is Nothing) Then sr.Close()
        If Not (fs Is Nothing) Then fs.Close()
    End Try
    sLireFichier = sbContenu.ToString

End Function

Public Function sbLireFichier(ByVal sCheminFichier$) As StringBuilder

    ' Lire et renvoyer le contenu d'un fichier

    sbLireFichier = New StringBuilder
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function

    Dim fs As IO.FileStream = Nothing
    Dim sr As IO.StreamReader = Nothing
    Dim bDebut As Boolean = False
    Try
        fs = New IO.FileStream(sCheminFichier, IO.FileMode.Open, _
            IO.FileAccess.Read)
        ' Encoding.UTF8 fonctionne dans le bloc-notes, mais pas avec Excel via csv
        sr = New IO.StreamReader(fs, _
            Encoding.GetEncoding(iCodePageWindowsLatin1252))
        Do
            Dim sLigne$ = sr.ReadLine()
            If IsNothing(sLigne) Then Exit Do
            If bDebut Then sbLireFichier.Append(vbCrLf)
            bDebut = True
            sbLireFichier.Append(sLigne)
        Loop While True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "sbLireFichier")
        Exit Function
    Finally
        If Not (sr Is Nothing) Then sr.Close()
        If Not (fs Is Nothing) Then fs.Close()
    End Try

End Function

Public Function asLireFichier(ByVal sCheminFichier$) As String()

    ' Lire et renvoyer le contenu d'un fichier
    asLireFichier = Nothing
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function
    asLireFichier = IO.File.ReadAllLines(sCheminFichier, _
        Encoding.GetEncoding(iCodePageWindowsLatin1252))

End Function

Public Function bEcrireFichier(ByVal sCheminFichier$, _
    ByVal sbContenu As StringBuilder) As Boolean

'Reessayer: ' Déjà pris en charge dans bSupprimerFichier
    If Not bSupprimerFichier(sCheminFichier, bPromptErr:=True) Then
        'Dim iReponse% = MsgBox( _
        '    "Echec de l'écriture du fichier :" & vbLf & sCheminFichier & vbLf & _
        '    "Voulez-vous réessayer ?", _
        '    MsgBoxStyle.RetryCancel Or MsgBoxStyle.Question, sTitreMsg)
        'If iReponse = MsgBoxResult.Retry Then GoTo Reessayer
        Exit Function
    End If

    Dim sw As IO.StreamWriter = Nothing
    Try
        sw = New IO.StreamWriter(sCheminFichier, append:=False, _
            Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        sw.Write(sbContenu.ToString())
        sw.Close()
        bEcrireFichier = True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "bEcrireFichier", _
            "Impossible d'écrire les données dans le fichier :" & _
            vbCrLf & sCheminFichier)
    Finally
        If Not IsNothing(sw) Then sw.Close()
    End Try

End Function

Public Function bEcrireFichier(ByVal sCheminFichier$, ByVal sContenu$, _
    Optional ByVal bEncodageDefaut As Boolean = False, _
    Optional ByVal bEncodageISO_8859_1 As Boolean = False, _
    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 ø
            sw = New IO.StreamWriter(sCheminFichier, append:=False)
        ElseIf bEncodageISO_8859_1 Then
            sw = New IO.StreamWriter(sCheminFichier, append:=False, _
                Encoding:=Encoding.GetEncoding("ISO-8859-1"))
        Else
            ' Encodage par défaut de VB6 et de Windows en français
            sw = New IO.StreamWriter(sCheminFichier, append:=False, _
                Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        End If
        sw.Write(sContenu)
        sw.Close()
        bEcrireFichier = True
    Catch Ex As Exception
        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
        sw = New IO.StreamWriter(sCheminFichier, append:=True, _
            Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        sw.Write(sContenu)
        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
        sw = New IO.StreamWriter(sCheminFichier, append:=True, _
            Encoding:=Encoding.GetEncoding(iCodePageWindowsLatin1252))
        sw.Write(sbContenu.ToString())
        sw.Close()
        bAjouterFichier = True
    Catch Ex As Exception
        AfficherMsgErreur2(Ex, "bAjouterFichier", _
            "Impossible d'écrire les données dans le fichier :" & vbCrLf & sCheminFichier)
    Finally
        If Not IsNothing(sw) Then sw.Close()
    End Try

End Function

Public Function bReencoder(ByVal sCheminFichier$) As Boolean

    ' Réencoder un fichier avec les sauts de ligne Unix (vbLf) en fichier Windows (vbCrLf)
    If Not bFichierExiste(sCheminFichier, bPrompt:=True) Then Exit Function
    Dim sb As StringBuilder = sbLireFichier(sCheminFichier)
    If sb.Length = 0 Then Exit Function
    bReencoder = bEcrireFichier(sCheminFichier, sb.Append(vbCrLf))

End Function

#End Region

#Region "Divers"

Public Function asArgLigneCmd(ByVal sFichiers$) As String()

    ' Retourner les arguments de la ligne de commande

    Dim asArgs$() = Nothing

    'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg

    ' Parser les noms cours : facile
    'asArgs = Split(Command, " ")

    ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers)
    ' Chaque nom long de fichier est entre guillemets : ""
    '  une fois le nom traité, les guillemets sont enlevés
    ' S'il y a un non court parmi eux, il n'est pas entre guillemets

    Const sGm$ = """" ' Un seul " en fait
    'sGm = Chr$(34) ' Guillemets
    Dim iNbArg%, sFichier$, sSepar$
    Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2%
    Dim bFin As Boolean, bNomLong As Boolean
    sCmd = sFichiers 'Command$
    iLen = Len(sCmd)
    iDeb = 1
    Do

        bNomLong = False : sSepar = " "
        ' Si le premier caractère est un guillement, c'est un nom long
        If Mid$(sCmd, iDeb, 1) = sGm Then bNomLong = True : sSepar = sGm

        iDeb2 = iDeb
        ' Supprimer les guillemets dans le tableau de fichiers
        If bNomLong Then iDeb2 += 1
        ' Bug corrigé : iDeb2 + 1 et non iDeb2 + 2
        iFin = InStr(iDeb2 + 1, sCmd, sSepar)
        ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande
        If iFin = 0 Then bFin = True : iFin = iLen + 1

        sFichier = Trim$(Mid$(sCmd, iDeb2, iFin - iDeb2))
        If sFichier <> "" Then
            ReDim Preserve asArgs(iNbArg)
            asArgs(iNbArg) = sFichier
            iNbArg += 1
        End If

        If bFin Or iFin = iLen Then Exit Do

        iDeb = iFin + 1
        If bNomLong Then iDeb = iFin + 2

    Loop

    Const iCodeGuillemets% = 34
    Dim iNumArg%
    For iNumArg = 0 To UBound(asArgs)
        asArgs(iNumArg) = Trim$(asArgs(iNumArg))
        Dim sArg$ = asArgs(iNumArg)
        ' S'il y avait 2 guillemets, il n'en reste plus qu'un
        '  on le converti en chaîne vide
        If Len(sArg) = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then
            asArgs(iNumArg) = ""
        End If
    Next iNumArg

    asArgLigneCmd = asArgs

End Function

Public Function sConvNomDos$(ByVal sChaine$, _
    Optional ByVal bLimit8Car As Boolean = False, _
    Optional ByVal bConserverSignePlus As Boolean = False)

    ' Remplacer les caractères interdits pour les noms de fichiers DOS
    '  et retourner un nom de fichier 8.3 correcte si demandé

    Dim iSel%, sBuffer$, sCar$, iCode%, sCarConv2$, sCarDest$
    Dim bOk As Boolean, bMaj As Boolean
    sBuffer = Trim$(sChaine)
    If bLimit8Car Then sBuffer = Left$(sBuffer, 8)
    Const sCarConv$ = " .«»/[]:;|=,*-" ' Caractères à convertir en souligné
    sCarConv2 = sCarConv
    If Not bConserverSignePlus Then sCarConv2 &= "+"
    For iSel = 1 To Len(sBuffer)
        sCar = Mid$(sBuffer, iSel, 1)
        iCode = Asc(sCar)
        bMaj = False
        If iCode >= 65 And iCode <= 90 Then bMaj = True
        If iCode >= 192 And iCode <= 221 Then bMaj = True
        If InStr(sCarConv2, sCar) > 0 Then _
            Mid$(sBuffer, iSel, 1) = "_" : GoTo Suite
        If InStr("èéêë", sCar) > 0 Then
            If bMaj Then sCarDest = "E" Else sCarDest = "e"
            Mid$(sBuffer, iSel, 1) = sCarDest
            GoTo Suite
        End If
        If InStr("àáâä", sCar) > 0 Then
            If bMaj Then sCarDest = "A" Else sCarDest = "a"
            Mid$(sBuffer, iSel, 1) = sCarDest
            GoTo Suite
        End If
        If InStr("ìíîï", sCar) > 0 Then
            If bMaj Then sCarDest = "I" Else sCarDest = "i"
            Mid$(sBuffer, iSel, 1) = sCarDest
            GoTo Suite
        End If
        If InStr("ùúûü", sCar) > 0 Then
            If bMaj Then sCarDest = "U" Else sCarDest = "u"
            Mid$(sBuffer, iSel, 1) = sCarDest
            GoTo Suite
        End If
        If bConserverSignePlus And iCode = 43 Then GoTo Suite
        'de 65 à 90  maj
        'de 97 à 122 min
        'de 48 à 57 Chiff
        bOk = False
        If (iCode >= 65 And iCode <= 90) Then bOk = True
        If (iCode >= 97 And iCode <= 122) Then bOk = True
        If (iCode >= 48 And iCode <= 57) Then bOk = True
        If Not bOk Then Mid$(sBuffer, iSel, 1) = "_"
Suite:
    Next iSel
    sConvNomDos = sBuffer

End Function

#End Region

End Module