|
|
[code]
很多材料表的内容相同，只是更改极个别数据后材料重量又要重新计算。
利用handle的特性，将材料的内容先移到excel中，经过excel的重新计算，再返回到保持原有其原有的格式。
Function AutoCadConnectExcel(InputSheetName As String) As Object
Dim xlApp As Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
Set AutoCadConnectExcel = xlApp.ActiveWorkbook.Sheets(InputSheetName)
End Function
Sub HandleReadText()
Set gg = AutoCadConnectExcel("Sheet3")
gg.Range("a:z").ClearContents
Dim Ent As AcadEntity, textObj As AcadText
ii = 1: jj = 0
For Each Ent In ThisDrawing.ModelSpace
Select Case Ent.ObjectName
Case "AcDbText"
Set textObj = Ent
With textObj
gg.cells(ii, jj + 1) = .ObjectID
gg.cells(ii, jj + 2) = "'" & .TextString
gg.cells(ii, jj + 3) = Round(.insertionPoint(0), 3)
gg.cells(ii, jj + 4) = Round(.insertionPoint(1), 3)
gg.cells(ii, jj + 5) = Round(.insertionPoint(2), 3)
'gg.cells(ii, jj + 2) = .TextString
ii = ii + 1
End With
End Select
Next Ent
End Sub
Function RemoveOverlap(ByRef Ary)
On Error Resume Next
Dim i As Long
Dim colTmp As New Collection
For i = 0 To UBound(Ary) - 1
colTmp.Add Ary(i), "K" & Ary(i)
Next
Dim aryTmp() As String
ReDim aryTmp(colTmp.Count - 1) As String
For i = 0 To colTmp.Count - 1
aryTmp(i) = colTmp.Item(i + 1)
Next
Set colTmp = Nothing
RemoveOverlap = aryTmp
End Function
'主程序
Sub ll()
Dim xm(1000) As Double, xm1(1000) As Double, TextArray(10000) As String, TextInsertPoint(10000, 2)
Dim HandleArray(10000) As String
Dim tt As AcadText, ll As AcadLine, Ent As AcadEntity
xm_i = 0: xm1_i = 0: tt_i = 0
''
Dim x1 As Double, y1 As Double
'ReDim xm(1000) As Double, xm1(1000) As Long
For Each Ent In ThisDrawing.ModelSpace
Select Case Ent.ObjectName
Case "AcDbLine"
Set ll = Ent
Select Case ll.Layer
Case "零件表格竖线"
'ReDim xm(xm_i) As Double
xm(xm_i) = Round(ll.EndPoint(0), 0)
'Debug.Print xm_i, xm(xm_i), Round(ll.EndPoint(0), 3)
xm_i = xm_i + 1
Case "零件表格横线"
'ReDim xm1(xm1_i) As Double
xm1(xm1_i) = Round(ll.EndPoint(1), 0)
xm1_i = xm1_i + 1
End Select
Case "AcDbText"
Set tt = Ent
If tt.Layer = "零件表格文本" Then
TextInsertPoint(tt_i, 0) = tt.insertionPoint(0)
TextInsertPoint(tt_i, 1) = tt.insertionPoint(1)
TextArray(tt_i) = tt.TextString
HandleArray(tt_i) = tt.ObjectID
tt_i = tt_i + 1
End If
End Select
Next Ent
MM = RemoveOverlap(xm1)
xx = Bubble_Sort(MM)
MM = RemoveOverlap(xm)
yy = Bubble_Sort(MM)
Dim gg, ggg
ReDim gg(UBound(xx) - 2, UBound(yy) - 2), ggg(UBound(xx) - 2, UBound(yy) - 2)
For kk = 0 To tt_i - 1
x1 = TextInsertPoint(kk, 1)
For ii = 1 To UBound(xx) - 1
If x1 > xx(ii) And x1 yy(jj) And y1 Ary(j) Then
Swap Ary(i), Ary(j)
End If
Next
Next
Bubble_Sort = Ary
End Function
Function Swap(a, b)
Dim tmp
tmp = a
a = b
b = tmp
End Function--------------------------------------------------------
Function CAdToText(InputFileName)
Dim LineData As AcadLine, ArcData As AcadArc
Close #1
Open InputFileName For Output As #1
Write #1, "m1", "m2", "m3", "m4", "m5", "m6", "m7", "m8", "m9", "m10", "m11", "m12"
Dim Ent As AcadEntity
Dim lineObj As AcadLine, textObj As AcadText
For Each Ent In ThisDrawing.ModelSpace
m1 = Ent.ObjectName
m2 = Ent.ObjectID
m3 = Ent.Layer
Select Case Ent.ObjectName
Case "AcDbLine"
Set lineObj = Ent
With lineObj
Select Case .Layer
Case "零件表格竖线", "零件表格横线"
m4 = Round(.StartPoint(0), 2)
m5 = Round(.StartPoint(1), 2)
m6 = Round(.StartPoint(2), 2)
m7 = Round(.EndPoint(0), 2)
m8 = Round(.EndPoint(1), 2)
m9 = Round(.EndPoint(2), 2)
End Select
End With
Case "AcDbText"
Set textObj = Ent
With textObj
If .Layer = "零件表格文本" Then
m4 = Round(.InsertionPoint(0), 2)
m5 = Round(.InsertionPoint(1), 2)
m6 = Round(.InsertionPoint(2), 2)
m7 = .TextString
End If
End With
End Select
Write #1, m1, m2, m3, m4, m5, m6, m7, m8, m9
Next Ent
Close #1
End FunctionSub Main()
CAdToText ("D:\Temp.txt")
Dim rsX As ADODB.Recordset, rsY As ADODB.Recordset, rsText As ADODB.Recordset
Dim abc As String
abc = "select "
abc = abc & " val(m4) as mm from temp.txt where m1 = 'AcDbLine' "
abc = abc & " union "
abc = abc & " select val(m7) as mm from temp.txt where m1 = 'AcDbLine' "
Set rsX = RecordsetToExcel(abc)
abc = "select "
abc = abc & " m5 as mm from temp.txt where m1 = 'AcDbLine' "
abc = abc & " union "
abc = abc & " select m8 from temp.txt where m1 = 'AcDbLine' ORDER BY mm DESC "
Set rsY = RecordsetToExcel(abc)
abc = "select "
abc = abc & " m7,m2,m4,m5,m6 from temp.txt where m3 = '零件表格文本' "
Set rsText = RecordsetToExcel(abc)
Dim xlSheet
Set xlSheet = ConnectExcel("Sheet1")
rsX.MoveFirst: rsY.MoveFirst: rsText.MoveFirst
'rsX.Sort = 0
With xlSheet
.Range("a:z").ClearContents
'.Range("A1").CopyFromRecordset rsX
'.Range("B1").CopyFromRecordset rsY
For ii = 0 To rsText.RecordCount - 1
xx = rsText.Fields(2): yy = rsText.Fields(3)
rsX.MoveFirst
For n1 = 0 To rsX.RecordCount - 1
'rsX.Move n1
a1 = rsX.Fields(0)
If rsX.EOF Then
Exit For
Else
rsX.MoveNext
End If
a2 = rsX.Fields(0)
If rsX.EOF() Then
Exit For
End If
If xx >= a1 And xx = a2 And yy handle每次重新打开cad都不同。
所以，是否只能在一次打开该dwg文件的时候使用？
这样的话，下次修改还是一样要重新做的吧
|
|
置顶卡
