[编程交流] 将Excel VBA链接到acad

 
Option Explicit
'' Require Reference to:
'' Tools--> References --> Microsoft Excel 1X.0 Type Library
'' and also you have to set options here:
'' Tools--> Options --> Genetral --> Error Trapping -> check 'Break on Unhahdled Errors'
'' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ''
Const xlFileName As String = "C:\Test\TitleBlock.xls" '<-- change data file name
Const sheetName As String = "MyAttributes" '<-- change sheet name
Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long
''------------Late binding example:------------------''
Sub LateBindingExcel()
Dim xlApp As Object
Dim xlBooks As Object
Dim xlBook As Object
Dim xlSheets As Object
Dim xlSheet As Object
Dim xlCells As Object
Dim xlRange As Object
On Error GoTo Err_Control
On Error Resume Next
Set xlApp = Nothing
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
Set xlApp = CreateObject("Excel.Application")
End If
Err.Clear
Set xlBooks = xlApp.Workbooks
If xlBooks.Count > 0 Then
Set xlBook = xlBooks.Item(1)
End If
If xlBooks.Count = 0 Then
Set xlBook = xlBooks.Open(xlFileName, False)
End If
Set xlSheets = xlBook.worksheets
Set xlSheet = xlSheets.Item(sheetName)  '<--- change a sheet name (might be a sheet number instead)
xlSheet.Application.Visible = True
Set xlCells = xlSheet.Cells
Set xlRange = xlCells.Range("$A1:$A10")
Dim i As Long
i = 1
Dim strAddr As String
Dim attrData(0 To 9) As String
For i = 1 To 10
strAddr = "A" & CStr(i)
Set xlRange = xlCells.Range(strAddr)
Dim cellVal
cellVal = xlRange.Value
attrData(i - 1) = CStr(cellVal) '<-- store data you took from Excel for the future use
Next
ThisDrawing.Activate
' keep this order
Set xlRange = Nothing
Set xlCells = Nothing
Set xlSheet = Nothing
Set xlSheets = Nothing
xlBook.Close False
Set xlBook = Nothing
Set xlBooks = Nothing
xlApp.Quit
Set xlApp = Nothing
MsgBox "Select blocks"
''------------- End of Excel work-----------------''
Dim oEnt As AcadEntity
Dim oBlkRef As AcadBlockReference
Dim oAttrib As AcadAttributeReference
Dim attVal  As Variant
Dim ftype(0 To 1) As Integer
Dim fdata(0 To 1) As Variant
Dim dxfCode, dxfValue
ftype(0) = 0: fdata(0) = "insert"
ftype(1) = 66: fdata(1) = 1
dxfCode = ftype: dxfValue = fdata
    Dim oSset As AcadSelectionSet
         With ThisDrawing.SelectionSets
              While .Count > 0
                   .Item(0).Delete
              Wend
         Set oSset = .Add("$MyBlocks$")
         End With
oSset.SelectOnScreen dxfCode, dxfValue
If oSset.Count = 0 Then
MsgBox "nothing selected, exit..."
Exit Sub
End If
For Each oEnt In oSset
Set oBlkRef = oEnt
attVal = oBlkRef.GetAttributes
For i = LBound(attrData) To (UBound(attrData)) '<-- assuming a contents size of the stored data
Set oAttrib = attVal(i)
If attrData(i) <> vbNullString Then
oAttrib.TextString = attrData(i)
End If
Next i
Next oEnt
Err_Control:
If Err.Number <> 0 Then
MsgBox Err.Description
End If
End Sub

 
dim obj as AcadEntity
Dim oText as AcadText
dim handlerange as range
dim textrange as range
set handlerange=mySheet.Range("A1000")
set textrange=mySheet.Range("B1000")
Set obj= thisdrawing.HandleToObject(range.Value)
set txtobj= obj
txtobj.TextString= textrange.value''--> or value2