Public Declare Function GetTickCount& Lib "kernel32" ()

Sub MesureDuTempsQuiPasse()
Dim Départ As Double, arrivée As Double,  Durée As Double,i As Long
Dim mn As Integer, ms As Integer, sd As Integer, tps As String
    Départ = GetTickCount&
    '************* ton code ********************
    For i = 1 To 100000 'remplace le déroulement du code
         DoEvents
    Next
    '*****************************************
    arrivée = GetTickCount&
    Durée = arrivée - Départ
    mn = Int(Durée / 1000 / 60)
    sd = Int((Durée / 1000) - (mn * 60))
    ms = Durée - (sd * 1000) - (mn * 1000 * 60)
    'Formatage #:##:###
    tps = mn & ":" & right("00" & sd, 2) & ":" & Right("000" & ms, 3)
    MsgBox tps
End Sub

Sub ajouteMenu(ByVal MenuName As String, _
            ByVal tItems As Variant, _
            ByVal tLinks As Variant, _
            ByVal tTTText As Variant)
    
    Dim myMenu As CommandBar
    Dim newMenu As CommandBarControl
    Dim subMenu As CommandBarControl
    Dim ctl As CommandBarControl
    Dim Value As Variant
    Dim i As Long, j As Long
    
    Set myMenu = CommandBars.ActiveMenuBar
    Set newMenu = myMenu.Controls.Add(Type:=msoControlPopup, temporary:=True)
    newMenu.Caption = MenuName
    For Each Value In tItems
        If IsArray(Value) Then
            'cas d'un sous menu
            Set subMenu = newMenu.Controls.Add(Type:=msoControlPopup, temporary:=True)
            subMenu.Caption = Value(0)
            For j = 1 To UBound(Value)
                Set ctl = subMenu.Controls.Add(Type:=msoControlButton)
                ctl.Caption = Value(j)
                ctl.Style = msoButtonIconAndCaption
                ctl.OnAction = tLinks(i)(j)
                ctl.FaceId = CLng(tTTText(i)(j))
            Next j
        Else
            'cas d'un menu
            Set ctl = newMenu.Controls.Add(Type:=msoControlButton)
            If Left(Value, 1) = "-" Then
                ctl.BeginGroup = True
                ctl.Caption = Mid(Value, 2)
            Else
                ctl.Caption = Value
            End If
            ctl.Style = msoButtonIconAndCaption
            ctl.OnAction = tLinks(i)
            ctl.FaceId = CLng(tTTText(i))
        End If
        i = i + 1
    Next Value
    

End Sub

Sub effaceMenu(ByVal MenuName As String)
    
    Dim myMenu As CommandBar
    
    On Error Resume Next
   
    Set myMenu = CommandBars.ActiveMenuBar
    myMenu.Controls(MenuName).Delete

End Sub

Private Sub Workbook_Open()

' arg1  :   titre du menu affiché dans la barre de menu (chaine)
' arg2  :   noms des menus (tableaux / imbrications possibles)
' arg3  :   noms des subs liés au code (tableaux / imbrications possibles)
' arg4  :   icones (numériques code des FaceId)
' plus d'infos sur les FaceId sur
'   http://officeone.mvps.org/faceid/

' NB : il est important d'utiliser la meme structure d'imbrication dans les 
'        paramArrays pour que le code ne plante pas.

' NB : pour insérer un séparateur commencer le nom du menu par un tiret
'         ex : "-&Quitter"

ajouteMenu "Nom d&u menu", _
            Array("Menu&1", Array("&sous menu", "sous me&nu 1", "sous m&enu 2"), "-&Quitter"), _
            Array("Macro1", Array("", "soussub1", "soussub2"), "subquitter"), _
            Array(1, Array(107, 1671, 48), 343)


End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

' arg   :   nom du menu à effacer (chaine)

effaceMenu "Nom d&u menu"

End Sub

Sub Auto_open()
 Call CréerBouton
End Sub


Sub CréerBouton()
Dim nbboutons As Byte

Set MonControl = Application.CommandBars("Standard")

