Excel到Autocad插入属性
样品rar公司嗨，朋友们，
我从网上找到了一个VBA代码。根据AutoCAD中的定位坐标对块进行编码。
代码正在工作，但用于简单的块。
我想更改属性块，但我做不到。
谁能帮忙？
我希望我能理解。因为我的英语太差了
Option Explicit
'A custom type that holds the scale factors of the block.
Private Type ScaleFactor
X As Double
Y As Double
Z As Double
End Type
Sub InsertBlocks()
'--------------------------------------------------------------------------------------------------------------------------
'Inserts blocks in AutoCAD using data - insertion point, block name/full path, scale factors, rotation angle - from Excel.
'Note that the block name or the block path must already exists, otherwise nothing will be inserted.
'The code uses late binding, so no reference to external AutoCAD (type) library is required.
'It goes without saying that AutoCAD must be installed at your computer before running this code.
'Written by: Christos Samaras
'Date: 21/04/2014
'e-mail: xristos.samaras@gmail.com
'site: http://www.myengineeringworld.net
'--------------------------------------------------------------------------------------------------------------------------
' Define the block
'Declaring the necessary variables.
Dim acadApp As Object
Dim height As Double
Dim acadDoc As Object
Dim acadBlock As Object
Dim attributeObj As Object
Dim LastRow As Long
Dim i As Long
Dim InsertionPoint(0 To 2)As Double
Dim BlockName As String
Dim BlockScale As ScaleFactor
Dim RotationAngle As Double
Dim tag As String
Dim value As String
Dim prompt As String
tag = "ATT1"
value = Range("E3")
height = 250
'Activate the coordinates sheet and find the last row.
With Sheets("Coordinates")
.Activate
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'Check if there are coordinates for at least one circle.
If LastRow < 2 Then
MsgBox "There are no coordinates for the insertion point!", vbCritical, "Insertion Point Error"
Exit Sub
End If
'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If
'Check (again) if there is an AutoCAD object.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0
'If there is no active drawing create a new one.
On Error Resume Next
Set acadDoc = acadApp.ActiveDocument
If acadDoc Is Nothing Then
Set acadDoc = acadApp.Documents.Add
End If
On Error GoTo 0
'Check if the active space is paper space and change it to model space.
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding
End If
On Error Resume Next
'Loop through all the rows and add the corresponding blocks in AutoCAD.
With Sheets("Coordinates")
For i = 2 To LastRow
'Set the block name.
BlockName = .Range("D" & i).value
'If the block name is not empty, insert the block.
If BlockName <> vbNullString Then
'Set the insertion point.
InsertionPoint(0) = .Range("A" & i).value
InsertionPoint(1) = .Range("B" & i).value
InsertionPoint(2) = .Range("C" & i).value
'Initialize the optional parameters.
BlockScale.X = 1
BlockScale.Y = 1
BlockScale.Z = 1
RotationAngle = 0
'Add the block using the sheet data (insertion point, block name, scale factors and rotation angle).
'The 0.0174532925 is to convert degrees into radians.
Set attributeObj = acadBlock.AddAttribute(height, _
prompt, InsertionPoint, tag, value)
Set acadBlock = acadDoc.ModelSpace.Insertblock(InsertionPoint, BlockName, _
BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925)
End If
Next i
End With
'Zoom in to the drawing area.
acadApp.ZoomExtents
'Release the objects.
Set acadBlock = Nothing
Set acadDoc = Nothing
Set acadApp = Nothing
End Sub
没有人回答吗？ 下面是一些代码更新属性值的示例
attribs = SS.Item(Cntr).GetAttributes
If attribs(0).TextString = pitname Then
pt1 = ThisDrawing.Utility.GetPoint(, " pick first point")
txtx1 = CStr(FormatNumber(pt1(0), 3))
TXTY1 = CStr(FormatNumber(pt1(1), 3))
attribs(1).TextString = txtx1
attribs(2).TextString = TXTY1
attribs(1).Update
attribs(2).Update
嗨，比格尔，
非常感谢你为我花的时间。
代码由我如何集成自己的代码给出？我不太擅长编码，你能帮我吗？ 我已经停止使用VBA了，最好看一下VLISP或纯lisp的很多例子来做同样的事情。 非常感谢。我的搜索还在继续，我希望我的权利 我和你在一起。
首先，您需要能够在excel工作表中列出属性值。在表格中的样本中（“坐标”）
然后您将使用；
Dim varAttributes作为变体
varAttributes=acadblock。获取属性
对于L=LBound（varAttributes）到UBound（varAttributes）
varAttributes（L）。TextString=devrekesici（k+1，L+1）。价值
下一个
上面的“devrekesici”是我指定的范围。它将是你想要的任何东西。
希望这对别人有帮助。 非常感谢piscopatos，它起作用了！！ 我很高兴它对你有用。试着进入。NET API。这有点难，但要强大得多。 [尺寸=4]witchhero，你能在这里找到新的重拍代码吗：），谢谢！[/尺寸]
页:
[1]
2