+ Répondre à la discussion
Affichage des résultats 1 à 11 sur 11
  1. #1
    Membre Expert
    Avatar de fred65200
    Inscrit en
    septembre 2007
    Messages
    901
    Détails du profil
    Informations personnelles :
    Âge : 47

    Informations forums :
    Inscription : septembre 2007
    Messages : 901
    Points : 1 140
    Points
    1 140

    Par défaut Sauvegarder des macros et les importer

    Un peu de code pour sauvegarder des macros d'un classeur
    Activation de la référence Microsoft Visual Basic for Applications Extensibility avec Minor et Majour mis à 0 pour "rattrapage" automatique.
    Création des dossiers de sauvegarde...

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    Option Explicit
    
    
    Sub SauvegardeMacros()
    Dim AWbk As Workbook
    Dim DateEtHeure As String
    Dim NomSansExt As String
    Dim DossierSauvegarde As String
     
    Set AWbk = ActiveWorkbook
     
    ' Activation de la référence
    ' "Microsoft Visual Basic for Applications Extensibility"
    On Error Resume Next
    ThisWorkbook.VBProject.References.AddFromGuid _
        GUID:="{0002E157-0000-0000-C000-000000000046}", Major:=0, Minor:=0
    On Error GoTo 0
     
    DateEtHeure = "-" & Format(Now, "dd-mm-yy hh-mm-ss")
    NomSansExt = Mid(AWbk.Name, 1, InStr(1, AWbk.Name, ".") - 1)
    DossierSauvegarde = AWbk.Path & Application.PathSeparator & "Code " & NomSansExt & DateEtHeure
     
    'Exportation des modules
    ExportAllVBA AWbk.Name, DossierSauvegarde
     
    If MsgBox("Ouvrir le dossier de sauvegarde ?", vbYesNo) = vbYes Then _
      Shell "C:\WINDOWS\EXPLORER.EXE /n,/e," & DossierSauvegarde, vbNormalFocus
    End Sub
    Sub ExportAllVBA(Quoi, Destination)
    'macro d'origine de Chip pearson
    'http://www.cpearson.com/excel/vbe.aspx
    Dim VBComp As VBIDE.VBComponent
    Dim Ext As String
    Dim DossierSauvegarde As String
    Dim Wbk As Workbook
    Dim Dest As String
    Dim objFSO As Object
    Dim Obj As Object
    Dim Txt As Object
    Dim LeCode As String
    'Création des dossiers de destination
    DossierSauvegarde = Destination
    MkDir DossierSauvegarde
    MkDir DossierSauvegarde & Application.PathSeparator & "Modules de feuille"
     
    'export des codes
    Set Wbk = Workbooks(Quoi)
     
    For Each VBComp In Wbk.VBProject.VBComponents
       Select Case VBComp.Type
            Case vbext_ct_ClassModule
               Ext = ".cls": Dest = Destination: GoTo cas1
            Case vbext_ct_MSForm
               Ext = ".frm": Dest = Destination: GoTo cas1
            Case vbext_ct_StdModule
               Ext = ".bas": Dest = Destination: GoTo cas1
            Case vbext_ct_Document
               Ext = ".cls": Dest = Destination & Application.PathSeparator & "Modules de feuille": GoTo cas2
            Case Else
               Ext = ""
        End Select
    
    'Deux cas pour faciliter la réécriture des modules de feuille
    cas1:
       If Ext <> "" Then
          VBComp.Export Filename:=Dest & Application.PathSeparator & VBComp.Name & Ext
          Dest = ""
        End If
        GoTo Suite
        
    cas2:
       If Ext <> "" Then
          Set Obj = VBComp.CodeModule
    'Ajout suite au commentaire de aalex_38 
          If Obj.CountOfLines = 0 Then GoTo Suite
    'Fin de l'ajout
          LeCode = Obj.Lines(1, Obj.CountOfLines)
          Set objFSO = CreateObject("Scripting.FileSystemObject")
          Set Txt = objFSO.OpenTextFile(Dest & Application.PathSeparator & VBComp.Name & Ext, 2, True)
          Txt.Write LeCode
          Txt.Close
          Dest = ""
       End If
    
    Suite:
    Next VBComp
    End Sub
    encore un peu pour les importer
    Boite de dialogue pour sélectionner le dossier de sauvegarde
    Liste des modules dans le dossier et les sous dossiers
    Affichage d'un userform avec case à cocher,
    Importation à la demande après suppression ou effacement

    Code :
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
    15
    16
    17
    18
    19
    20
    21
    22
    23
    24
    25
    26
    27
    28
    29
    30
    31
    32
    33
    34
    35
    36
    37
    38
    39
    40
    41
    42
    43
    44
    45
    46
    47
    48
    49
    50
    51
    52
    53
    54
    55
    56
    57
    58
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    Option Explicit
    Dim i As Integer, k As Integer
    Dim tabFichiers() As Variant
     
     
     
    Sub Importer()
    Dim objShell As Object, objFolder As Object, objFolderItem As Object
    Dim objFSO As Object, objSubFolder As Object, objFile As Object
    Dim CheminRep As String
    Dim tabDossiers As Variant
    Dim tabextensions As Variant
     
    tabDossiers = Array()
    tabextensions = Array("bas", "frm", "cls")
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, ThisWorkbook.Path)
     
    'si  Annuler , fin de Sub
    If objFolder Is Nothing Then Exit Sub
     
    Set objFolderItem = objFolder.Self
    CheminRep = objFolderItem.Path
     
    'Insertion du chemin dans le tableau
    ReDim Preserve tabDossiers(UBound(tabDossiers) + 1)
    tabDossiers(UBound(tabDossiers)) = CheminRep
     
    'Recherche des sous répertoires
    Set objFSO = CreateObject("Scripting.FileSystemObject")
     
    'Ajout des chemins des sous répertoires au tableau
    For Each objSubFolder In objFSO.GetFolder(CheminRep).SubFolders
       ReDim Preserve tabDossiers(UBound(tabDossiers) + 1)
       tabDossiers(UBound(tabDossiers)) = objSubFolder.Path
    Next
     Dim Tag2 As String
    'Recherche des fichiers
    k = 0
       For i = 0 To UBound(tabDossiers)
          For Each objFile In objFSO.GetFolder(tabDossiers(i)).Files
            ' If Not Right(objFile.Name, 3) = "frx" Then
             If Not IsError(Application.Match(Extension(objFile.Name, True), tabextensions, 0)) Then   'ajout
                ReDim Preserve tabFichiers(2, k)
                'Ajout du nom au tableau
                tabFichiers(0, k) = objFile.Name
                'Ajout du chemin au tableau
                tabFichiers(1, k) = objFile.Path
                Select Case Extension(objFile.Name, True)
                   Case "bas": Tag2 = "Module standard"
                   Case "cls": Tag2 = "Module de classe"
                   Case "frm": Tag2 = "User Form"
                End Select
                tabFichiers(2, k) = IIf(InStr(1, objFile.Path, "Modules de feuille") > 0, "Module de feuille", Tag2)
                k = k + 1
             End If
          Next objFile
       Next i
     
    Set objShell = Nothing
    Set objFolder = Nothing
    Set objFolderItem = Nothing
    Set objFSO = Nothing
    Set objSubFolder = Nothing
     
    'Affichage des Modules dans un USF
    NewUserForm '"Modules"
     
    End Sub
    Function Extension(Fichier As String, Optional SansPt As Boolean = False) As String
       Extension = Mid(Fichier, InStrRev(Fichier, ".") + Abs(SansPt))
    End Function
     
    Sub NewUserForm()
     
    Dim ufCaption As String
    Dim ub As Integer
    Dim j As Integer
    Dim Col As Integer
    Dim ufTemp As Object
    Dim newBtn As Object
    Dim LargMax As Integer
    Dim HauteurUSF As Integer
    Dim LargUSF As Integer
    Dim DerLiCode As Integer
    Dim Code As String
     
    ufCaption = "Choix des modules à importer"
    ub = k - 1
     
    'Application.VBE.MainWindow.Visible = False
     
     j = 0: Col = 15
     
    'Création du UserForm
    Set ufTemp = ThisWorkbook.VBProject.VBComponents.Add(3)        'vbext_ct_MSForm
     
    'Création des cases à cocher, 10 par "colonnes"
    For i = 0 To ub
       Set newBtn = ufTemp.Designer.Controls.Add("forms.checkbox.1")
       With newBtn
          .Caption = tabFichiers(0, i)
          ' si changement de dizaine, nouvelle colonne
          If i Mod 10 = 0 Then Col = Col + LargMax: LargMax = 0: j = 0
          .Left = Col
          .Top = 10 + 20 * j
          .WordWrap = False
          .AutoSize = True
          If .Width > LargMax Then LargMax = .Width
          .Tag = tabFichiers(1, i)
          .ControlTipText = tabFichiers(2, i)
       End With
       j = j + 1
    Next i
     
    'Création du bouton OK
    Set newBtn = ufTemp.Designer.Controls.Add("forms.CommandButton.1", "BtnOK")
       With newBtn
          .Caption = "OK": .Accelerator = "O"
          .Left = IIf(Col + LargMax - .Width > 95, Col + LargMax - .Width, 95)
          .Top = IIf(i > 9, 220, (i + 1) * 20)
          .Default = True
          HauteurUSF = .Top + .Height + 60
          LargUSF = .Left + .Width + 20
       End With
     
     
    'Création du bouton Annuler
    Set newBtn = ufTemp.Designer.Controls.Add("forms.CommandButton.1", "BtnAnnuler")
       With newBtn
          .Caption = "Annuler": .Accelerator = "A"
          .Left = 15:      .Top = IIf(i > 9, 220, (i + 1) * 20)
       End With
     
    'Case Cocher tout
       Set newBtn = ufTemp.Designer.Controls.Add("forms.checkbox.1", "ToutOuRien")
       With newBtn
          .Caption = "Cocher tout": .Accelerator = "C"
          .Left = 15:      .Top = HauteurUSF - 45:      .AutoSize = True
       End With
     
    'Dimensions du USF
       With ufTemp
      '    .Properties("Name") = "ufTemp"
          .Properties("Caption") = ufCaption
          .Properties("Width") = LargUSF
          .Properties("Height") = HauteurUSF
       End With
     
    'Ajout de code au bouton "BtnOK"
    Code = Code & "Sub BtnOK_Click()" & vbLf
    Code = Code & "Unload Me" & vbLf
    Code = Code & "Dim i As Integer" & vbLf
    Code = Code & "Dim Chaine As String, NomSansExt As String" & vbLf
    Code = Code & "" & vbLf
    Code = Code & "For i = 1 To " & ub + 1 & vbLf
    Code = Code & "   If Controls(""CheckBox"" & i) Then" & vbLf
    Code = Code & "      If Controls(""CheckBox"" & i).ControlTipText = ""Module de feuille"" Then" & vbLf
    Code = Code & "         NomSansExt = Mid(Controls(""CheckBox"" & i).Caption, 1, InStr(1, Controls(""CheckBox"" & i).Caption, ""."") - 1)" & vbLf
    Code = Code & "         EcrireCodeFeuille Controls(""CheckBox"" & i).Tag, NomSansExt" & vbLf
    Code = Code & "      Else" & vbLf
    Code = Code & "         RemplacerModule NomSansExt, Controls(""CheckBox"" & i).Tag" & vbLf
    Code = Code & "      End If" & vbLf
    Code = Code & "   End If" & vbLf
    Code = Code & "Next i" & vbLf
    Code = Code & "End Sub" & vbLf
    'Ajout du code de la case à cocher "Cocher tout"
    Code = Code & "Private Sub ToutOuRien_Click()" & vbLf
    Code = Code & "Dim Ctrl As Control" & vbLf
    Code = Code & "For Each Ctrl In Me.Controls" & vbLf
    Code = Code & "If TypeName(Ctrl) = ""CheckBox"" Then Ctrl.Value = ToutOuRien.Value" & vbLf
    Code = Code & "Next Ctrl" & vbLf
    Code = Code & "End Sub" & vbLf
    'Ajout de code au bouton BtnAnnuler
    Code = Code & "Sub BtnAnnuler_Click()" & vbLf
    Code = Code & "Unload Me" & vbLf
    Code = Code & "End Sub" & vbLf
     
     
    'Ajout de code au bouton OK
    With ufTemp.CodeModule
       DerLiCode = .CountOfLines
       .InsertLines DerLiCode + 1, Code
    End With
     
    'Affichage du USF
    VBA.UserForms.Add(ufTemp.Name).Show
    'Suppression du USF
    ThisWorkbook.VBProject.VBComponents.Remove ufTemp
     
    'Application.VBE.CommandBars.FindControl(ID:=106).Execute
     
    End Sub
    Sub EcrireCodeFeuille(NomDeFichier, monModule)
     
       Dim NoFichier As Integer
       Dim LongueurFichier As Long
       Dim LeCode As String
     
       NoFichier = FreeFile()
       'Ouvre le fichier en mode lecture.
       Open NomDeFichier For Input As #NoFichier
          LongueurFichier = FileLen(NomDeFichier)
          LeCode = Input(LongueurFichier, NoFichier)
       Close NoFichier
     
       With ActiveWorkbook.VBProject.VBComponents(monModule).CodeModule
          'Suppression du code existant
          .DeleteLines 1, .CountOfLines
          'Insertion du code
          .InsertLines 1, LeCode
       End With
     
    End Sub
    Sub RemplacerModule(Ancien, Nouveau)
    With ActiveWorkbook.VBProject
       'Suppression du module si existant
       If ModuleExists(CStr(Ancien)) Then _
          .VBComponents.Remove .VBComponents(Ancien)
       'Importation
       .VBComponents.Import Nouveau
    End With
    End Sub
    Function ModuleExists(VBCompName As String) As Boolean
     'Code de Chip Pearson
     On Error Resume Next
      ModuleExists = CBool(Len(ActiveWorkbook.VBProject.VBComponents(VBCompName).Name))
    End Function
    Merci à Louis qui m'a fait plancher la dessus ce soir.

    Vos commentaires sont les bienvenus, surtout pour la partie "Importation".

    Cordialement
    fred65200
    Pensez à cliquer sur

  2. #2
    Inactif
    Avatar de ouskel'n'or
    Inscrit en
    février 2005
    Messages
    12 466
    Détails du profil
    Informations forums :
    Inscription : février 2005
    Messages : 12 466
    Points : 15 063
    Points
    15 063

    Par défaut

    Un lien qui peut peut-être se joindre à toi
    A+

  3. #3
    Inactif
    Inscrit en
    juin 2007
    Messages
    2 055
    Détails du profil
    Informations forums :
    Inscription : juin 2007
    Messages : 2 055
    Points : 2 273
    Points
    2 273

    Par défaut


    Tout à fait complet.
    Et en prime la construction dynamique d'un UF. avec les contrôles et le codes.

  4. #4
    Membre Expert Avatar de aalex_38
    Inscrit en
    septembre 2007
    Messages
    1 630
    Détails du profil
    Informations forums :
    Inscription : septembre 2007
    Messages : 1 630
    Points : 1 965
    Points
    1 965

    Par défaut un petit probleme de sauvegarde pour THISWORKBOOK

    D'abord merci pour ce code qui est super.

    Je signale juste que si je n'ai rien dans ThisWorkBook, j'ai un plantage dans le cas 2 de la sauvegarde car "CountofLines" est à zéro.
    Ajouter un espace par exemple dans ThisWorkBook suffit à régler le problème.

    Encore merci pour cette source.

    NB: je n'ai pas encore testé l'importation.

  5. #5
    Membre Expert Avatar de aalex_38
    Inscrit en
    septembre 2007
    Messages
    1 630
    Détails du profil
    Informations forums :
    Inscription : septembre 2007
    Messages : 1 630
    Points : 1 965
    Points
    1 965

    Par défaut Ok

    Bonjour,

    J'ai ajouté ça dans le code :

    Code :
    1
    2
    3
    If Obj.CountOfLines = 0 Then
            GoTo Suite
    End If
    et il n'y a plus de problème.

    ce code répond parfaitement a ce que je voulais faire. Merci

  6. #6
    Membre Expert
    Avatar de fred65200
    Inscrit en
    septembre 2007
    Messages
    901
    Détails du profil
    Informations personnelles :
    Âge : 47

    Informations forums :
    Inscription : septembre 2007
    Messages : 901
    Points : 1 140
    Points
    1 140

    Par défaut

    Bonjour et merci aalex_38 pour tes commentaires.

    J'ai ajouté ta contribution au code du premier post de ce fil.

    Fred
    fred65200
    Pensez à cliquer sur

  7. #7
    Membre Expert Avatar de aalex_38
    Inscrit en
    septembre 2007
    Messages
    1 630
    Détails du profil
    Informations forums :
    Inscription : septembre 2007
    Messages : 1 630
    Points : 1 965
    Points
    1 965

    Par défaut UserForm et Importation

    Je viens de tester l'importation et je ce trouve ça génial !

    Les modules sont parfaitement chargés, c'est très pratique de pouvoir ainsi regroupper tous les codes que l'on veut.

    J'ai par contre une erreur d'execution pour charger les USERFORM
    Je n'ai pas réussi à voir d'ou venait le bug.

  8. #8
    Membre Expert
    Avatar de fred65200
    Inscrit en
    septembre 2007
    Messages
    901
    Détails du profil
    Informations personnelles :
    Âge : 47

    Informations forums :
    Inscription : septembre 2007
    Messages : 901
    Points : 1 140
    Points
    1 140

    Par défaut

    bonjour aalex_38,

    désolé de répondre aussi tardivement, pas mal de boulot en ce moment.
    J'ai effectué une petite modif au code
    Code :
    1
    2
    'Affichage des Modules dans un USF
    NewUserForm '"Modules"
    et cela semble fonctionner même pour les userforms. Peux tu retester s'il te plait et donner tes versions d'OS et d'Excel.
    Testé avec Excel 2007 sur Vista.
    Cordialement
    fred65200
    Pensez à cliquer sur

  9. #9
    Membre du Club
    Inscrit en
    janvier 2007
    Messages
    79
    Détails du profil
    Informations forums :
    Inscription : janvier 2007
    Messages : 79
    Points : 65
    Points
    65

  10. #10
    Membre du Club
    Homme Profil pro aymeric
    Développeur informatique
    Inscrit en
    octobre 2013
    Messages
    145
    Détails du profil
    Informations personnelles :
    Nom : Homme aymeric
    Localisation : France, Rhône (Rhône Alpes)

    Informations professionnelles :
    Activité : Développeur informatique
    Secteur : Industrie

    Informations forums :
    Inscription : octobre 2013
    Messages : 145
    Points : 41
    Points
    41

    Par défaut

    Bonjour

    J'aimerais savoir quel référence il faut avoir pour que cela fonctionne
    Car personnellement j'ai Excel 2003 avec les références suivantes :
    Visual Basic For Application
    Microsoft Excel 11.0 Object Library
    OLE Automation
    Microsoft Office 11.0 Object Library
    Microsoft Forms 2.0 Object Library

    et le programme que tu as fait bloque a la ligne :

    Code :
    Dim VBComp As VBIDE.VBComponent
    il me met :

    Erreur de compilation
    Type définie pas l'utilisateur non défini

    Et comme je ne suis pas un super pro en vba Excel bha je pige rien ^^

  11. #11
    Membre Expert Avatar de curt
    Homme Profil pro Curt
    Bureau d'Etudes
    Inscrit en
    mars 2006
    Messages
    1 144
    Détails du profil
    Informations personnelles :
    Nom : Homme Curt
    Localisation : France

    Informations professionnelles :
    Activité : Bureau d'Etudes
    Secteur : Bâtiment Travaux Publics

    Informations forums :
    Inscription : mars 2006
    Messages : 1 144
    Points : 1 538
    Points
    1 538

    Par défaut

    Bonjour Sharox,

    il faut ajouter
    Code :
    Microsoft Visual Basic for Applications Extensibility
    aux références comme annoncé au début du post.

    Curt
    Pas de demande par MP, sinon j'correctionne plus, j'dynamite, j'disperse, j'ventile !!!
    ---------------------------------------------------------------------
    Vous avez un talent insoupçonné... Faites-en profitez les autres. Un p'tit CLIC pour une grande cause.
    Et si vous faisiez un bon geste en 2014 ? Soyez utile, ça vous changera ! Moi, ça m’a changé !

Liens sociaux

Règles de messages

  • Vous ne pouvez pas créer de nouvelles discussions
  • Vous ne pouvez pas envoyer des réponses
  • Vous ne pouvez pas envoyer des pièces jointes
  • Vous ne pouvez pas modifier vos messages
  •