openFile.bas
上传用户:hyb6888
上传日期:2016-01-24
资源大小:5186k
文件大小:5k
- Attribute VB_Name = "openFile"
- Option Explicit
- Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
- Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BROWSEINFO) As Long
- Private Const BIF_RETURNONLYFSDIRS = &H1
- Private Const BIF_NEWDIALOGSTYLE = &H40
- Private Type BROWSEINFO
- hOwner As Long
- pidlRoot As Long
- pszDisplayName As String
- lpszTitle As String
- ulFlags As Long
- lpfn As Long
- lParam As Long
- iImage As Long
- End Type
- Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
- Private Type OPENFILENAME
- lStructSize As Long
- hwndOwner As Long
- hInstance As Long
- lpstrFilter As String
- lpstrCustomFilter As String
- nMaxCustFilter 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
- Private Const OFN_ALLOWMULTISELECT = &H200
- Private Const OFN_EXPLORER = &H80000
- Private Const OFN_FILEMUSTEXIST = &H1000
- Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
- Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
- Public Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
- Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
- '浏览文件夹函数
- Public Function BrowseFolder(ByVal hwnd As Long, ByVal Title As String) As String
- Dim bi As BROWSEINFO
- Dim rtn, pid As Long
- Dim path As String * 512
- Dim pos As Integer
- With bi
- .hOwner = hwnd
- .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_NEWDIALOGSTYLE
- .lpszTitle = Title
- End With
- pid = SHBrowseForFolder(bi)
- rtn = SHGetPathFromIDList(ByVal pid, ByVal path)
- If rtn Then
- pos = InStr(path, Chr(0))
- BrowseFolder = Left(path, pos - 1)
- Else
- BrowseFolder = ""
- End If
- End Function
- '不用控件实现打开文件对话框
- Public Function OpenDlg(hwnd As Long, filter As String, FilterIndex As Integer) As String
- Dim pOpenfilename As OPENFILENAME
- Dim dd As Long, FileName As String, pos As Integer
- With pOpenfilename
- .flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST
- .lpstrTitle = "(打开文件)"
- .hwndOwner = hwnd
- .hInstance = App.hInstance
- .lpstrFilter = filter
- .lpstrInitialDir = App.path
- .nFilterIndex = FilterIndex
- .lpstrFile = Space(254)
- .nMaxFile = 255
- .lpstrFileTitle = .lpstrFile
- .nMaxFileTitle = 255
- .lStructSize = Len(pOpenfilename)
- End With
- dd = GetOpenFileName(pOpenfilename)
- If dd Then
- pos = InStrRev(pOpenfilename.lpstrFile, vbNullChar)
- FileName = Left(pOpenfilename.lpstrFile, pos - 2)
- Else
- FileName = ""
- End If
- OpenDlg = FileName
- End Function
- '取得系统文件夹
- Public Function GetSystemDir() As String
- Dim nSize As Long
- Dim tmp As String
- tmp = Space$(256)
- nSize = Len(tmp)
- Call GetSystemDirectory(tmp, nSize)
- If right(TrimNull(tmp), 1) <> "" Then
- GetSystemDir = TrimNull(tmp) + ""
- Else: GetSystemDir = TrimNull(tmp)
- End If
-
- End Function
- '取得windows文件夹
- Public Function GetWinDir() As String
- Dim nSize As Long
- Dim tmp As String
- tmp = Space$(256)
- nSize = Len(tmp)
- Call GetWindowsDirectory(tmp, nSize)
-
- If right(TrimNull(tmp), 1) <> "" Then
- GetWinDir = TrimNull(tmp) + ""
- Else: GetWinDir = TrimNull(tmp)
- End If
-
- End Function
- '删除VBNullchar字符
- Private Function TrimNull(item As String)
- Dim pos As Integer
- pos = InStr(item, Chr$(0))
- If pos Then
- TrimNull = Left$(item, pos - 1)
- Else: TrimNull = item
- End If
-
- End Function
- '返回文件路径,包含""
- Public Function ExtractFilePath(ByVal FileName As String) As String
- Dim i As Integer
- i = InStrRev(FileName, "")
- ExtractFilePath = Left(FileName, i)
- End Function
- '从全路径中返回文件名,包含扩展名
- Public Function ExtractFileName(ByVal FileName As String) As String
- Dim x
- x = Split(FileName, "")
- ExtractFileName = x(UBound(x))
- End Function