With MonControl
    nbboutons = .Controls.Count
    Set MonBouton = .Controls.Add(msoControlButton, 2950, nbboutons)
    With MonBouton
        .Caption = "Recettes"
        .OnAction = "NomMacroAssociée"
    End With
    Set MonBouton = Nothing
End With

Set MonControl = Nothing
End Sub


Sub Auto_Close()
Call SupprimerBouton
End Sub


Sub SupprimerBouton()
On Error Resume Next 'Au cas ou bouton déjà détruit
Application.CommandBars("Standard").Controls("Recettes").Delete
End Sub

'--------------------------------------
'à placer dans le module objet ThisWorbook pour que la classe
'soit initialisée lors de l'ouverture du classeur.

Option Explicit

Private Sub Workbook_Open()
Dim Obj As OLEObject
Dim Cl As Classe1

Set Collect = New Collection

'boucle sur les objets de la Feuil1
For Each Obj In Feuil1.OLEObjects
    'verifie s'il s'agit d'un Checkbox
    If TypeOf Obj.Object Is MSForms.CheckBox Then
        
        Set Cl = New Classe1
        Set Cl.CheckBoxGroup = Obj.Object
        Collect.Add Cl
    End If
Next Obj

End Sub
'--------------------------------------

'--------------------------------------
'dans un module standard
Option Explicit

Public Collect As Collection
'--------------------------------------

'--------------------------------------
'Dans un module de classe nommé "Classe1"
'
Option Explicit

Public WithEvents CheckBoxGroup As MSForms.CheckBox


'Evenement Click sur les CheckBox de la feuille de calcul.
Private Sub CheckBoxGroup_Click()
    
    'Renvoie le nom et la valeur de la CheckBox cliquée
    MsgBox CheckBoxGroup.Name & ": " & CheckBoxGroup.Value
    
    'Exemple qui renvoie dans la colonne A, la valeur de CheckBox
    Cells(CheckBoxGroup.TopLeftCell.Row, 1) = CheckBoxGroup.Value
End Sub

'--------------------------------------

Option Explicit

Public Declare Function CreateScalableFontResource Lib "gdi32" _
    Alias "CreateScalableFontResourceA" (ByVal fHidden As Long, ByVal _
    lpszResourceFile As String, ByVal lpszFontFile As String, _
    ByVal lpszCurrentPath As String) As Long


Sub informationsFonts_CelluleA1()
    'Testé avec Excel2002 et WinXP
    
    Const Cible = &H14
    '
    'Nécessite d'activer la référence "Microsoft Shell Controls and Automation"
    '
    Dim objShell As Shell32.Shell
    Dim objFolder As Shell32.Folder
    Dim colItems As Shell32.FolderItems
    Dim objItem As Shell32.FolderItem
    Dim i As Integer
    Dim LaPolice As String
    
    LaPolice = Range("A1").Font.Name
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.NameSpace(Cible)
    Set colItems = objFolder.Items
    
    For Each objItem In colItems
        If FichierCible(objItem.Name) = LaPolice Then
            MsgBox objItem.Path
            Exit For
        End If
    Next objItem
    
End Sub


Public Function FichierCible(FichierTTF As String) As String
    Dim NumFich As Integer, x As Integer
    Dim Buffer As String, Fichier As String, FichierTemp As String
    
    FichierTemp = ThisWorkbook.Path & "\~TEMP.FOT"
    
    If CreateScalableFontResource(1, FichierTemp, FichierTTF, vbNullString) Then
        NumFich = FreeFile
    
        Open FichierTemp For Binary Access Read As NumFich
            Buffer = Space(LOF(NumFich))
            Get NumFich, , Buffer
            x = InStr(Buffer, "FONTRES:") + 8
            Fichier = Mid(Buffer, x, InStr(x, Buffer, vbNullChar) - x)
        Close NumFich
        
        Kill FichierTemp
    End If
    
    FichierCible = Fichier
End Function

Option Explicit
 
