Option Compare Database
Option Explicit
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Integer, ppidl As Long) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal szPath As String) As Long
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Const MAX_LEN = 255
Const DESKTOP = &H0& '桌面
Const PROGRAMS = &H2& '程序集
Const MYDOCUMENTS = &H5& '我的文檔
Const MYFAVORITES = &H6& '收藏夾
Const STARTUP = &H7& '啟動
Const RECENT = &H8& '最近打開的文件
Const SENDTO = &H9& '發送
Const STARTMENU = &HB& '開始菜單
Const NETHOOD = &H13& '網上鄰居
Const FONTS = &H14& '字體
Const SHELLNEW = &H15& 'ShellNew
Const APPDATA = &H1A& 'Application Data
Const PRINTHOOD = &H1B& 'PrintHood
Const PAGETMP = &H20& '網頁臨時文件
Const COOKIES = &H21& 'Cookies目錄
Const HISTORY = &H22& '歷史
Function GetDirs(FName As String) As String
Dim sTmp As String * MAX_LEN '存放結果的固定長度字符串
Dim Length As Long '字符串的實際長度
Dim pidl As Long '某特殊目錄在特殊目錄列表中的位置
Select Case LCase(FName)
Case "win": '***獲得windows目錄***
Length = GetWindowsDirectory(sTmp, MAX_LEN)
GetDirs = Left(sTmp, Length)
Case "sys": '***獲得system目錄***
Length = GetSystemDirectory(sTmp, MAX_LEN)
GetDirs = Left(sTmp, Length)
Case "tmp": '***獲得temp目錄***
Length = GetTempPath(MAX_LEN, sTmp)
GetDirs = Left(sTmp, Length)
Case "desktop": '**獲得desktop目錄***
SHGetSpecialFolderLocation 0, DESKTOP, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "sendto": ' *獲得發送到目錄**
SHGetSpecialFolderLocation 0, SENDTO, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "mydoc": ' *獲得我的文檔目錄 *
SHGetSpecialFolderLocation 0, MYDOCUMENTS, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "programs": ' *獲得程序目錄 ***
SHGetSpecialFolderLocation 0, PROGRAMS, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "startup": ' *獲得啟動目錄 *****
SHGetSpecialFolderLocation 0, STARTUP, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "startmenu": ' *獲得開始菜單目錄 *
SHGetSpecialFolderLocation 0, STARTMENU, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "fav": ' *獲得收藏夾目錄 ***
SHGetSpecialFolderLocation 0, MYFAVORITES, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "recent": ' **獲得最後打開的文件目錄 ***
SHGetSpecialFolderLocation 0, RECENT, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "network": ' *獲得網上鄰居目錄 *
SHGetSpecialFolderLocation 0, NETHOOD, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "fonts": ' *獲得字體目錄 **
SHGetSpecialFolderLocation 0, FONTS, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "cookies": ' *獲得cookies目錄 **
SHGetSpecialFolderLocation 0, COOKIES, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "history": ' *獲得歷史目錄 **
SHGetSpecialFolderLocation 0, HISTORY, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "pagetmp": ' ***獲得網頁臨時文件目錄 ***
SHGetSpecialFolderLocation 0, PAGETMP, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "shellnew": ' *ShellNew *
SHGetSpecialFolderLocation 0, SHELLNEW, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "appdata": ' ***Application Data目錄 *
SHGetSpecialFolderLocation 0, APPDATA, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
Case "printhood": ' *PrintHood *
SHGetSpecialFolderLocation 0, PRINTHOOD, pidl
SHGetPathFromIDList pidl, sTmp
GetDirs = Left(sTmp, InStr(sTmp, Chr(0)) - 1)
End Select
End Function
Function CopyTFile(SPathName As String, TPathName As String) As Boolean
CopyFile SPathName, TPathName, 0
CopyTFile = True
End Function
Function FindTFile(TPath As String, Tname As String) As Boolean
FindTFile = (Dir(TPath & "\" & Tname) <> "")
End Function
Function CurDir() As String
CurDir = CurrentProject.Path
End Function
