Discussion :

[cranic]

Bonjour,

Je travaille présentement à écrire du code qui m'aide à propager du code d'un fichier central à un gros volumes de fichiers (~850), ce qui me sert à faire des mises à jour dans mon code au travers des fichiers déjà en place. Ce code ouvre chacun des fichiers et transfère les modules de mon fichier source au fichier qui vient juste d'être ouvert.

Le code que j'utilise est le suivant (Prit sur http://www.cpearson.com/excel/vbe.aspx)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Function CopyModule(ModuleName As String, _
    FromVBProject As VBIDE.VBProject, _
    ToVBProject As VBIDE.VBProject, _
    OverwriteExisting As Boolean) As Boolean
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' CopyModule
    ' This function copies a module from one VBProject to
    ' another. It returns True if successful or  False
    ' if an error occurs.
    '
    ' Parameters:
    ' --------------------------------
    ' FromVBProject         The VBProject that contains the module
    '                       to be copied.
    '
    ' ToVBProject           The VBProject into which the module is
    '                       to be copied.
    '
    ' ModuleName            The name of the module to copy.
    '
    ' OverwriteExisting     If True, the VBComponent named ModuleName
    '                       in ToVBProject will be removed before
    '                       importing the module. If False and
    '                       a VBComponent named ModuleName exists
    '                       in ToVBProject, the code will return
    '                       False.
    '
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
    Dim VBComp As VBIDE.VBComponent
    Dim FName As String
    Dim CompName As String
    Dim S As String
    Dim SlashPos As Long
    Dim ExtPos As Long
    Dim TempVBComp As VBIDE.VBComponent
 
    '''''''''''''''''''''''''''''''''''''''''''''
    ' Do some housekeeping validation.
    '''''''''''''''''''''''''''''''''''''''''''''
    If FromVBProject Is Nothing Then
        CopyModule = False
        Exit Function
    End If
 
    If Trim(ModuleName) = vbNullString Then
        CopyModule = False
        Exit Function
    End If
 
    If ToVBProject Is Nothing Then
        CopyModule = False
        Exit Function
    End If
 
    If FromVBProject.Protection = vbext_pp_locked Then
        CopyModule = False
        Exit Function
    End If
 
    If ToVBProject.Protection = vbext_pp_locked Then
        CopyModule = False
        Exit Function
    End If
 
    On Error Resume Next
    Set VBComp = FromVBProject.VBComponents(ModuleName)
    If Err.Number <> 0 Then
        CopyModule = False
        Exit Function
    End If
 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' FName is the name of the temporary file to be
    ' used in the Export/Import code.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    FName = Environ("Temp") & "\" & ModuleName & ".bas"
    If OverwriteExisting = True Then
        ''''''''''''''''''''''''''''''''''''''
        ' If OverwriteExisting is True, Kill
        ' the existing temp file and remove
        ' the existing VBComponent from the
        ' ToVBProject.
        ''''''''''''''''''''''''''''''''''''''
        If Dir(FName, vbNormal + vbHidden + vbSystem) <> vbNullString Then
            Err.Clear
            Kill FName
            If Err.Number <> 0 Then
                CopyModule = False
                Exit Function
            End If
        End If
        With ToVBProject.VBComponents
            .Remove .Item(ModuleName)      '<-------- Le programme lit cette ligne mais ne l'exécute pas
        End With
    Else
        '''''''''''''''''''''''''''''''''''''''''
        ' OverwriteExisting is False. If there is
        ' already a VBComponent named ModuleName,
        ' exit with a return code of False.
        ''''''''''''''''''''''''''''''''''''''''''
        Err.Clear
        Set VBComp = ToVBProject.VBComponents(ModuleName)
        If Err.Number <> 0 Then
            If Err.Number = 9 Then
                ' module doesn't exist. ignore error.
            Else
                ' other error. get out with return value of False
                CopyModule = False
                Exit Function
            End If
        End If
    End If
 
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    ' Do the Export and Import operation using FName
    ' and then Kill FName.
    ''''''''''''''''''''''''''''''''''''''''''''''''''''
    FromVBProject.VBComponents(ModuleName).Export Filename:=FName
 
    '''''''''''''''''''''''''''''''''''''
    ' Extract the module name from the
    ' export file name.
    '''''''''''''''''''''''''''''''''''''
    SlashPos = InStrRev(FName, "\")
    ExtPos = InStrRev(FName, ".")
    CompName = Mid(FName, SlashPos + 1, ExtPos - SlashPos - 1)
 
    ''''''''''''''''''''''''''''''''''''''''''''''
    ' Document modules (SheetX and ThisWorkbook)
    ' cannot be removed. So, if we are working with
    ' a document object, delete all code in that
    ' component and add the lines of FName
    ' back in to the module.
    ''''''''''''''''''''''''''''''''''''''''''''''
    Set VBComp = Nothing
    Set VBComp = ToVBProject.VBComponents(CompName)
 
    If VBComp Is Nothing Then
        ToVBProject.VBComponents.Import Filename:=FName
    Else
        If VBComp.Type = vbext_ct_Document Then
            ' VBComp is destination module
            Set TempVBComp = ToVBProject.VBComponents.Import(FName)
            ' TempVBComp is source module
            With VBComp.CodeModule
                .DeleteLines 1, .CountOfLines
                S = TempVBComp.CodeModule.Lines(1, TempVBComp.CodeModule.CountOfLines)
                .InsertLines 1, S
            End With
            On Error GoTo 0
            ToVBProject.VBComponents.Remove TempVBComp
        End If
    End If
    Kill FName
    CopyModule = True
End Function

Le problème que je rencontre est que pour certains de mes modules, le code ne fonctionne tout simplement pas. En fait il s'exécute normalement, mais quand vient le temps d'enlever le module du Workbook, la fonction lit la ligne et ne l'exécute tout simplement pas.

Les pistes de solution que j'ai trouvé à date sont que les modules qui ne veulent pas se transférer comportent des fonctions reliées à l'affichage et que ces fonctions sont appelées dans ma déclaration de Workbook_Open. J'ai essayé lors de test de faire en sorte que le code ne lise pas la ligne où la fonction est appelée, mais ça ne change rien. Par contre, si je met la ligne où la fonction d'affichage est appelée en commentaire, soudainement je suis capable de transférer tous mes modules.
Au début je n'avais qu'un seul module qui ne voulait pas se transférer, mais maintenant que j'ai pris les fonctions Title_Show et Title_Hide (Voir les modules plus bas) et que je les ai changés de modules j'ai aussi des problèmes à transférer le nouveau module d'accueil de ces fonctions.

Est-ce quelqu'un aurait une idée de ce qui cause ce problème et un moyen de le régler?

Je laisse mes modules qui ne veulent pas être transférés ici pour consultation

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
  (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
  (ByVal hwnd As Long, ByVal nIndex As Long) As Long
 
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_MAXIMIZEBOX = &H10000
Private Const WS_MINIMIZEBOX = &H20000
Private Const WS_SYSMENU = &H80000
 
Private Declare Function SetWindowPos Lib "user32" _
  (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
  ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
  ByVal cy As Long, ByVal wFlags As Long) As Long
 
Private Enum ESetWindowPosStyles
  SWP_SHOWWINDOW = &H40
  SWP_HIDEWINDOW = &H80
  SWP_FRAMECHANGED = &H20
  SWP_NOACTIVATE = &H10
  SWP_NOCOPYBITS = &H100
  SWP_NOMOVE = &H2
  SWP_NOOWNERZORDER = &H200
  SWP_NOREDRAW = &H8
  SWP_NOREPOSITION = SWP_NOOWNERZORDER
  SWP_NOSIZE = &H1
  SWP_NOZORDER = &H4
  SWP_DRAWFRAME = SWP_FRAMECHANGED
  HWND_NOTOPMOST = -2
End Enum
 
Private Declare Function GetWindowRect Lib "user32" _
  (ByVal hwnd As Long, lpRect As RECT) As Long
 
Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type
 
Sub ShowTitleBar(bShow As Boolean)
'
'Ne pas toucher, code derrière title_hide et title_show.
 
  Dim lStyle As Long
  Dim tRect As RECT
  Dim xlHnd As Long
 
  xlHnd = Application.hwnd
 
  '// Get the window's position:
  GetWindowRect xlHnd, tRect
 
  '// Show the Title bar ?
  If Not bShow Then
    lStyle = GetWindowLong(xlHnd, GWL_STYLE)
    lStyle = lStyle And Not WS_SYSMENU
    lStyle = lStyle And Not WS_MAXIMIZEBOX
    lStyle = lStyle And Not WS_MINIMIZEBOX
    lStyle = lStyle And Not WS_CAPTION
  Else
    lStyle = GetWindowLong(xlHnd, GWL_STYLE)
    lStyle = lStyle Or WS_SYSMENU
    lStyle = lStyle Or WS_MAXIMIZEBOX
    lStyle = lStyle Or WS_MINIMIZEBOX
    lStyle = lStyle Or WS_CAPTION
  End If
 
  SetWindowLong xlHnd, GWL_STYLE, lStyle
 
  Application.DisplayFullScreen = Not bShow
 
  '// Ensure the style is set and makes the xlwindow the
  '// same size, regardless of the title bar.
  SetWindowPos xlHnd, 0, tRect.Left, tRect.Top, tRect.Right - tRect.Left, _
    tRect.Bottom - tRect.Top, SWP_NOREPOSITION Or SWP_NOZORDER Or SWP_FRAMECHANGED
End Sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Option Explicit
 
Public g_strVar As String
 
Sub Test_Proc()
 
    g_strVar = ImportTextFile("ADRESS/Message_Alerte.txt")
    MsgBox g_strVar
 
End Sub
 
Function ImportTextFile(strFile As String) As String
 
    Open strFile For Input As #1
    ImportTextFile = Input$(LOF(1), 1)
    Close #1
 
End Function
 
Sub Title_Show()
'
' Title_Show Macro, affiche l'interface normale d'Excel.
 
ShowTitleBar True
 
ActiveWindow.DisplayWorkbookTabs = True
 
Application.OnKey "{ESC}"      ' to reenable
Application.OnKey "%{F11}"      ' to reenable
 
 
End Sub
 
Sub Title_Hide()
'
'Cache l'interface normale d'Excel, dont la barre windows en haut et la plupart des features d'Excel.
'Empèche aussi les utilisateurs de peser sur ESC pour réduire la fenêtre Excel.
 
ShowTitleBar False
 
ActiveWindow.DisplayWorkbookTabs = False
 
Application.OnKey "{ESC}", ""  ' to disable
Application.OnKey "%{F11}", ""  ' to disable
 
g_strVar = ImportTextFile("ADRESS/Message_Alerte.txt")
If g_strVar <> "" Then MsgBox g_strVar
 
End Sub

[pgz]

Bonsoir

Le problème que je rencontre est que pour certains de mes modules, le code ne fonctionne tout simplement pas. En fait il s'exécute normalement, mais quand vient le temps d'enlever le module du Workbook, la fonction lit la ligne et ne l'exécute tout simplement pas.

Les pistes de solution que j'ai trouvé à date sont que les modules qui ne veulent pas se transférer comportent des fonctions reliées à l'affichage et que ces fonctions sont appelées dans ma déclaration de Workbook_Open. J'ai essayé lors de test de faire en sorte que le code ne lise pas la ligne où la fonction est appelée, mais ça ne change rien. Par contre, si je met la ligne où la fonction d'affichage est appelée en commentaire, soudainement je suis capable de transférer tous mes modules.

Tu pourrais essayer d'ouvrir le classeur à mettre à jour dans une application avec le traitement des évènements désactivé

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Application.EnableEvents = False

Cordialement,

PGZ

[cranic]

Wow, je vous remercie, ça a en effet corrigé le problème! Et dire qu'une solution si simple fonctionne, j'étais rendu à essayer de changer le code programmatiquement afin qu'il ne lise pas la ligne, mais rien ne fonctionnait.

Merci beaucoup!

Nicolas