Sub lancementProcedure()
    'Le classeur spécifié doit être ouvert
    recupContenuVBE Workbooks("NomClasseur.xls"), "Module1"
    
    'recupContenuVBE Workbooks("NomClasseur.xls"), "Feuil1"
    'recupContenuVBE Workbooks("NomClasseur.xls"), "ThisWorkbook"
End Sub
 
 
 
Function recupContenuVBE(ByVal Wb As Workbook, Optional nomModule As String)
    Dim oModule As Object
    Dim Resultat As String
 
    Set oModule = Wb.VBProject.VBComponents(nomModule).CodeModule
    Resultat = oModule.Lines(1, oModule.CountOfLines)
 
    xPortCode Resultat, 18, Wb.Name, nomModule
End Function
 
 
 
Function xPortCode(ByVal strBuff As String, ByVal sizeFont As Integer, _
        ByVal Titre As String, ByVal nomModule As String)
 
    '
    'Source: http://cafeine.developpez.com/access/tutoriel/regexp/
    '
    
    Dim i As Long
    Dim Fic As Integer
    Dim reg As VBScript_RegExp_55.RegExp
    Dim KeyWords() As String, KeyWordsList As String
    Dim Types() As String, TypesList As String
    Dim APIArg As String
    Dim appWrd As Object, docWord As Object
 
 
    Set reg = New VBScript_RegExp_55.RegExp
    Fic = 1
     
    ' ouverture du fichier en écriture
    Open "C:\" & nomModule & " (" & Format(Now, "yy-mm-dd") & ").html" For Output As #Fic
    
    ' écriture des en-têtes HTML et style
    Print #Fic, "<HTML>"
    Print #Fic, "<HEAD><TITLE>Export au format HTML " & Titre & " - " & nomModule; "</TITLE>"
    Print #Fic, "<meta http-equiv=""Content-Type"" content=""text/html; charset=ISO-8859-1"" />"
    Print #Fic, "<style type='Text/css'>"
    Print #Fic, "<!--"
    Print #Fic, "BODY {"
    Print #Fic, "margin-top:0; margin-left:10; margin-right:0;"
    Print #Fic, "font-family: Arial;"
    'la variable argument sizeFont passe dans la définition du style
    Print #Fic, "font-size: " & sizeFont & "px;"
    Print #Fic, "}"
    Print #Fic, ".commentaire {"
    Print #Fic, "color: #669933;"
    Print #Fic, "}"
    Print #Fic, ".chaine {"
    Print #Fic, "color: #993399;"
    Print #Fic, "}"
    Print #Fic, ".key {"
    Print #Fic, "color: #0033BB;"
    Print #Fic, "}"
    Print #Fic, ".type {"
    Print #Fic, "font-weight: bold;"
    Print #Fic, "color: #3366CC;"
    Print #Fic, "}"
    
    Print #Fic, ".titre {"
    Print #Fic, "font-weight: bold;"
    Print #Fic, "text-decoration: underline;"
    '
    Print #Fic, "font-family: Arial;"
    Print #Fic, "color: #000066;"
    Print #Fic, "font-size: 14px;"
    Print #Fic, "}"
    
    Print #Fic, "-->"
    Print #Fic, "</style>"
    Print #Fic, "</HEAD>"
    Print #Fic, "<BODY>"
    
    
    'empêcher les ouvertures de tag HTML
    strBuff = Replace(strBuff, "<", "&lt;")
    
    ' les retours chariot
    reg.Pattern = "(\n)"
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1<br />")
    
    
    ' 1- les mots-clé
    KeyWordsList = "AddressOf©Alias©And©As©ByRef©ByVal©Call©Case©Close©CBool©CByte©CCur©" & _
            "CDate©CDec©CDbl©CInt©CLng©CSng©CStr©CVar©Const©Compare©Database©Declare©Debug©Default©" & _
            "Dim©Do©Each©Else©ElseIf©End©Enum©Erase©Error©Explicit©Event©Exit©False©For©" & _
            "Friend©Function©Get©GoTo©Handles©If©Implements©Imports©In©Inherits©" & _
            "Interface©Is©Let©Lib©Like©Loop©Me©Mod©New©Next©Not©Nothing©" & _
            "On©Open©Option©Optional©Or©ParamArray©Preserve©Print©Private©Property©Protected©" & _
            "Public©RaiseEvent©ReadOnly©Redim©REM©Resume©Return©Select©Set©Shared©Static©" & _
            "Step©Stop©Sub©Then© To ©True©Type©TypeOf ©Until©UBound©When©Wend©While©With©WithEvents©WriteOnly©Xor"
            
    KeyWords = Split(KeyWordsList, "©")
    For i = 0 To UBound(KeyWords)
        reg.Pattern = "(\W|^)(" & KeyWords(i) & ")(\W|$)"
        reg.MultiLine = False
        reg.Global = True
        reg.IgnoreCase = True
        strBuff = reg.Replace(strBuff, "$1<span class=key>$2</span>$3")
    Next i
    
    ' 2- les commentaires
    '  les REM
    reg.Pattern = "(\s)(rem .*)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1<span class=commentaire>$2</span>")
    
    '  les apostrophes (')
    reg.Pattern = "(\n)(([^\x22\n]*\x22[^\x22\n]*\x22)*)([^\x22\n']*)('.*)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "$1$2$4<span class=commentaire>$5</span>")
 
    ' 3- les types
    TypesList = "Boolean©Byte©Date©Double©Integer©Long©Object©Short©Single©String©Unicode©Variant"
    Types = Split(TypesList, "©")
    For i = 0 To UBound(Types)
        reg.Pattern = "(\W|^)(" & Types(i) & ")(\W|$)"
        reg.MultiLine = False
        reg.Global = True
        reg.IgnoreCase = True
        strBuff = reg.Replace(strBuff, "$1<span class=type>$2</span>$3")
    Next i
    
    ' 4- les chaines
    reg.Pattern = "(\x22[^\x22\n]*\x22)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    strBuff = reg.Replace(strBuff, "<span class=chaine>$1</span>")
    
    ' Highlight dans un Highlight
    reg.Pattern = "(<span class=\w{6,11}>)(.*)(<span class=\w{3,11}>)(.*)(</span>)(.*</span>)"
    reg.MultiLine = False
    reg.Global = True
    reg.IgnoreCase = True
    Do While reg.Test(strBuff)
        strBuff = reg.Replace(strBuff, "$1$2$4$6")
    Loop
    
    ' les espaces
    strBuff = Replace(strBuff, "  ", "  ")
    
    ' écriture de la chaîne dans le fichier
    Print #Fic, strBuff
    Print #Fic, "</BODY>"
    Print #Fic, "</HTML>"
    
    ' libération des objets mémoire
    Reset
    Set reg = Nothing
    
    Set appWrd = CreateObject("Word.Application")
    'Indiquez False pour masquer Word pendant l'impression
    appWrd.Visible = True
    Set docWord = appWrd.Documents.Open("C:\" & nomModule & _
        " (" & Format(Now, "yy-mm-dd") & ").html", False)
    docWord.PrintOut
    
    docWord.Close
    appWrd.Quit
    Set docWord = Nothing
    Set appWrd = Nothing
