'Voici le code de la form qui vous permet d'intégrer 'une fenêtre de selection de dossier à votre application. ' 'COMMENT RECUPERER CE CODE ? '1 - Enregistrez ce fichier sur votre ordinateur. '2 - Renommez le avec une extension FRM. '3 - Démarrer un nouveau projet Visual Basic* ou ouvrez un projet existant. '4 - Ajoutez le fichier à ce projet. '5 - Double-cliquez sur la form dans l'explorateur de projet pour afficher la form. ' ' '*propriété de MicroSoft ' '********************* VOICI LE CODE DE LA FORM ************************** ' VERSION 5.00 Begin VB.Form frmSelectionDossier BorderStyle = 3 'Fixed Dialog Caption = "Selection d' un dossier" ClientHeight = 4275 ClientLeft = 5595 ClientTop = 3195 ClientWidth = 3960 Icon = "frmSelectionDossier.frx":0000 LinkTopic = "Form1" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 4275 ScaleWidth = 3960 ShowInTaskbar = 0 'False StartUpPosition = 2 'CenterScreen Begin VB.CommandButton Boutons Caption = "&Nouveau" Height = 375 Index = 2 Left = 2640 TabIndex = 7 ToolTipText = "Nouveau dossier" Top = 3840 Width = 1275 End Begin VB.CommandButton Boutons Cancel = -1 'True Caption = "&Fermer" Height = 375 Index = 1 Left = 1320 TabIndex = 6 ToolTipText = "Quitter" Top = 3840 Width = 1275 End Begin VB.CommandButton Boutons Caption = "&OK" Default = -1 'True Height = 375 Index = 0 Left = 60 TabIndex = 4 ToolTipText = "Valider" Top = 3840 Width = 1215 End Begin VB.TextBox txtDossier Height = 315 Left = 780 TabIndex = 3 ToolTipText = "Dossier actif" Top = 3300 Width = 3135 End Begin VB.DriveListBox Drive1 Appearance = 0 'Flat Height = 315 Left = 60 TabIndex = 1 ToolTipText = "Liste des lecteurs" Top = 300 Width = 3855 End Begin VB.DirListBox Dir1 Height = 2565 Left = 60 TabIndex = 0 ToolTipText = "Liste des dossiers" Top = 660 Width = 3855 End Begin VB.Line Line2 BorderColor = &H00E0E0E0& X1 = 60 X2 = 3915 Y1 = 3720 Y2 = 3735 End Begin VB.Line Line1 BorderWidth = 2 X1 = 60 X2 = 3915 Y1 = 3720 Y2 = 3735 End Begin VB.Label lblInformation AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Sélectionnez un dossier:" Height = 195 Left = 60 TabIndex = 5 ToolTipText = "Sélectionnez un dossier:" Top = 60 Width = 1725 End Begin VB.Label Label1 AutoSize = -1 'True BackStyle = 0 'Transparent Caption = "Dossier:" Height = 195 Left = 60 TabIndex = 2 Top = 3420 Width = 570 End End Attribute VB_Name = "frmSelectionDossier" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option Explicit Public retour As String 'valeur renvoyer lors de la sortie de la fenetre Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long Private Sub Boutons_Click(Index As Integer) ' Select Case Index Case 0 'OK 'selection de dossier retour = Dir1.Path 'sortie Unload Me Case 1 'QUITTER retour = "" Unload Me Case 2 'NOUVEAU DOSSIER 'nouveau dossier? If txtDossier.Text = "" Then MsgBox "Saisissez un nom pour le nouveau dossier.", vbInformation, "Information" Exit Sub End If 'le nouveau dossier existe t il deja? Dim nouveau_rep$ Dim nb_rep% For nb_rep = 0 To Dir1.ListCount - 1 nouveau_rep = LCase$(NomDossier(Dir1.List(nb_rep))) If LCase$(Trim$(txtDossier.Text)) = LCase$(nouveau_rep) Then MsgBox "Impossible de créer le nouveau dossier. Celui-ci existe déja.", vbInformation, "Dossier existant..." Exit Sub End If Next nb_rep 'creation du nouveau dossier nouveau_rep = Dir1.Path If Right$(nouveau_rep, 1) <> "\" Then nouveau_rep = nouveau_rep & "\" nouveau_rep = nouveau_rep & Trim$(txtDossier.Text) If MsgBox("Êtes-vous sûr(e) de vouloir créer le nouveau dossier: " & Trim$(txtDossier.Text) & vbCrLf & "dans le dossier: " & Dir1.Path, vbQuestion + vbYesNo + vbDefaultButton1, "Nouveau dossier") = vbNo Then Exit Sub MkDir nouveau_rep Dir1.Refresh For nb_rep = 0 To Dir1.ListCount - 1 If LCase$(Dir1.List(nb_rep)) = LCase$(nouveau_rep) Then Dir1.Path = Dir1.List(nb_rep): Exit For Next nb_rep End Select ' End Sub Private Function Verif_Dossier(chemin_dossier As String) As Boolean 'permet de savoir si le repertoire voulu existe 'exemple d'appel: ok=Verif_Dossier("c:\aaaaaaaa\bbbbb") ' Dim nom As String ' If (nom = Dir(chemin_dossier, vbDirectory)) = vbEmpty Then Verif_Dossier = True Else Verif_Dossier = False End If ' End Function Private Sub Dir1_Change() txtDossier.Text = NomDossier(Dir1.List(Dir1.ListIndex)) End Sub Private Sub Dir1_Click() txtDossier.Text = NomDossier(Dir1.List(Dir1.ListIndex)) End Sub Private Sub Drive1_Change() On Error GoTo annulation Dir1.Path = Drive1.Drive txtDossier.Text = NomDossier(Dir1.List(Dir1.ListIndex)) Exit Sub 'erreur annulation: MsgBox Err.Description, vbCritical, "ERREUR..." Drive1.Drive = Dir1.Path End Sub Private Sub Form_Load() 'fenetre de selection de dossier à integrer dans votre application 'exemple d'appel de la fenetre. celle ci s'appelle frmSelectionDossier 'en appuyant sur un bouton appele Command1 et en recuperant le dossier 'selectionne dans un zone de texte nommee Text1 ' '******DEBUT DU CODE 'Private Sub Command1_Click() 'Load frmSelectionDossier 'charge la feuille en memoire 'With frmSelectionDossier 'position de la fenetre '.Top = X 'mettez ici la position en hauteur X de la fenetre '.Left = Y 'mettez ici la position en hauteur Y de la fenetre '.Show vbModal 'affiche la fenetre 'if .retour <> "" then Text1.Text = .retour 'ecrit le nom du dossier selectionne dans la zone de texte 'End With 'end sub 'voila, rien de plus simple. '********FIN DU CODE ' 'NE PAS CHANGER txtDossier.Text = NomDossier(Dir1.List(Dir1.ListIndex)) ' End Sub Private Function NomDossier(chemin As String) As String NomDossier = "" ' Dim Z% For Z = Len(chemin) To 1 Step -1 If Mid$(chemin, Z, 1) = "\" Then NomDossier = Right$(chemin, Len(chemin) - Z) Exit Function End If Next Z ' End Function Private Function CheminDossier(chemin As String) As String ' CheminDossier = "" ' Dim Z% For Z = Len(chemin) To 1 Step -1 If Mid$(chemin, Z, 1) = "\" Then CheminDossier = Left$(chemin, Z) Exit Function End If Next Z ' End Function Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) retour = "" End Sub