text2的MultiLine属性为真、Text2.ScrollBars = 2
文件包括子拍隐源目录里的
如果不想包括
删除
If strTemp <>"." And strTemp <携基>".." Then
'It's a normal dir: let's dive straight
'into it...
Call FindFiles(strRootFolder &strTemp, strFolder, strFile, colFilesFound)
End If
这一段
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
Const BIF_RETURNONLYFSDIRS = &H1
Private pidl As Long
Private Declare Function _
SHGetPathFromIDList _
Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal _
pszPath As String) As Long
Private Declare Function _
SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BROWSEINFO) As Long
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Public Sub FindFiles(strRootFolder As String, strFolder As String, strFile As String, colFilesFound As Collection)
Dim lngSearchHandle As Long
Dim udtFindData As WIN32_FIND_DATA
Dim strTemp As String, lngRet As Long
'Check that folder name ends with "\"
If Right$(strRootFolder, 1) <>"\" Then strRootFolder = strRootFolder &"\"
'Find first file/folder in current folder
lngSearchHandle = FindFirstFile(strRootFolder &"*", udtFindData)
'Check that we received a valid handle
If lngSearchHandle = INVALID_HANDLE_VALUE Then Exit Sub
lngRet = 1
Do While lngRet <>0
'Trim nulls from filename
strTemp = TrimNulls(udtFindData.cFileName)
If (udtFindData.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) = FILE_ATTRIBUTE_DIRECTORY Then
'It's a dir - make sure it isn't . or .. dirs
'删除下面的内容可以不包括子目录
'--------------删除开始
If strTemp <>"." And strTemp <>".." Then
'It's a normal dir: let's dive straight
'into it...
Call FindFiles(strRootFolder &strTemp, strFolder, strFile, colFilesFound)
End If
'--------------删除结束
Else
'It's a file. First check if the current folder matches
'the folder path in strFolder
If (strRootFolder Like strFolder) Then
'Folder matches, what about file?
If (strTemp Like strFile) Then
'Found one!
colFilesFound.Add strRootFolder &strTemp
End If
End If
End If
'Get next file/folder
lngRet = FindNextFile(lngSearchHandle, udtFindData)
Loop
'Close find handle
Call FindClose(lngSearchHandle)
End Sub
Public Function TrimNulls(strString As String) As String
Dim l As Long
l = InStr(1, strString, Chr(0))
If l = 1 Then
TrimNulls = ""
ElseIf l >0 Then
TrimNulls = Left$(strString, l - 1)
Else
TrimNulls = strString
End If
End Function
Private Sub Command2_Click()
Dim i As Long
Dim con As New Collection
Dim a() As String
'List1.Visible = False
'List1.Clear
DoEvents
FindFiles Text1.Text, "*", "*.*", con '查找excel文件
Text2.Text = ""
For i = 1 To con.Count
t1 = con.Item(i)
t2 = InStrRev(t1, "\") + 1
t3 = Mid(con.Item(i), t2)
'
Text2.Text = Text2.Text &t3 &vbCrLf
Next
Set con = Nothing
End Sub
Private Sub Command1_Click()
Dim bi As BROWSEINFO
Dim r As Long
Dim pidl As Long
Dim path As String
Dim pos As Integer
'句柄
bi.hOwner = Me.hWnd
'展开根目录
bi.pidlRoot = 0&
'列表框标题
bi.lpszTitle = "请选择路径:"
'规定只能选择文件夹,其他无效
bi.ulFlags = BIF_RETURNONLYFSDIRS
'调用API函数显示列表框
pidl = SHBrowseForFolder(bi)
'利用API函数获取返回的路径
path = Space$(512)
r = SHGetPathFromIDList(ByVal pidl&, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
Text1.Text = Left(path, pos - 1)
Else: Text1.Text = ""
End If
End Sub
Private Sub Form_Load()
Text1.Text = App.path
Command1.Caption = "浏览"
Command2.Caption = "整理"
End Sub
'调试完成
Private Sub Command1_Click()Dim filename As String
filename = App.Path &"\" &Text1 &".txt" '创建的文件格式.
If Dir(filename) = "" Then '判断搭帆姿文件是否存在,不存在就创建,存在就不创建轿枣
Open filename For Append As #1
Close #1
MsgBox "创建成功。", vbInformation, "成功。"
Else
MsgBox "文件已存在.", vbInformation, "已知绝存在在文件."
End If
End Sub
添加一个Dirlistbox,Textbox,一个按钮,一个组合框...按钮的单击事件如下
Private Sub Command1_Click()
Dim i As Integer
Dim b As Integer
Dim a As String
a = Text1.Text
Dir1.Path = a
b = Len(a)
Combo1.Clear
For i = 0 To Dir1.ListCount - 1
Combo1.AddItem (Mid(Dir1.List(i), b + 1))
Next
End Sub
运行时候,在TextBox里输入文件路径,如 C:\windows\ 这里路径后面把"\"要加上,然后,单击按钮,再查看组合框,就可以看到windows目录下了。。。
以上程序在我的机子(XP,SP2版,VB6.0企业版)上测试通过
欢迎分享,转载请注明来源:内存溢出
评论列表(0条)