Handle更改材料表数据。
本帖最后由 作者 于 2008-7-9 14:47:54 编辑很多材料表的内容相同，只是更改极个别数据后材料重量又要重新计算。
利用handle的特性，将材料的内容先移到excel中，经过excel的重新计算，再返回到autocad保持原有其原有的格式。
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 < xx(ii + 1) Then
Exit For
End If
Next ii
y1 = Val(TextInsertPoint(kk, 0))
For jj = 1 To UBound(yy) - 1
If y1 > yy(jj) And y1 < yy(jj + 1) Then
Exit For
End If
Next jj
'gg(ii - 1, jj - 1) = TextArray(kk)
gg(ii - 1, jj - 1) = TextArray(kk)
ggg(ii - 1, jj - 1) = HandleArray(kk)
Next kk
Dim xlSheet As Object
Set xlSheet = AutoCadConnectExcel("Sheet1")
Set xlSheet1 = AutoCadConnectExcel("Sheet2")
xlSheet.Range("a:z").ClearContents
xlSheet1.Range("a:z").ClearContents
For ii = 0 To UBound(gg)
For jj = 0 To 7
With xlSheet
If jj <= 4 Then
.cells(ii + 1, jj + 1) = "'" & gg(ii, jj)
Else
.cells(ii + 1, jj + 1) = gg(ii, jj)
End If
End With
Next jj
Next ii
For ii = 0 To UBound(ggg)
For jj = 0 To 7
With xlSheet1
If jj <= 4 Then
.cells(ii + 1, jj + 1) = "'" & ggg(ii, jj)
Else
.cells(ii + 1, jj + 1) = ggg(ii, jj)
End If
End With
Next jj
Next ii
End Sub
'冒泡程序
Function Bubble_Sort(Ary)
Dim aryUBound, i, j
aryUBound = UBound(Ary)
For ii = 0 To aryUBound
Ary(ii) = Val(Round(Ary(ii), 2))
Next ii
For i = 0 To aryUBound
For j = i + 1 To aryUBound
If Ary(i) > 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 Function
Sub 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 & " selectm8 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 Then
Exit For
End If
' rsX.MoveNext
Next n1
rsY.MoveFirst
For n2 = 0 To rsY.RecordCount - 1
a1 = rsY.Fields(0)
If rsY.EOF Then
Exit For
Else
rsY.MoveNext
End If
a2 = rsY.Fields(0)
If rsY.EOF Then
Exit For
End If
If yy >= a2 And yy <= a1 Then
Exit For
End If
Next n2
If n1 = 3 Or n1 = 5 Or n1 = 6 Then
.cells(n2 + 1, n1 + 1) = Val(rsText(0))
Else
.cells(n2 + 1, n1 + 1) = rsText(0)
End If
If Not rsText.EOF Then
rsText.MoveNext
End If
Next ii
End With
End Sub
Function RecordsetToExcel(InputFileName As String) As ADODB.Recordset
Set conn = CreateObject("ADODB.Connection")
Set rs = CreateObject("adodb.recordset")
conn.Open "DRIVER={Microsoft Text Driver (*.txt; *.csv)};DBQ=d:\", "", ""
rs.Open " " & InputFileName, conn, 1, 3
Set RecordsetToExcel = rs
'Sheet1.Range("A2").CopyFromRecordset rs
End Function
Function ConnectExcel(InputSheetName As String) As Object
Dim xlApp As Object
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
Set ConnectExcel = xlApp.ActiveWorkbook.Sheets(InputSheetName)
End Function
<p>handle每次重新打开cad都不同。</p><p>所以，是否只能在一次打开该dwg文件的时候使用？</p><p>这样的话，下次修改还是一样要重新做的吧</p> 好像是我理解有点问题~~ <p>打开已有的dwg文件，handle不会变。只是在写实体时是随机变化，如画一条直线，写一个文字 handle是随机变化的。</p><p>set ent = ent1.copy() 后，ent的handle会变的</p>
页:
[1]