End Function

Sub tranfertTableAccess_Vers_ClasseurExcelFerme()
    'Transfére une Table Access dans un nouvel onglet d'un classeur fermé.
    '
    Dim ExcelCn As ADODB.Connection
    Dim ExcelRst As ADODB.Recordset
    Dim AccessCn As New ADODB.Connection
    Dim AccessRst As New ADODB.Recordset
    Dim maBase As String, maFeuille As String, listeTable As String
    Dim maTable As String, NomClasseur As String
    Dim j As Integer
    Dim Fld As ADODB.Field
    
    'Chemin de la base Access
    maBase = "C:\Documents and Settings\mimi\dossier\dataBase.mdb"
    'Nom de la table Access à transfèrer
    maTable = "Table1"
    'Classeur ou va être créée la nouvelle feuille
    NomClasseur = "C:\leClasseurFermé.xls"
    'Nom de la nouvelle feuille Excel
    maFeuille = "MaNouvelleFeuille"
    
    
    'Connection à la base Access
    AccessCn.Open "provider=microsoft.jet.oledb.4.0; data source=" & maBase
    'Requète dans la table Access
    AccessRst.Open "SELECT * FROM " & maTable, AccessCn, adOpenStatic
    
    'Connection au classeur Excel
    Set ExcelCn = New ADODB.Connection
    ExcelCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & NomClasseur & ";" & _
                   "Extended Properties=""Excel 8.0;HDR=NO;"""
        
        
    'paramétrage des entêtes et types de données
    For Each Fld In AccessRst.Fields
        listeTable = listeTable & Fld.Name & " " & FieldType(Fld.Type) & ","
    Next Fld
    
    'création nouvelle Feuille Excel
    listeTable = Left(listeTable, Len(listeTable) - 1)
    ExcelCn.Execute "create table " & maFeuille & "(" & listeTable & ")"
    
    
    Set ExcelRst = New ADODB.Recordset
    ExcelRst.Open "Select * from " & maFeuille, ExcelCn, adOpenKeyset, adLockOptimistic
        
    'transfert les données Access vers le classeur Excel
    Do While Not (AccessRst.EOF)
            ExcelRst.AddNew
                For j = 0 To ExcelRst.Fields.Count - 1
                    ExcelRst.Fields(j) = AccessRst.Fields(j).Value
                Next j
            ExcelRst.Update
            AccessRst.MoveNext
    Loop
        
    
    AccessRst.Close
    AccessCn.Close
    Set ExcelRst = Nothing
    Set ExcelCn = Nothing
