|
|
发表于 2011-12-1 18:43:00
|
显示全部楼层
从开始的一无所知，到现在的基本成型，花费了我不少时间，也让我收获颇丰。
贴上偶的源码（也有参考别人的）：
Option Explicit
'以下为调用浏览文件夹窗口的API
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
'定义类(用于浏览文件夹窗口)
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
'常量
Const MAX_PATH = 260
Const MAXDWORD = &HFFFF
Const INVALID_HANDLE_VALUE = -1
Const FILE_ATTRIBUTE_ARCHIVE = &H20
Const FILE_ATTRIBUTE_DIRECTORY = &H10
Const FILE_ATTRIBUTE_HIDDEN = &H2
Const FILE_ATTRIBUTE_NORMAL = &H80
Const FILE_ATTRIBUTE_READONLY = &H1
Const FILE_ATTRIBUTE_SYSTEM = &H4
Const FILE_ATTRIBUTE_TEMPORARY = &H100
Const BIF_RETURNONLYFSDIRS = 1
Private Type filetime
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Dim lsttime As Date
Dim begintime As Date
Dim i As Integer '多页选择控制
Dim cout As Integer '记录搜索到的文件数量
Dim srchblname As String '要搜索的块名
Dim heigh As Variant '获取图纸大小
Dim width As Variant
Private Sub command1_Click()
Dim namestr As String
Dim pathname As String
On Error Resume Next
List1.Clear
srchblname = text3.Text '获取要搜索块字符
heigh = Text5.Text '获取图纸大小
width = Text4.Text
If Text1.Text = "" Then
MsgBox "没有选择搜索范围"
Exit Sub
End If
pathname = Text1.Text & "\"
namestr = Dir(pathname & "*.dwg") '获取文件名
'控制搜索条件选择
Select Case i
Case 0: Call Page_FileName(namestr, pathname)
Case 1: Call Page_BlockName(namestr, pathname)
Case 3: Call Page_DrawingSize(namestr, pathname)
Case 4: Call Page_Date(namestr, pathname)
End Select
End Sub
Private Sub Page_DrawingSize(namestr As String, pathname As String)
Dim h1 As Single
Dim w1 As Single
cout = 0
On Error Resume Next
Do While namestr ""
Dim fs As New AcadDocument
Set fs = ThisDrawing.Application.Documents.Open(pathname & namestr, 1)
w1 = fs.width
h1 = fs.Height
If w1 = width And h1 = heigh Then
List1.AddItem pathname & namestr
cout = cout + 1
End If
fs.Close (pathname & namestr)
namestr = Dir
Loop
Label5.Caption = "找到" & cout & "个文件"
End Sub
Private Sub OpenFile(pathX As String)
ThisDrawing.Application.Documents.Open pathX
Label5.Caption = "文件" & pathX & "已打开"
End Sub
Private Sub Page_BlockName(namestr As String, pathname As String) '按块名搜索
Dim bakname As String
Dim juged As Boolean
cout = 0
On Error Resume Next
If text3.Text = "" Then
MsgBox "没有选择搜索条件"
Exit Sub
End If
Do While namestr ""
Dim fs As New AcadDocument
Dim blockobject As AcadBlock
Set fs = ThisDrawing.Application.Documents.Open(pathname & namestr, 1)
For Each blockobject In fs.Blocks
bakname = blockobject.Name
If InStr(1, bakname, srchblname) Then
juged = True '判断文件是否含有要找的块
End If
Next
If juged = True Then
List1.AddItem pathname & namestr
cout = cout + 1
End If
fs.Close (pathname & namestr)
namestr = Dir
Loop
Label5.Caption = "找到" & cout & "个文件"
End Sub
Private Sub Page_Date(namestr As String, pathname As String) '按时间搜索
Dim filetime As Date
Dim fs As Variant
Dim f As Variant
cout = 0
On Error Resume Next
Set fs = CreateObject("Scripting.FileSystemObject") '创建FileSystemObject 对象
Do While namestr ""
Set f = fs.GetFile(pathname & namestr) '返回指定路径文件所对应的 File 对象
filetime = CDate(f.DateLastModified)
If filetime >= begintime And filetime ""
If InStr(1, namestr, searhname) Then
List1.AddItem pathname & namestr
cout = cout + 1
End If
namestr = Dir
Loop
Label5.Caption = "找到" & cout & "个文件"
End Sub
Private Sub command2_Click()
End
End Sub
Private Sub DTPicker1_Change()
begintime = CDate(Me.DTPicker1.Value) '获取日期下限
End Sub
Private Sub DTPicker2_Change()
lsttime = CDate(Me.DTPicker2.Value) '获取日期上限
End Sub
Private Sub Label2_Click()
Dim SearchPath As String, FindStr As String, findname As String
Dim FileSize As Long
Dim NumFiles As Integer, NumDirs As Integer
Dim iNull As Integer, lpIDList As Long, lResult As Long
Dim sPath As String, udtBI As BrowseInfo
'调出浏览窗口
lpIDList = SHBrowseForFolder(udtBI)
If lpIDList Then
sPath = String$(MAX_PATH, 0)
'获取路径
SHGetPathFromIDList lpIDList, sPath
'释放内存
CoTaskMemFree lpIDList
iNull = InStr(sPath, vbNullChar)
If iNull Then
sPath = Left$(sPath, iNull - 1)
End If
End If
Text1.Text = sPath
End Sub
Private Sub Label9_Click()
End Sub
Private Sub List1_Click()
End Sub
Private Sub List1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Dim path1 As String
path1 = List1.Text
If path1 "" Then
Call OpenFile(path1)
Else
MsgBox "未能获得文件路径"
End If
End Sub
Private Sub MultiPage1_Change()
i = Me.MultiPage1.Value
End Sub
Private Sub MultiPage1_Click(ByVal Index As Long)
Dim scal As Double
Dim ss As Double
'初始化时间
begintime = CDate(Me.DTPicker1.Value) '获取日期下限
lsttime = CDate(Me.DTPicker2.Value) '获取日期上限
End SubPrivate Sub UserForm_Initialize()
Me.MultiPage1.Value = 0
Label5.Caption = ""
End Sub
程序运行界面：
|
|
置顶卡
