Private Declare Function OpenFile Lib "Kernel32" (ByVal lpFilaName As String, _
lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long
Const OFS_MAXPATHNAME = 128
Const OF_EXIST = &H4000
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Function FileExists(FName As String) As Boolean
Dim isThere As Long
Dim OfSt As OFSTRUCT
isThere = OpenFile(FName, OfSt, OF_EXIST)
If isThere = 1 Then
FileExists = True
Else
FileExists = False
End If
End Function
|
Declare Function GetWindowsDirectory Lib "Kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetWindowsSystemDirectory Lib "Kernel32" Alias "GetSystemDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As Long) As Long
Function WinDirs(sDirNameNeeded As String) As String
On Error GoTo WinDirsError
Dim sBuffer As String
Dim iSize As Integer
Dim iResult As Integer
iSize = 256
sBuffer = Space$(iSize)
Select Case sDirNameNeeded
Case "WindowsDirectory"
iResult = GetWindowsDirectory(sBuffer, iSize)
Case "WindowsSystemDirectory"
iResult = GetWindowsSystemDirectory(sBuffer, iSize)
End Select
WinDirs = Left$(sBuffer, iResult)
Exit Function
WinDirsError:
If Err Then
' Process Error
End If
End Function
|
Private Declare Function GetComputerNameA Lib "kernel32" _
(ByVal lpBuffer As String, nSize As Long) As Long
Public Function GetMachineName() As String
Dim sBuffer As String * 255
If GetComputerNameA(sBuffer, 255&) <> 0 Then
GetMachineName = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
Else
GetMachiineName = "(Not Known)"
End If
End Function
|
Private Declare Function WNetGetUserA Lib "mpr" _
(ByVal lpname As String, ByVal lpUserName As String, lpnLength As Long) As Long
Function GetUser() As String
Dim sUserNameBuff As String * 255
sUserNameBuff = Space(255)
Call WNetGetUserA(vbNullString, sUserNameBuff, 255&)
GetUser = Left$(sUserNameBuff, InStr(sUserNameBuff, vbNullChar) - 1)
End Function
|
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
Const MAX_PATH = 260
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" _
(ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" _
(lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
(ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Sub Form_Load()
Dim iNull As Integer
Dim lpIDList As Long
Dim lResult As Long
Dim sPath As String
Dim udtBI As BrowseInfo
With udtBI
'Set the owner window
.hWndOwner = Me.hWnd
'lstrcat appends the two strings and returns the memory address
.lpszTitle = lstrcat("C:\", "")
'Return only if the user selected a directory
.ulFlags = BIF_RETURNONLYFSDIRS
End With
'Show the 'Browse for folder' dialog
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
'Get the path from the IDList
SHGetPathFromIDList lpIDList, sPath
'free the block of memory
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
MsgBox sPath
End Sub
|
Public Function GetLongPath(InPath As String) As String
' GetLongPath() function returns the longpath version of a
' filepath or dirpath that is formatted in the 8.3 shortpath format.
' EXAMPLE:
' Debug.Print GetLongPath("C:\Progra~1\Common~1\micros~1\webser~1")
' This will print:
' C:\Program Files\Common Files\Microsoft Shared\Web Server Extensions
'
' NOTE: Reference required to Microsoft Scripting Runtime (Scrrun.dll)
Dim fso As FileSystemObject
Dim fold As Folder
Dim fil As File
Dim S As String
Dim i As Integer
Dim j As Integer
Dim drv As String
Dim tmp As String
Dim SS As String
' get the trimmed form of Path
S = Trim$(InPath)
' receiving buffer
drv = String(260, 0)
On Error Resume Next
' get buffer to drv, len to i
i = GetLongPathName(S, drv, 260)
' not win98/ME/2000
If Err.Number = 0 Then
' return path if no error
GetLongPath = Left$(drv, i)
Exit Function
End If
On Error GoTo 0
' WIN NT4.0/95 or below, so do it with an FSO
' blank in case not existing
drv = ""
' file/dir exist
If Len(Dir(S)) Or Len(Dir(S, vbDirectory)) Then
' init to full path
drv = S
'
' check for short stuff existing
'
' short stuff in there?
If InStr(1, S, "~") Then
' yes to yank short path
drv = ""
' set up pathing object
Set fso = New FileSystemObject
' UNC path ?
If Left$(S, 2) = "\\" Then
' yes, skip device name
i = InStr(3, S, "\")
If i Then
' then skip drive name
j = InStr(i + 1, S, "\")
If j Then i = j
End If
Else
' else just skip drive
i = InStr(3, S, "\")
End If
' drivepath specified
If i Then
' get drive
drv = Left$(S, i)
' get stuff after
S = Mid$(S, i + 1)
End If
'
' step through directory data
'
' a subdir path
i = InStr(i + 1, S, "\")
Do While i
' yes, get subdir name
tmp = LCase$(Left$(S, i - 1))
' short name ?
j = InStr(tmp, "~")
' yes, find full name
If j Then
SS = Dir(drv & Left$(tmp, j - 1) & "*", vbDirectory)
Do While Len(SS)
' get folder for long path
Set fold = fso.GetFolder(drv & SS)
' found short version
If LCase$(fold.ShortName) = tmp Then Exit Do
' else get next
SS = Dir()
Loop
Else
' not short so keep full name
SS = tmp
End If
' set new base path
drv = drv & SS & "\"
' trim off prev dir
S = Mid$(S, i + 1)
' check for another
i = InStr(1, S, "\")
Loop
'
' handle stuff left over
'
If Len(S) Then
'last item short?
j = InStr(1, S, "~")
' yes
If j Then
SS = Dir(drv & Left$(S, j - 1) & "*", vbDirectory)
'was a directory
If Len(SS) Then
' get full path
Do While Len(SS)
Set fold = fso.GetFolder(drv & SS)
If LCase$(fold.ShortName) = S Then Exit Do
' never blank unless it's a file
SS = Dir()
Loop
End If
' file ?
If Len(SS) = 0 Then
' yes, check matching files
SS = Dir(drv & Left$(S, j - 1) & "*")
Do While Len(SS)
' check for matching shortname
Set fil = fso.GetFile(drv & SS)
If LCase$(fil.ShortName) = S Then Exit Do
' else check next
SS = Dir()
Loop
End If
Else
' keep full name if not short
SS = S
End If
End If
' build full long path
If Len(SS) Then drv = drv & SS
' remove object
Set fso = Nothing
End If
End If
' return result
GetLongPath = drv
End Function
|
