'------------------------------------------------------------------------------
'
' Form Code
'
'------------------------------------------------------------------------------
Option Explicit
Private row As Integer, col As Integer
Private Sub CloseWindows_Click()
If TextStartRow.Text = "" Then TextStartRow = 0
If TextStartCol = "" Then TextStartCol = 0
If TextPath = "" Then TextPath = "D:\"
CloseMyDialog TextStartRow, TextStartCol
End Sub
Private Sub GetDir_Click()
If TextStartRow.Text = "" Then TextStartRow = 0
If TextStartCol = "" Then TextStartCol = 0
If TextPath = "" Then
TextPath = "D:\"
ElseIf Right(TextPath, 1) <> "\" Then
TextPath = TextPath & "\"
End If
doGetDir TextPath, Val(TextStartRow), Val(TextStartCol)
End Sub
Private Sub ShowWindows_Click()
If TextStartRow.Text = "" Then TextStartRow = 0
If TextStartCol = "" Then TextStartCol = 0
If TextPath = "" Then TextPath = "D:\"
ShowMyDialog Application.hWnd, TextStartRow, TextStartCol
End Sub
上面是Form上面的
Option Explicit
Dim MyFile, Mypath, MyName
Dim i%, j%
Dim DirPath() As String
Sub GetDir(ByVal Mypath As String, row As Integer, col As Integer)
' 显示 C:\ 目录下的名称。
' MyPath = "d:\电大\" ' 指定路径。
MyName = Dir(Mypath, vbDirectory) ' 找寻第一项。
Do While MyName <> "" ' 开始循环。
' 跳过当前的目录及上层目录。
If MyName <> "." And MyName <> ".." Then
' 使用位比较来确定 MyName 代表一目录。
If (GetAttr(Mypath & MyName) And vbDirectory) = vbDirectory Then
Cells(row + i, col) = Mypath & MyName ' 如果它是一个目录，将其名称显示出来。
ReDim Preserve DirPath(i)
DirPath(i) = Mypath & MyName & "\"
i = i + 1
End If
End If
MyName = Dir ' 查找下一个目录。
Loop
End Sub
Public Sub doGetDir(ByVal TextPath$, ByVal TextStartRow%, ByVal TextStartCol%)
j = 1
i = 1
Mypath = TextPath
GetDir Mypath, TextStartRow, TextStartCol
For j = 1 To i - 1
GetDir DirPath(j), TextStartRow, TextStartCol
Next
End Sub
'end code---------------------------------------------------
Option Explicit
Public Const OFN_ALLOWMULTISELECT As Long = &H200
Public Const OFN_CREATEPROMPT As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPLATE As Long = &H40
Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
Public Const OFN_FILEMUSTEXIST As Long = &H1000
Public Const OFN_HIDEREADONLY As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFERENCELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBUTTON As Long = &H20000
Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
Public Const OFN_NOTESTFILECREATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPROMPT As Long = &H2
Public Const OFN_PATHMUSTEXIST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTHROUGH As Long = 2
Public Const OFN_SHAREWARN As Long = 0
Public Const OFN_SHARENOWARN As Long = 1
Public Const OFN_SHOWHELP As Long = &H10
Public Const OFS_MAXPATHNAME As Long = 260
Public Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_CREATEPROMPT _
Or OFN_NODEREFERENCELINKS
Public Const OFS_FILE_SAVE_FLAGS = OFN_EXPLORER _
Or OFN_LONGNAMES _
Or OFN_OVERWRITEPROMPT _
Or OFN_HIDEREADONLY
Public Type OPENFILENAME
nStructSize As Long
hWndOwner As Long
hInstance As Long
sFilter As String
sCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
sFile As String
nMaxFile As Long
sFileTitle As String
nMaxTitle As Long
sInitialDir As String
sDialogTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
sDefFileExt As String
nCustData As Long
fnHook As Long
sTemplateName As String
End Type
Public OFN As OPENFILENAME
Public Const WM_CLOSE = &H10
Public Declare Function GetOpenFileName Lib "comdlg32" _
Alias "GetOpenFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Public Declare Function GetSaveFileName Lib "comdlg32" _
Alias "GetSaveFileNameA" _
(pOpenfilename As OPENFILENAME) As Long
Public Declare Function GetShortPathName Lib "kernel32" _
Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, _
ByVal lpszShortPath As String, _
ByVal cchBuffer As Long) As Long
Public Const WM_INITDIALOG = &H110
Private Const SW_SHOWNORMAL = 1
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Function GetParent Lib "user32" _
(ByVal hWnd As Long) As Long
Public Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hWnd As Long, _
ByVal lpString As String) As Long
Public Declare Function MoveWindow Lib "user32" _
(ByVal hWnd As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long, _
ByVal bRepaint As Long) As Long
Public Declare Function GetWindowRect Lib "user32" _
(ByVal hWnd As Long, _
lpRect As RECT) As Long
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) As Long
Public Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" _
(ByVal lpClassName As Long, _
ByVal lpWindowName As String) As Long
Public Function FARPROC(ByVal pfn As Long) As Long
FARPROC = pfn
End Function
Public Function OFNHookProc(ByVal hWnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Dim hwndParent As Long
Dim rc As RECT
Dim newLeft As Long
Dim newTop As Long
Dim dlgWidth As Long
Dim dlgHeight As Long
Dim scrWidth As Long
Dim scrHeight As Long
Select Case uMsg
Case WM_INITDIALOG
hwndParent = GetParent(hWnd)
If hwndParent <> 0 Then
Call GetWindowRect(hwndParent, rc)
dlgWidth = rc.Right - rc.Left
dlgHeight = rc.Bottom - rc.Top
Call MoveWindow(hwndParent, newLeft, newTop, dlgWidth, dlgHeight, True)
OFNHookProc = 1
End If
Case Else:
End Select
End Function
Public Sub ShowFolder(hWnd As Long, Mypath$)
Dim sFilters As String
Dim pos As Long
Dim buff As String
Dim sLongname As String
Dim sShortname As String
With OFN
.nStructSize = Len(OFN)
.hWndOwner = hWnd
.sFilter = sFilters
.nFilterIndex = 2
.sFile = Space$(1024) & vbNullChar & vbNullChar
.nMaxFile = Len(.sFile)
.sDefFileExt = "bas" & vbNullChar & vbNullChar
.sFileTitle = vbNullChar & Space$(512) & vbNullChar & vbNullChar
.nMaxTitle = Len(OFN.sFileTitle)
.sInitialDir = Mypath & vbNullChar & vbNullChar
.sDialogTitle = Mypath & vbNullChar & vbNullChar
.flags = OFS_FILE_OPEN_FLAGS Or _
OFN_ALLOWMULTISELECT Or _
OFN_EXPLORER Or _
OFN_ENABLEHOOK
.fnHook = FARPROC(AddressOf OFNHookProc)
End With
GetOpenFileName OFN
End Sub
Public Sub CloseFolder(Mypath As String)
Dim hWnd As Long
hWnd = FindWindow(0, Mypath)
Call SendMessage(hWnd, WM_CLOSE, 0&, ByVal 0&)
End Sub
Public Sub ShowMyDialog(MyhWnd As Long, TextStartRow As Integer, TextStartCol As Integer)
Dim row, col
Dim i
Dim hWnd As Long
hWnd = MyhWnd
i = 1: row = TextStartRow: col = TextStartCol
Do While Cells(i + row, col) <> ""
Shell "C:\Windows\explorer.exe " & Cells(i + row, col)
' ShowFolder hWnd, Cells(i + row, col)
' hWnd = FindWindow(0, Cells(i + row, col))
i = i + 1
Loop
End Sub
Public Sub CloseMyDialog(TextStartRow As Integer, TextStartCol As Integer)
Dim row, col
Dim i
i = 1: row = TextStartRow: col = TextStartCol
Do While Cells(i + row, col) <> ""
CloseFolder pathToName(Cells(i + row, col))
i = i + 1
Loop
End Sub
Private Function pathToName(Mypath$) As String
Dim str() As String
str = Split(Mypath, "\")
pathToName = str(UBound(str))
End Function
欢迎分享，转载请注明来源：内存溢出
微信扫一扫
支付宝扫一扫
评论列表（0条）