Option Explicit
'!Thierry Pourtier : xlti@wanadoo.fr
'!http://www.veriti.net
Public Type TFileName
FFull As String
FDrive As String
FPath As String
FName As String
FBase As String
FExt As String
End Type
Public Enum eSpecialFolder
WindowsFolder = 0
SystemFolder = 1
TemporaryFolder = 2
End Enum
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Const BIF_RETURNONLYFSDIRS = 1, MAX_PATH = 260
Const CSIDL_PERSONAL = &H5, CSIDL_DESKTOPDIRECTORY = &H10
Private Declare Function FindWindow32& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem&)
Private Declare Function lstrcat& Lib "kernel32" Alias "lstrcatA" (ByVal lpString1$, ByVal lpString2$)
Private Declare Function SHBrowseForFolder& Lib "shell32" (lpbi As BrowseInfo)
Private Declare Function SHGetPathFromIDList& Lib "shell32" (ByVal pidList&, ByVal lpBuffer$)
Private Declare Function SHGetSpecialFolderLocation& Lib "shell32" (ByVal hWnd&, ByVal nFolder&, ppidl&)
Function ExistePath(ByVal P$) As Boolean
On Error GoTo fin
ExistePath = CreateObject("Scripting.FileSystemObject").FolderExists(P)
fin:
End Function
Public Function SpecFolder$(ByVal Folder&)
Dim Result&, FFound&, Pidl&, SPath$
SPath = Space$(MAX_PATH)
Result = SHGetSpecialFolderLocation(0, Folder, Pidl)
If Result = 0 Then FFound = SHGetPathFromIDList(Pidl, SPath)
If FFound Then SpecFolder = Left$(SPath, InStr(1, SPath, vbNullChar) - 1)
CoTaskMemFree Pidl
End Function
Function GetMyFiles()
GetMyFiles = SpecFolder(CSIDL_PERSONAL)
End Function
Function GetDeskTop()
GetDeskTop = SpecFolder(CSIDL_DESKTOPDIRECTORY)
End Function
Function GetTempPath$()
'!renvoie le chemin du dossier temp
On Error GoTo fin
GetTempPath = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(2)
fin:
End Function
Function GetSpecialPath$(SpecPath As eSpecialFolder)
'!renvoie le chemin d'un dossier spécial (Windows-System-Temp)
On Error GoTo fin
GetSpecialPath = CreateObject("Scripting.FileSystemObject").GetSpecialFolder(SpecPath)
fin:
End Function
Function GetFName$(ByVal PF$)
'!renvoie le nom complet d'un fichier, sans le chemin
On Error GoTo fin
GetFName = CreateObject("Scripting.FileSystemObject").GetFileName(PF)
fin:
End Function
Function GetFBase$(ByVal PF$)
'!renvoie le nom de base d'un fichier (avant le point)
On Error GoTo fin
GetFBase = CreateObject("Scripting.FileSystemObject").GetBaseName(PF)
fin:
End Function
Function GetFExt$(ByVal PF$)
'!renvoie l'extension d'un nom de fichier (après le point)
On Error GoTo fin
GetFExt = CreateObject("Scripting.FileSystemObject").GetExtensionName(PF)
fin:
End Function
Function GetFPath$(ByVal PF$)
'!renvoie le chemin complet d'un fichier
On Error GoTo fin
GetFPath = CreateObject("Scripting.FileSystemObject").GetParentFolderName(PF)
fin:
End Function
Function GetFDrive$(ByVal PF$)
'!renvoie le lecteur d'un fichier
On Error GoTo fin
GetFDrive = CreateObject("Scripting.FileSystemObject").GetDriveName(PF)
fin:
End Function
Function BuildPath(ByVal PathF$, ByVal FileF$)
'!construit un nom de fichier à partir du chemin et du nom
On Error GoTo fin
BuildPath = CreateObject("Scripting.FileSystemObject").BuildPath(PathF, FileF)
fin:
End Function
Function GetFileInfo(ByVal PF$) As TFileName
'!renvoie en une seule fois toutes les infos d'un nom de fichier
Dim Fso As Object
On Error GoTo fin
Set Fso = CreateObject("Scripting.FileSystemObject")
With GetFileInfo
.FFull = PF
.FPath = Fso.GetParentFolderName(PF)
.FDrive = Fso.GetDriveName(PF)
.FName = Fso.GetFileName(PF)
.FBase = Fso.GetBaseName(PF)
.FExt = Fso.GetExtensionName(PF)
End With
fin:
End Function
Function BrowseForFolder$(ByVal Capt$)
Dim nNull%, lpIDList&, Result&, hWnd&
Dim SPath$, Msg$, BInf As BrowseInfo
Msg = "Sélectionner le dossier de destination par défaut : "
hWnd = FindWindow32(vbNullString, Capt)
BInf.hWndOwner = hWnd
BInf.lpszTitle = lstrcat(Msg, "")
BInf.ulFlags = BIF_RETURNONLYFSDIRS
lpIDList = SHBrowseForFolder(BInf)
If lpIDList Then
BrowseForFolder = Space$(MAX_PATH)
Result = SHGetPathFromIDList(lpIDList, BrowseForFolder)
CoTaskMemFree lpIDList
nNull = InStr(BrowseForFolder, vbNullChar)
If nNull Then BrowseForFolder = Left$(BrowseForFolder, nNull - 1)
End If
End Function