Handle更改材料表数据。

兰州人 · 发表于 2008-7-8 15:23:00

本帖最后由作者于 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 & " 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 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

很多材料表的内容相同，只是更改极个别数据后材料重量又要重新计算。
利用handle的特性，将材料的内容先移到excel中，经过excel的重新计算，再返回到<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>保持原有其原有的格式。
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 & " 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 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

xxxtttxxx · 发表于 2008-7-9 20:35:00

handle每次重新打开cad都不同。

所以，是否只能在一次打开该dwg文件的时候使用？

这样的话，下次修改还是一样要重新做的吧

xxxtttxxx · 发表于 2008-7-9 20:37:00

好像是我理解有点问题~~

兰州人 · 发表于 2008-7-11 11:37:00

打开已有的dwg文件，handle不会变。只是在写实体时是随机变化，如画一条直线，写一个文字 handle是随机变化的。

set ent = ent1.copy() 后，ent的handle会变的

账号		自动登录	找回密码
密码			注册