Récupérer une liste de fichiers et l'affciher dans le programme en VB6

**Theocourant** · 06/07/2006, 14h48

Lut,

Je ne comprends pas ton problème. Soit plus clair

Théo

**Ribéry** · 06/07/2006, 14h56

Je voudrais que qd j'ajoute un fichier de la List 1 (a gauche) à la List2 (à droite) ca créé l'objet dans la base de données et que ca s'affiche dans le menu "liste des fichiers" (j sais pas si t as vu dans la PJ que j ai mis). D'habitude pr créer un nouvel objet, je passais par une form (SaisieNouveau) dans laquelle je chargais le controle voulu (en l'occurence Ctrl_Fichiers).
Voila j sais pas si j ai ete assez clair...

**Theocourant** · 06/07/2006, 15h21

Envoyé par Ribéry

Je voudrais que qd j'ajoute un fichier de la List 1 (a gauche) à la List2 (à droite) ca créé l'objet dans la base de données et que ca s'affiche dans le menu "liste des fichiers" (j sais pas si t as vu dans la PJ que j ai mis). D'habitude pr créer un nouvel objet, je passais par une form (SaisieNouveau) dans laquelle je chargais le controle voulu (en l'occurence Ctrl_Fichiers).
Voila j sais pas si j ai ete assez clair...

Pour la base de données, désolé mais j'y connais rien donc je peux pas t'aider à ce niveau...

Pour l'écriture dans le menu liste des fichiers, qu'est-ce que tu as déjà codé ? As quel niveau tu bloques ?

+

Théo

**Ribéry** · 06/07/2006, 15h29

J'te mets mon code tel quel. Je bloque...tout simplement...je sais meme pas a quel niveau...

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
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
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
 
Option Explicit
 
'***********************************************************************************
'*Contrôle : MiseJourFichiers                                                      *
'*Projet   : Configurateur                                                         *
'*Date     : 04/07/2006                                                            *
'*Auteur   :                                                         *
'***********************************************************************************
'*                                                                                 *
'*                                                                                 *
'*                                                                                 *
'***********************************************************************************
 
'Définition des variables locales associées aux propriétés
'*********************************************************
Event Change()
Event Supprime(CommandeSQL As String, Numéro As Long)
Event Précédent(Numéro As Long)
Event Suivant(Numéro As Long)
Event ModifFichiers(TypeModule As ListeTypeObjet, Action As ActionListeFichiers)
 
'Définition des variables locales associées aux propriétés
'*********************************************************
Private WithEvents mvar_ObjetLié    As clsFichiers
Private mvar_ListeLiée              As ListView
 
Private mvarNom_Fichiers         As String
Private mvarNuméro              As Byte
Private mvarNouveauNuméro       As Byte
Private mvarAppareil_Fichiers   As New clsAppareil
Private mvarAncien_Appareil     As New clsAppareil
 
 
 
Private mModification           As Boolean
 
 
Private m_Objet             As Object
Private m_Création          As Boolean
Private m_TypeListe     As ListeTypeObjet
Private m_NuméroInfo    As Long
Dim StrScanFolderFtp As String
Dim CancelAction As Boolean
 
Public Function AddSlash(ByVal SlashStr As String) As String
'-- Ajouter un "\" dans un path
    If Len(SlashStr) = 0 Then Exit Function
    If Right$(SlashStr, 1) <> "\" Then SlashStr = SlashStr & "\"
    AddSlash = SlashStr
End Function
 
Sub WaitExecute(InetCtl As Inet)
'-- Attendre la fin d'execution d'une instruction d'un controle Inet
    While InetCtl.StillExecuting
        DoEvents
    Wend
End Sub
Public Function ScanFolderFtp(Optional FolderPath As String = "", Optional Filename As String = "", Optional SubFold As Boolean = True) As Long
'-- Fonction récursive pour l'exploration des répertoires Ftp
 
    Dim StrPath() As String
    Dim subFolders As New Collection
    Dim i As Integer
 
    With Inet1
 
 
  On Error GoTo TraiteErreur
        .Execute , "DIR "
 
        WaitExecute Inet1
        StrPath = Split(Replace(StrScanFolderFtp, "/", "\"), vbCrLf)
        For i = 0 To UBound(StrPath) - 1
            '-- Affichage dans la listbox
            If InStr(1, StrPath(i), ".\") = 0 And Len(StrPath(i)) > 0 Then
                MiseJourFichiers.List1.AddItem AddSlash(FolderPath) & StrPath(i)
 
            End If
            '-- Remplir la collection des sous-dossiers du dossier en cours
            If Right(StrPath(i), 1) = "\" And InStr(1, StrPath(i), ".\") = 0 Then
                subFolders.Add Left(StrPath(i), Len(StrPath(i)) - 1)
            End If
        Next
        MiseJourFichiers.List1.AddItem ("/")
        '-- Renvoie le nombre d'éléments du dossier en cours
        ScanFolderFtp = UBound(StrPath)
 
        '--Recherche dans les sous-dossiers
        If SubFold Then
            For i = 1 To subFolders.Count
                Debug.Print subFolders.Item(i)
                .Execute , "CD " & subFolders.Item(i)
                WaitExecute Inet1
                DoEvents
                If CancelAction Then Exit Function
                ScanFolderFtp = ScanFolderFtp + ScanFolderFtp(AddSlash(FolderPath) & subFolders.Item(i), , SubFold)
                .Execute , "CDUP"
                WaitExecute Inet1
            Next i
        End If
 
        '-- Vide la collection des sous-dossiers
        Set subFolders = Nothing
    End With
TraiteErreur:
AfficheErreur
End Function
 
Private Sub Ajouter_Click(Index As Integer)
Dim FichPres As Boolean
Dim mvarModification As Boolean
Dim i As Integer
 With mvar_ObjetLié
    FichPres = False
    If List1.ListIndex >= 0 Then
        For i = 0 To List2.ListCount - 1
            If List1.List(List1.ListIndex) = List2.List(i) Then
                FichPres = True  'Fichier présent dans la List2
            End If
        Next i
        If Not FichPres Then
            List2.AddItem List1.List(List1.ListIndex)
            List1.RemoveItem (List1.ListIndex)
            SauveModifications
            CréationModule mFichiers, mvarModification
        End If
 
    End If
End With
End Sub
 
Private Sub Annuler_Click(Index As Integer)
    Unload Me
End Sub
 
Private Sub Supprime_Click()
If List2.ListIndex >= 0 Then
  List2.RemoveItem (List2.ListIndex)
End If
End Sub
 
Private Sub Command2_Click()
mMessage.Refresh
    With Inet1
    List1.Clear
        .AccessType = icDirect
        .Protocol = icFTP
        .URL = txtURL.Text
        .UserName = txtName.Text
        .Password = txtPassword.Text
        ScanFolderFtp
        '.Execute , "CLOSE"
        WaitExecute Inet1
 
    End With
 
End Sub
 
Private Sub Form_Load()
    txtURL.Text = "ftp://
    txtName.Text = ""
    txtPassword.Text = ""
    LoadResStrings Me
    AfficheInfoFichiers
End Sub
 
Private Sub Inet1_StateChanged(ByVal State As Integer)
' Récupère la réponse du serveur à l'aide de
' la méthode GetChunk lorsque State = 12.
 
    Dim vtData As Variant    ' Variable Data.
    Select Case State
 
    Case icError    ' 11
    ' En cas d'erreur, renvoie ResponseCode et
    ' ResponseInfo.
        vtData = Inet1.ResponseCode & ":" & _
                Inet1.ResponseInfo
    Case icResponseCompleted
        Dim strData As String
        Dim bDone As Boolean: bDone = False
 
        ' Lecture du premier segment
        vtData = Inet1.GetChunk(1024, icString)
        DoEvents
 
        ' Lecture des segments suivants
        Do While Not bDone
            strData = strData & vtData
            vtData = Inet1.GetChunk(1024, icString)
            DoEvents
 
            If Len(vtData) = 0 Then
                bDone = True
            End If
        Loop
        StrScanFolderFtp = strData
    End Select
 
End Sub
 
Private Sub AfficheInfoFichiers()
 
    Dim ItemX           As ListItem
    Dim Cpte            As Integer
    Dim ListeFichiersCréés As New clsListeObjet
 
    DoEvents
 
    'Constitution de la liste des fichiers déclarés
    '**********************************************
    ListeFichiersCréés.Populate mFichiers
 
   With ListeFichiersCréés
       With ListeFichiersCréés
        If .Count <> 0 Then
            'Il y a des modules déclarés
            '***************************
            For Cpte = 1 To .Count
                List2.AddItem .Item(Cpte).Nom
 
            Next Cpte
 
        End If
    End With
       End With
End Sub
 
Private Sub AfficheErreur()
 
mMessage.Refresh
mMessage.ForeColor = vbRed
mMessage.Caption = "Tranfert FTP impossible !!"
End Sub
Private Sub AfficheErreurPassword()
    mMessage.Refresh
    mMessage.ForeColor = vbRed
    mMessage.Caption = LoadRessourceString(IDErreurPassword)
End Sub
 
Private Sub AfficheErreurUserName()
    mMessage.Refresh
    mMessage.ForeColor = vbRed
    mMessage.Caption = LoadRessourceString(IDErreurUser)
End Sub
 
Private Sub AfficheErreurURL()
    mMessage.Refresh
    mMessage.ForeColor = vbRed
    mMessage.Caption = LoadRessourceString(IDErreurURL)
End Sub
Public Property Get ObjetLié() As clsFichiers
    'Donne l'objet clsGestionFichiers lié au contrôle
    '**********************************************
    Set ObjetLié = mvar_ObjetLié
End Property
 
Public Property Set ObjetLié(ByVal New_ObjetLié As clsFichiers)
    If Ambient.UserMode = False Then Err.Raise 383
 
    'Un objet clsGestionFichiers est lié au contrôle
    '*********************************************
    If Not (New_ObjetLié Is Nothing) Then
        If Not (mvar_ObjetLié Is New_ObjetLié) Then
            'L'objet lié va changé, on sauvegarde l'ancien
            '*********************************************
            SauveModifications
        End If
    End If
 
    Set mvar_ObjetLié = New_ObjetLié
    GestionObjetLié
End Property
 
 
Public Sub SauveModifications()
    Dim Cpte        As Integer
    Dim NouveauMOD  As clsFichiers
 
    If Not (mvar_ObjetLié Is Nothing) Then
 
            With mvar_ObjetLié
                'Un objet est lié, mise à jour de ces propriétés
                '***********************************************
                .Nom = List1.List(List1.ListIndex)
                .NouveauNuméro = List2.ListCount + 1
                If .Sauve(BDDModification) Then
                    'Des modifications ont été constatées, l'objet a été sauvé,
                    'mise à jour de la liste liée
                    '**********************************************************
                    MiseJourListeLiée .Nom, .Numéro
                End If
            End With
 
    End If
End Sub
 
 
Private Sub GestionObjetLié()
    Dim mModule As clsModulesGestionDroits
 
    If Not (mvar_ObjetLié Is Nothing) Then
        With mvar_ObjetLié
            'Mise à jour de l'interface utilisateur
            'avec les informations de l'objet
            '**************************************
            List1.Text = .Nom
            List2.ListCount 1 = .Numéro
        End With
    End If
End Sub
 
 
Private Sub mvar_ObjetLié_ModifFichiers(TypeModule As ListeTypeObjet, Action As ActionListeFichiers)
    RaiseEvent ModifFichiers(TypeModule, Action)
End Sub
 
 
Private Sub UserControl_Terminate()
    'Sauvegarde des éventuelle modifications
    '***************************************
    SauveModifications
End Sub
 
Private Sub MiseJourListeLiée(Nom As String, _
                              Index As String)
    Dim ItemX   As ListItem
 
    If Not (mvar_ListeLiée Is Nothing) Then
        'Mise à jour de la liste liée
        '****************************
        On Error Resume Next
        If (mvar_ListeLiée.ListItems.Count) Then
            'Sélection de l'Item concerné
            '****************************
            Set ItemX = mvar_ListeLiée.ListItems("FICH" & mvar_ObjetLié.Numéro)
            'Mise à jour
            '***********
            ItemX.Text = Nom
        End If
    End If
End Sub
 
Private Sub CréationModule(mvarType_Fichiers As ListeTypeObjet, _
                           mvarModification As Boolean)
    Dim mvarModule      As New clsModulesGestionDroits
 
    'Création d'un nouveau module de gestion des droits
    '**************************************************
    With mvarModule
        .Nom = mvarNom_Fichiers
        .Type_Fichiers = mvarType_Fichiers
        .Index_Fichiers = mvarNouveauNuméro
        .Sauve mvarModification
    End With
    Set mvarModule = Nothing
    RaiseEvent ModifFichiers(mvarType_Fichiers, mAjout)
End Sub
Public Function InitProperties(ByVal ADO_Recordset As ADODB.Recordset, _
                               vData As Long) As Long
    Dim mOuvert As Boolean
 
    If ADO_Recordset Is Nothing Then
        'Aucun objet recordset passé en paramètre, il faut en créer un
        '*************************************************************
        mOuvert = True
        BDDProjet.CommandeText = SQL_Fichiers_par_Index
        Set ADO_Recordset = BDDProjet.ExecuteCommande(vData)
    End If
 
    With ADO_Recordset
        'Recherche du module demandé
        '***************************
        .Find ChampIndex_Fichiers & " = " & vData
        If Not .EOF Then
            'Il existe, initialisation des propriétés
            'avec les valeurs contenues dans la BDD
            '****************************************
            InitProperties = vData
 
            On Error Resume Next
            mvarNom_Fichiers = .Fields(ChampNom_Fichiers)
            mvarNuméro = .Fields(ChampIndex_Fichiers)
            mvarAppareil_Fichiers.TypeAppareil = .Fields(ChampAppareil_Fichiers)
            mvarAncien_Appareil.TypeAppareil = .Fields(ChampAppareil_Fichiers)
        Else
            'Il n'existe pas, initialisation des propriétés
            'avec des valeurs par défaut
            '**********************************************
            InitProperties = 255
            mvarAppareil_Fichiers.TypeAppareil = -1
            mvarAncien_Appareil.TypeAppareil = -1
        End If
    End With
 
    If mOuvert Then
        'Le recordset a été ouvert par la fonction, on le ferme
        'et on détruit l'objet
        '******************************************************
        ADO_Recordset.Close
    End If
End Function
 
Public Property Let Nom(ByVal vData As String)
    'Nom du fichier
    '*************
    If mvarNom_Fichiers <> vData Then
        mvarNom_Fichiers = vData
        mModification = True
    End If
End Property
 
Public Property Get Nom() As String
    Nom = mvarNom_Fichiers
End Property
 
Public Property Let Numéro(ByVal vData As Byte)
    'Index du fichier
    '****************
    mvarNuméro = vData
    mvarNouveauNuméro = vData
    InitProperties Nothing, CLng(vData)
End Property
 
Public Property Get Numéro() As Byte
    Numéro = mvarNuméro
End Property
 
Public Property Let NouveauNuméro(ByVal vData As Byte)
    'Nouvel Index du fichier
    '**********************
    If mvarNouveauNuméro <> vData Then
        mvarNouveauNuméro = vData
        mModification = True
    End If
End Property
 
Public Property Let Appareil_Type(ByVal vData As Integer)
    'Non utlisé
    '**********
    If mvarAppareil_Fichiers.TypeAppareil <> vData Then
        mvarAppareil_Fichiers.TypeAppareil = vData
        mModification = True
    End If
End Property
 
Public Property Get Appareil_Type() As Integer
    Appareil_Type = mvarAppareil_Fichiers.TypeAppareil
End Property
 
Public Property Get Appareil_Nom() As String
    'Non utilisé
    '***********
    Appareil_Nom = mvarAppareil_Fichiers.Libellé
End Property

Pour ecrire ca j me suis inspiré d'un code que j'utilise pour créer un module à partir d'un objet. Cad qu'en fait qd je crée un fichier ca crée automatiquement un module ou on pourra gérer les droits sur ce fichier. La, j'ai voulu faire le meme procédé pr créer le fichier et voila ou j'en suis....

Récupérer une liste de fichiers et l'affciher dans le programme en VB6

VB 6 et antérieur

Discussions similaires

Partager

Partager