如何批处理读取文件夹下所有图纸中块？

xin-ge

例如：D:\SAMPLE

文件夹中有50张图纸
我需要读取每张图纸中的名位a-bc的块，统计数量

想用批处理
求一批处理就代码？

xin-ge

从开始的一无所知，到现在的基本成型，花费了我不少时间，也让我收获颇丰。
贴上偶的源码（也有参考别人的）：
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 <= lsttime Then
           List1.AddItem pathname & namestr
           cout = cout + 1
        End If
    namestr = Dir
    Loop
Label5.Caption = "找到" & cout & "个文件"
End Sub
Private Sub Page_FileName(namestr As String, pathname As String) '按文件名搜索
Dim searhname As String
cout = 0
On Error Resume Next
searhname = Text2.Text

If Text2.Text = "" Then
    MsgBox "没有选择搜索条件"
    Exit Sub
End If

Do While namestr <> ""
    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 Sub



Private Sub UserForm_Initialize()
Me.MultiPage1.Value = 0
Label5.Caption = ""

End Sub






程序运行界面：

xin-ge

请大侠根据上面的代码 帮改改!!

xin-ge

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

crazylsp

50张图纸都打开，然后用你上面的模块代码对每一张图纸变活动文档后找了数目。再个数求和。

sjl_fyl

学习