Cocher un addin.XLA dans un fichier Excel que l'on crée sous Visual basic 6

**Esmax** · 20/08/2010, 11h50

Bonjour tout le monde

Je possède un programme en VB6 qui me crée des fichier excel et a la fin du programme avant la sauvegarde du fichier je voudrais que le programme coche directement un fichier xla

J'ai donc rajouté ce code

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
Public NomBaseDonnees As String Public NameUser As String Public NameFileXLA As String Public ListReferences As String Public RefExists As String NomBaseDonnees = ActiveWorkbook.Name If AddIns("RTEImport").Installed = True Then Else AddIns("RTEImport").Installed = True End If NameUser = Environ("UserName") Dim NameFileXLA As String NameFileXLA = "C:\Documents and Settings\" & NameUser & "\Application Data\Microsoft\AddIns\RTEImport.xla" If Dir(NameFileXLA) = "" Then MsgBox "XLA not found under: " & NameFileXLA Else Set ListReferences = Workbooks(NomBaseDonnees).VBProject.References RefExists = False For m = 1 To ListReferences.Count If ListReferences.Item(m).FullPath = NameFileXLA Then RefExists = True Exit For End If Next m

Mais apparament il n'aime pas le "ListReferences", il affiche une fenetre avec "compile error: Object required"
Comment feriez vous?

**ProgElecT** · 20/08/2010, 13h10

Code :

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

1
2
'Public ListReferences As String  ??????
Public ListReferences  As Object

**Esmax** · 20/08/2010, 13h48

Ok j'ai plus d'erreur par contre la reference n'est pas coché quel code utilisez vous?

