Les mémos

Fermer Tables

Fermer Requêtes

Fermer Formulaires

Fermer Etats

Fermer Modules

Fermer Base

Fermer Automation

Fermer Administration

Fermer Registre

Fermer String

Fermer Email CDO

Fermer Outlook

Fermer Net

Fermer Dates - Heures

Fermer Fichiers

Fermer Références

Fermer Vrac

Je débute...

Fermer La normalisation

Fermer VBA

Attention
Aucun support
par émail !

Utilisez le forum pour les questions/réponses concernant MsAccess et les codes que vous trouverez sur ce site.
Visites

   visiteurs

   visiteurs en ligne

Fichiers - Sélection de fichiers

Parcourir et Sélectionner un ou plusieurs fichiers (API)

Sélectionner et retourner le chemin de un ou plusieurs fichiers séparés par un point-virgule, dans une boîte de dialogue Fichier Ouvrir.



Public Type OpenFileName

lStructSize As Long
hwndOwner As Long
Instance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String

End Type



Public Declare Function GetOpenFileName Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OpenFileName) As Long


Public Const OFN_AllowMultiSelect = &H200
Public Const OFN_CreatePrompt = &H2000
Public Const OFN_EnableHook = &H20
Public Const OFN_EnableTemplate = &H40
Public Const OFN_EnableTemplateHandle = &H80
Public Const OFN_EXPLORER = &H80000
Public Const OFN_ExtensionDifferent = &H400
Public Const OFN_FileMustExist = &H1000
Public Const OFN_HideReadOnly = &H4
Public Const OFN_LongNames = &H200000
Public Const OFN_NoChangeDir = &H8
Public Const OFN_NoDeReferenceLinks = &H100000
Public Const OFN_NoLongNames = &H40000
Public Const OFN_NoNetWorkButton = &H20000
Public Const OFN_NoReadOnlyReturn = &H8000
Public Const OFN_NoTestFileCreate = &H10000
Public Const OFN_NoValiDate = &H100
Public Const OFN_OverWritePrompt = &H2
Public Const OFN_PathMustExist = &H800
Public Const OFN_ReadOnly = &H1
Public Const OFN_ShareAware = &H4000
Public Const OFN_ShareFallThrough = 2
Public Const OFN_ShareNoWarn = 1
Public Const OFN_ShareWarn = 0
Public Const OFN_ShowHelp = &H10


Global Dialogue As OpenFileName

Public strFiltre As String
Public strFile As String
Public strNomFile As String
Public RetVal As Long


Public Function fOpenFile(Optional strTitle As Variant, _

Optional strInitialDir As Variant, _
Optional MultiSelect As Boolean = False) _
As String


If IsMissing(strTitle) Then

strTitle = "Ouvrir..."

End If

If IsMissing(strInitialDir) Then

strInitialDir = CurDir

End If

fOpenFile = ""
strFiltre = "Fichiers Word" & Chr$­­­­­­(0) & "*.doc;*txt" & Chr$­­­­­­(0) & _
"Fichiers Access" & Chr$­­­­­­(0) & "*.mdb" & Chr$­­­­­­(0) & _
"Fichiers Excel" & Chr$­­­­­­(0) & "*.xls" & Chr$­­­­­­(0) & _
"Tous les fichiers" & Chr$­­­­­­(0) & "*.*"

With Dialogue

.lStructSize = Len(Dialogue)
.lpstrFilter = strFiltre
.lpstrFile = Space(254)
.nMaxFile = 255
.lpstrFileTitle = Space(254)
.nMaxFileTitle = 255
.lpstrInitialDir = strInitialDir
.lpstrTitle = strTitle
If MultiSelect = False Then
.flags = OFN_FileMustExist + _
OFN_HideReadOnly + _
OFN_PathMustExist
Else
.flags = OFN_FileMustExist + _
OFN_HideReadOnly + _
OFN_PathMustExist + _
OFN_AllowMultiSelect + _
OFN_LongNames + _
OFN_EXPLORER
End If

End With

RetVal = GetOpenFileName(Dialogue)

If RetVal >= 1 Then

fOpenFile = fMultiSelect(Dialogue.lpstrFile)

Else

fOpenFile = ""
Exit Function

End If

End Function


' fMultiSelect

Function fMultiSelect(ByVal strItem As String) As String

Dim strTemp As String
Dim pos As Integer
Dim TabFile() As String
Dim no As Integer

no = -1
strTemp = strItem
pos = InStr(1, strTemp, vbNullChar, vbBinaryCompare)

Do While pos > 1

If Left$­­­­­­(strTemp, pos - 1) <> "" Then
no = no + 1
ReDim Preserve TabFile(no)
TabFile(no) = Left$­­­­­­(strTemp, pos - 1)
strTemp = Right(strTemp, Len(strTemp) - Len(TabFile(no)) - 1)
pos = InStr(1, strTemp, vbNullChar, vbBinaryCompare)
End If

Loop

If Len(TabFile(0)) = 3 Then

TabFile(0) = Left(TabFile(0), 2)

End If

If UBound(TabFile) = 0 Then

fMultiSelect = TabFile(0)

Else

For no = LBound(TabFile()) + 1 To UBound(TabFile)
If fMultiSelect = "" Then
fMultiSelect = TabFile(0) & "\" & TabFile(no)
Else
fMultiSelect = fMultiSelect & ";" & TabFile(0) & "\" & TabFile(no)
End If
Next no

End If
End Function



Date de création : 02/11/2005 : 00:15
Dernière modification : 09/02/2007 : 17:40
Catégorie : Fichiers
Page lue 6854 fois


Imprimer l'article Imprimer l'article

Recherche



Lettre d'information
Pour avoir des nouvelles de ce site, inscrivez-vous à notre Newsletter.
Captcha
Recopier le code :
Au sujet de l'auteur
L'auteur qui fréquente (fréquentait) le forum microsoft.public.fr.access a eu le plaisir d'être nommé MVP Office-Access de janvier 2003 à décembre 2011.

Qui sont les MVP ?

Divers ;-)
Nous contacter

Haut