唉，给你写一个凑合着用吧。标准点的封装（比如说按comdlg32.ocx或.net的windowsforms中的风格尽量写完整）就不是一时半会能弄出来的了。
调用：
Private Sub Command1_Click()
TestVBGetOpenFileName
End Sub
Private Sub TestVBGetOpenFileName()
Dim bResult As Boolean, sFilename As String
bResult = VBGetOpenFileName(sFilename, "打开文件", True, True)
If (bResult) Then
'MsgBox Join(Split(sFilename, vbNullChar), vbCrLf) '内置的MsgBox不支持ansi
MessageBox Me.hWnd, Join(Split(sFilename, vbNullChar), vbCrLf), Me.Caption, vbOKOnly
End If
End Sub
封装的模块：
Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameW" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function MessageBoxW Lib "user32" (ByVal hWnd As Long, ByVal lpText As Long, _
ByVal lpCaption As Long, ByVal wType As Long) As Long
Private Const MAX_PATH = 4096
Private Const MAX_FILE = 260
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As Long
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As Long
nMaxFile As Long
lpstrFileTitle As Long
nMaxFileTitle As Long
lpstrInitialDir As Long
lpstrTitle As Long
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As Long
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Enum EOpenFile
OFN_READONLY = &H1
OFN_OVERWRITEPROMPT = &H2
OFN_HIDEREADONLY = &H4
OFN_NOCHANGEDIR = &H8
OFN_SHOWHELP = &H10
OFN_ENABLEHOOK = &H20
OFN_ENABLETEMPLATE = &H40
OFN_ENABLETEMPLATEHANDLE = &H80
OFN_NOVALIDATE = &H100
OFN_ALLOWMULTISELECT = &H200
OFN_EXTENSIONDIFFERENT = &H400
OFN_PATHMUSTEXIST = &H800
OFN_FILEMUSTEXIST = &H1000
OFN_CREATEPROMPT = &H2000
OFN_SHAREAWARE = &H4000
OFN_NOREADONLYRETURN = &H8000
OFN_NOTESTFILECREATE = &H10000
OFN_NONETWORKBUTTON = &H20000
OFN_NOLONGNAMES = &H40000
OFN_EXPLORER = &H80000 '它使用类似资源管理器的打开一个文件的对话框模板。
OFN_NODEREFERENCELINKS = &H100000
OFN_LONGNAMES = &H200000
End Enum
' Common dialog errors
Private Declare Function CommDlgExtendedError Lib "COMDLG32" () As Long
Public Enum EDialogError
CDERR_DIALOGFAILURE = &HFFFF
CDERR_GENERALCODES = &H0
CDERR_STRUCTSIZE = &H1
CDERR_INITIALIZATION = &H2
CDERR_NOTEMPLATE = &H3
CDERR_NOHINSTANCE = &H4
CDERR_LOADSTRFAILURE = &H5
CDERR_FINDRESFAILURE = &H6
CDERR_LOADRESFAILURE = &H7
CDERR_LOCKRESFAILURE = &H8
CDERR_MEMALLOCFAILURE = &H9
CDERR_MEMLOCKFAILURE = &HA
CDERR_NOHOOK = &HB
CDERR_REGISTERMSGFAIL = &HC
PDERR_PRINTERCODES = &H1000
PDERR_SETUPFAILURE = &H1001
PDERR_PARSEFAILURE = &H1002
PDERR_RETDEFFAILURE = &H1003
PDERR_LOADDRVFAILURE = &H1004
PDERR_GETDEVMODEFAIL = &H1005
PDERR_INITFAILURE = &H1006
PDERR_NODEVICES = &H1007
PDERR_NODEFAULTPRN = &H1008
PDERR_DNDMMISMATCH = &H1009
PDERR_CREATEICFAILURE = &H100A
PDERR_PRINTERNOTFOUND = &H100B
PDERR_DEFAULTDIFFERENT = &H100C
CFERR_CHOOSEFONTCODES = &H2000
CFERR_NOFONTS = &H2001
CFERR_MAXLESSTHANMIN = &H2002
FNERR_FILENAMECODES = &H3000
FNERR_SUBCLASSFAILURE = &H3001
FNERR_INVALIDFILENAME = &H3002
FNERR_BUFFERTOOSMALL = &H3003
CCERR_CHOOSECOLORCODES = &H5000
End Enum
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileW" (lpExistingFileName As Any, ByVal lpNewFileName As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Function VBGetOpenFileName(Filename As String, _
Optional FileTitle As String, _
Optional FileMustExist As Boolean = True, _
Optional MultiSelect As Boolean = False, _
Optional ReadOnly As Boolean = False, _
Optional HideReadOnly As Boolean = False, _
Optional Filter As String = "All (*.*)| *.*", _
Optional FilterIndex As Long = 1, _
Optional InitDir As String, _
Optional DlgTitle As String, _
Optional DefaultExt As String, _
Optional Owner As Long = -1, _
Optional flags As Long = 0) As Boolean
Dim opfile As OPENFILENAME, s As String, afFlags As Long, lApiReturn As Long, lExtendedError As Long
lApiReturn = 0
lExtendedError = 0
With opfile
.lStructSize = Len(opfile)
' Add in specific flags and strip out non-VB flags
.flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
(-MultiSelect * OFN_ALLOWMULTISELECT) Or _
(-ReadOnly * OFN_READONLY) Or _
(OFN_EXPLORER) Or _
(-HideReadOnly * OFN_HIDEREADONLY) Or _
(flags And CLng(Not (OFN_ENABLEHOOK Or _
OFN_ENABLETEMPLATE)))
' Owner can take handle of owning window
If Owner <> -1 Then .hwndOwner = Owner
' InitDir can take initial directory string
.lpstrInitialDir = StrPtr(InitDir)
' DefaultExt can take default extension
.lpstrDefExt = StrPtr(DefaultExt)
' DlgTitle can take dialog box title
.lpstrTitle = StrPtr(DlgTitle)
' To make Windows-style filter, replace | and : with nulls
Dim ch As String, i As Integer
For i = 1 To Len(Filter)
ch = Mid$(Filter, i, 1)
If ch = "|" Or ch = ":" Then
s = s & vbNullChar
Else
s = s & ch
End If
Next
' Put double null at end
s = s & vbNullChar & vbNullChar
.lpstrFilter = StrPtr(s)
.nFilterIndex = FilterIndex
' Pad file and file title buffers to maximum path
Filename = Filename & String$(MAX_PATH - Len(Filename), 32)
.lpstrFile = StrPtr(Filename)
.nMaxFile = MAX_PATH
s = FileTitle & String$(MAX_FILE - Len(FileTitle), 0)
.lpstrFileTitle = StrPtr(s)
.nMaxFileTitle = MAX_FILE
' All other fields set to zero
lApiReturn = GetOpenFileName(opfile)
Select Case lApiReturn
Case 1
' Success
VBGetOpenFileName = True
Filename = Str2ZeroToStr(Filename)
'FileTitle = StrZToStr(.lpstrFileTitle)
flags = .flags
' Return the filter index
FilterIndex = .nFilterIndex
' Look up the filter the user selected and return that
'Filter = FilterLookup(.lpstrFilter, FilterIndex)
If (.flags And OFN_READONLY) Then ReadOnly = True
Case 0
' Cancelled
VBGetOpenFileName = False
Filename = ""
FileTitle = ""
flags = 0
FilterIndex = -1
Filter = ""
Case Else
' Extended error
lExtendedError = CommDlgExtendedError()
VBGetOpenFileName = False
Filename = ""
FileTitle = ""
flags = 0
FilterIndex = -1
Filter = ""
End Select
End With
End Function
Public Function StrZToStr(s As String) As String
StrZToStr = Left$(s, lstrlen(StrPtr(s)))
End Function
'---------------------------------------------------------------------------------------
' 过程名 : Str2ZeroToStr
' 时间 : 2013/7/26
' 作者 : 杨过.网狐.cn(csdn bcrun)
' 功能 : 将有效值部分以2个连续空格结束的字符串的有效部分提取出来
' 输入输出 :
' 说明 :
' 备注 : 星辰设计室VB一群:283362041,星辰学园BASIC辅导群:289219875
'---------------------------------------------------------------------------------------
Public Function Str2ZeroToStr(s As String) As String
Str2ZeroToStr = s
Dim iPos As Long
iPos = InStr(1, Str2ZeroToStr, vbNullChar & vbNullChar)
If (iPos > 0) Then
Str2ZeroToStr = Left$(Str2ZeroToStr, iPos - 1)
End If
End Function
Private Function FilterLookup(ByVal sFilters As String, ByVal iCur As Long) As String
Dim iStart As Long, iEnd As Long, s As String
iStart = 1
If sFilters = "" Then Exit Function
Do
' Cut out both parts marked by null character
iEnd = InStr(iStart, sFilters, vbNullChar)
If iEnd = 0 Then Exit Function
iEnd = InStr(iEnd + 1, sFilters, vbNullChar)
If iEnd Then
s = Mid$(sFilters, iStart, iEnd - iStart)
Else
s = Mid$(sFilters, iStart)
End If
iStart = iEnd + 1
If iCur = 1 Then
FilterLookup = s
Exit Function
End If
iCur = iCur - 1
Loop While iCur
End Function
Public Function MessageBox(ByVal hWnd As Long, ByVal lpText As String, _
ByVal lpCaption As String, ByVal wType As Long) As Long
MessageBox = MessageBoxW(hWnd, StrPtr(lpText), StrPtr(lpCaption), wType)
End Function
京公网安备 11010802041100号 | 京ICP备19059560号-4 | PHP1.CN 第一PHP社区 版权所有