End Sub

Function FieldType(Valeur As Long) As String
    'Spécification des types de données pour la création des champs Excel.
    'Attention ! la liste est incomplète.
    '
    Select Case Valeur
        Case 6
            FieldType = "currency"
            
        Case 7, 133, 134, 135
            FieldType = "Date"
            
        Case 14, 131
            FieldType = "Decimal"
            
        Case 5
            FieldType = "Float"
        
        Case 3, 2
            FieldType = "Integer"
            
        Case 4
            FieldType = "Real"
            
        Case 200, 202
            FieldType = "Text"
            
        Case 11
            FieldType = "Boolean"
            
        Case 203
            FieldType = "Memo"
            
        Case 16
            FieldType = "Tinyint"
    End Select
End Function

Sub tranfertTableAccess_Vers_ClasseurExcelFerme_V02()
    'Transfére une Table Access dans un nouvel onglet d'un classeur fermé
    '
    Dim ExcelCn As ADODB.Connection
    Dim ExcelRst As ADODB.Recordset
    Dim AccessCn As New ADODB.Connection
    Dim AccessRst As New ADODB.Recordset
    Dim maBase As String, maFeuille As String
    Dim maTable As String, NomClasseur As String
    Dim nbEnr As Long
    
    'Chemin de la base Access
    maBase = "C:\Documents and Settings\mimi\dossier\dataBase.mdb"
    'Nom de la table Access à transfèrer
    maTable = "Table1"
    'Classeur dans lequel va être créée la nouvelle feuille
    NomClasseur = "C:\leClasseurFermé.xls"
    'Nom de la nouvelle feuille Excel
    maFeuille = "MaNouvelleFeuille2"
    
    
    'Connection à la base Access
    AccessCn.Open "provider=microsoft.jet.oledb.4.0; data source=" & maBase
    'Requète dans la table Access
    AccessRst.Open "SELECT * FROM " & maTable, AccessCn, adOpenStatic
    
    'Connection au classeur Excel
    Set ExcelCn = New ADODB.Connection
    ExcelCn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                   "Data Source=" & NomClasseur & ";" & _
                   "Extended Properties=""Excel 8.0;HDR=NO;"""
        
    'Transfert les données d'Access vers Excel
    AccessCn.Execute "SELECT * INTO [Excel 8.0;" & _
        "Database=" & NomClasseur & "].[" & maFeuille & "] FROM " & maTable, nbEnr
    
    AccessRst.Close
    AccessCn.Close
    Set ExcelRst = Nothing
    Set ExcelCn = Nothing
End Sub