社区 › VB › 从Excel更新属性

jp_lujan 发表于 2006-6-27 01:39:43

从Excel更新属性

您好：
有人会知道对我说我哪里有问题a。
1º 使用 Autodesk 中的宏“Exttr”从 AutoCAD 导入属性。
2º 要使用宏“RestoreByHand”导出在excel的worsheet中对AutoCAD图形所做的任何修改都不起作用
它是AutoCAD 2004。
我把代码留给它，以防他们可以帮助我，事先感谢。
Public acad As Object
Public mspace As Object
Public Excel As Object
Public AcadRunning As Integer
Public excelSheet As Object
'_______________________________________________________________________________________
Sub Extract()
    Dim sheet As Object
    Dim shapes As Object
    Dim elem As Object
    Dim Excel As Object
    Dim Max As Integer
    Dim Min As Integer
    Dim NoOfIndices As Integer
    Dim excelSheet As Object
    Dim RowNum As Integer
    Dim Array1 As Variant
    Dim Count As Integer
    Dim SHand As String
    Dim TStr As String
   
    Set Excel = GetObject(, "Excel.Application")
    Worksheets("Attributes").Activate
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Attributes")
    excelSheet.Range(Cells(1, 1), Cells(5000, 100)).Clear
    excelSheet.Range(Cells(1, 1), Cells(1, 100)).Font.Bold = True
    Set acad = Nothing
    On Error Resume Next
    Set acad = GetObject(, "AutoCAD.Application")
    If Err0 Then
      Set acad = CreateObject("AutoCAD.Application")
      MsgBox "Open the drawing file first and then rexecute!"
      Exit Sub
    End If
    acad.Visible = True
    Set doc = acad.ActiveDocument
    Set mspace = doc.ModelSpace
    RowNum = 1
    Dim Header As Boolean
    Header = False
    For Each elem In mspace
      With elem
            If StrComp(.EntityName, "AcDbBlockReference", 1) = 0 Then
                If .HasAttributes Then
                  Array1 = .GetAttributes
                  For Count = LBound(Array1) To UBound(Array1)
                        If Header = False Then
                            If StrComp(Array1(Count).EntityName, "AcDbAttribute", 1) = 0 Then
                              TStr = Array1(Count).TagString
                              excelSheet.Cells(RowNum, Count + 1).Value = TStr
                            End If
                        End If
                  Next Count
                  RowNum = RowNum + 1
                  For Count = LBound(Array1) To UBound(Array1)
                        TStr = Array1(Count).TextString
                        excelSheet.Cells(RowNum, Count + 1).Value = TStr
                  Next Count
                  SHand = elem.Handle
                  excelSheet.Cells(RowNum, Count + 1).NumberFormat = "@"
                  excelSheet.Cells(RowNum, Count + 1).Value = SHand
                  Header = True
                End If
            End If
      End With
    Next elem
    NumberOfAttributes = RowNum - 1
    Set acad = Nothing
End Sub
'_______________________________________________________________________________________
Sub RestoreByHand()
    Dim sheet As Object
    Dim shapes As Object
    Dim elem As Object
    Dim Excel As Object
    Dim Max As Integer
    Dim Min As Integer
    Dim NoOfIndices As Integer
    Dim excelSheet As Object
    Dim RowNum As Integer
    Dim Array1 As Variant
    Dim Count As Integer
    Dim SHand As String
    Dim tempObj As Object
   
    Set Excel = GetObject(, "Excel.Application")
   
    Worksheets("Attributes").Activate
    Set excelSheet = Excel.ActiveWorkbook.Sheets("Attributes")
   
Dim iLig As Integer
Dim ColHand As Long, LigHand1 As Long, LigHand2 As Long
      
    Set acad = Nothing
    On Error Resume Next
    Set acad = GetObject(, "AutoCAD.Application")
    If Err0 Then
      Set acad = CreateObject("AutoCAD.Application")
      MsgBox "Open AutoCAD launch"
      Exit Sub
    End If
    acad.Visible = True
    Set doc = acad.ActiveDocument
    Set mspace = doc.ModelSpace
    RowNum = 1
    Dim Header As Boolean
    Header = False
   
    ColHand = 17
    LigHand1 = 1
    LigHand2 = 10000
    Dim iArray As Long
    Dim jL As Long
   
    iArray = 0
    For iLig = LigHand1 To LigHand2
       iArray = iArray + 1
       SHand = excelSheet.Cells(iLig, ColHand).Value
         If SHand"" Then
            Set tempObj = doc.HandleToObject(SHand)
            Array1 = tempObj.GetAttributes
               For jL = 0 To 40
               TStr = excelSheet.Cells(iLig, jL + 1).Value
               Array1(jL).TextString = TStr
               Next jL
         End If
                                                                  
    Next iLig
   
    Set acad = Nothing
End Sub
**** Hidden Message *****

Atook 发表于 2006-6-27 10:49:26

无代码宝贝！
我已经使用快速工具完成了这项工作。
您可以使用过滤器仅选择您感兴趣的块。
快速工具->块->导出属性信息
~在Excel中处理数据，保持列和行的完整性。完成后保存文件。~
快捷工具->块->导入属性信息
不是代码，但希望有用。
如果您仍然需要基于代码的解决方案，请告诉我们。

Atook 发表于 2006-6-27 10:53:17

代码在什么方面是免费的？诚然，它使用预先提供的代码来完成任务，但代码仍然存在。

Atook 发表于 2006-6-27 11:02:34

好吧，代码免费，因为不需要编写额外的
代码。
我想将计算机用于门挡以外的任何东西都不是免费的...
现在至少我们有免费的代码。但这是一个不同的话题。

查看完整版本: 从Excel更新属性