Est ce que j'ai au mauvais endroit mon code qui permet de rajouter la reference .xla ?

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
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
Public Function ConvertWorkBook() As Boolean
 
   Debug.Print "ConvertWorkBook()"
   ConvertWorkBook = False
 
   Dim objItem As listitem
   Dim sNiveauTension, sTranche, CodeSchem As String  'for better understanding
   Dim objFile As New Scripting.FileSystemObject
 
   For Each objItem In FCS.listTrancheView.ListItems
      sNiveauTension = objItem.Text
      sTranche = objItem.SubItems(1)
      CodeSchem = objItem.SubItems(2)
 
      DoEvents       'OS gets control, to receive events in Form
 
      If objItem.Selected Then
        If FCS.bEquipment.Value = cAktiviert Then
                Dim CodeSchem2
                CodeSchem2 = CodeSchem
                If Not InStr(1, CodeSchem2, "/") = 0 Then
                    Mid(CodeSchem2, InStr(1, CodeSchem2, "/"), 1) = "-"
                End If
                Call FCS.Log(Conversion_tranche_log & sTranche & Niveau_tension_log & sNiveauTension & From_checkliste_log & CodeSchem2 & ".xls ###")
        Else
            If FCS.xpCheck2.Value = cAktiviert Then
                Call FCS.Log(Conversion_tranche_log & sTranche & Niveau_tension_log & sNiveauTension & From_checkliste_log & sTranche & ".xls ###")
            Else
                Call FCS.Log(Conversion_tranche_log & sTranche & Niveau_tension_log & sNiveauTension & " ###", , True)
            End If
        End If
        'This is a global flag, if this is set, the user pressed the abort button
        'the called function, will close all worksheets and workbooks of the active
        '(own created) Excel application
 
         FCS.xpProgress1.max = 14
         FCS.xpProgress1.Value = 0
         Set xlFCSWorkBook = xlApp.Workbooks.Add
 
         '######################
         ' Procede
         '######################
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/Organes")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/RéducteursMesure")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/AutresAppareilsHTouBT")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/InterTranchesCommuns")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/InterTranchesDédiés")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/AlimentationsContinues")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/AutoTransformateurs-Transformateurs")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_PROCEDE, "Procédé/AutreAppareilHTouBT")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
 
         '######################
         ' Reglage
         '######################
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_REGLAGE, "Réglages/EquipementsTiers")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_REGLAGE, "Réglages/FonctionsNumériséesCCN")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
 
         '######################
         ' Conduite
         '######################
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_CONDUIT, "Conduite/Signalisations")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_CONDUIT, "Conduite/Commandes")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_CONDUIT, "Conduite/SignalisationsCommandes")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
            Call CreateSeparateWorkbooks(sNiveauTension, sTranche, TAB_COLOR_CONDUIT, "Conduite/Mesures")
            FCS.xpProgress1.Value = FCS.xpProgress1.Value + 1
 
         Call CreateJournalDeBord(sNiveauTension, sTranche, CodeSchem)
         ' at the end of CreateJournalDeBord,
         '     CompareWithEquipmentData
         ' will be called because the extrated Schematique information
         ' is extracted by CreateJournalDeBord
 
         'Delete unused sheets
         Dim xlTempWorksheet As Excel.Worksheet
 
         For Each xlTempWorksheet In xlFCSWorkBook.Worksheets
            If xlTempWorksheet.Tab.ColorIndex = -4142 Then
                 Call DeleteWorksheetSilent(xlTempWorksheet, False)
           End If
         Next xlTempWorksheet
 
         If xlFCSWorkBook.Worksheets.Count > 1 Then
            Dim sCurrentFolder As String
 
            Dim NomSite, sFilelink, sFile As String
            Dim FCSIndise, i, j As Integer
 
            FCSIndise = ""
            NomSite = ""
 
            On Error Resume Next
 
            NomSite = xlFCSWorkBook.Worksheets(1).Cells(2, 2).Value
            FCSIndise = xlFCSWorkBook.Worksheets(1).Cells(4, 2).Value
 
            On Error GoTo 0
 
 
            'Modification pour rajout du .XLA
 
            NomBaseDonnees = ActiveWorkbook.Name
 
            If AddIns("RTEImport").Installed = True Then
            Else
            AddIns("RTEImport").Installed = True
            End If
 
            NameUser = Environ("UserName")
 
            Dim NameFileXLA As String
            NameFileXLA = "C:\Documents and Settings\" & NameUser & "\Application Data\Microsoft\AddIns\RTEImport.xla"
 
            If Dir(NameFileXLA) = "" Then
            MsgBox "XLA not found under: " & NameFileXLA
 
            Else
            Set ListReferences = Workbooks(NomBaseDonnees).VBProject.References
            RefExists = False
 
 
            For m = 1 To ListReferences.Count
                If ListReferences.Item(m).FullPath = NameFileXLA Then
                    RefExists = True
                    Exit For
                End If
            Next m
            End If
 
            'fin de modification pour rajour .XLA
 
 
            'create Full path informations and folders
            '-----------------------------------------
            Dim bAlerting As Boolean
            bAlerting = xlApp.DisplayAlerts
 
            mDestinationFolder = PathOutputCL & "\FCS_" & NomSite & "_" & FCSIndise
            sCurrentFolder = mDestinationFolder
            If objFile.FolderExists(sCurrentFolder) = False Then objFile.CreateFolder (sCurrentFolder)
 
            sCurrentFolder = sCurrentFolder & "\" & sNiveauTension
            If objFile.FolderExists(sCurrentFolder) = False Then objFile.CreateFolder (sCurrentFolder)
 
            sCurrentFolder = sCurrentFolder & "\" & sTranche
            If objFile.FolderExists(sCurrentFolder) = False Then objFile.CreateFolder (sCurrentFolder)
 
        '-----------------------------------------
 
            xlFCSWorkBook.Worksheets(OngletJournalDeBord).Activate
 
            'Call DeleteWorksheetSilent(xlFCSWorkBook.Worksheets(DELETE_WS_ID), False)
            Call SaveAsWithoutAlert(xlFCSWorkBook, sCurrentFolder, _
                                                         sTranche & ".xls", True)
            If xlEquipWorkBook Is Nothing Then 'Import with Checklists
            Else
                On Error Resume Next
                Call SaveAsWithoutAlert(xlEquipWorkBook, mDestinationFolder, xlEquipWorkBook.Name, False)
            End If
         End If
      End If
      DoEvents
   Next objItem
 
   If FCS.ImportWithCL Then
        If xlEquipWorkBook Is Nothing Then
        Else
            xlEquipWorkBook.Close False
            Set xlEquipWorkBook = Nothing
        End If
   End If
 
   ConvertWorkBook = True
   FCS.xpProgress1.Value = 0
   FCS.StatusBar1.Panels(1).Text = Ready_Text
 
   Dim FSO As Object
   Set FSO = CreateObject("Scripting.FileSystemObject")
   FSO.DeleteFolder (PathOutputCL & "\TempFCS"), True
 
    xlApp.Quit
    Set xlApp = Nothing
 
End Function

**Esmax** · 20/08/2010, 14h50

Bon j'ai changé le code est ca marche avec

Workbooks(NomBaseDonnees).VBProject.References.AddFromFile NameFileXLA

Par contre si je lance une 2eme fois le programme cette ligne ne marche plus

Code :

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

            NomBaseDonnees = ActiveWorkbook.Name

je recois un message d'erreur "Run-time error '462': The remote server machine does not exist or is unavailable"

Vous savez d ou cela peut venir?

Cocher un addin.XLA dans un fichier Excel que l'on crée sous Visual basic 6

Macros et VBA Excel

Discussions similaires

Partager

Partager