从e另存为autocad图形
大家好我使用的是Christos Samaras先生编写的excell的vba
此vba绘图块位于激活的autocad图形中
我希望每次运行vba宏时都将图形另存为单元格A1内容
e、 g.如果单元格A1为（section1），则vba将图形另存为（section1.dwg）
任何帮助都将不胜感激
提前感谢
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
'--------------------------------------------------------------------------------------------------------------------------
'Declaring the necessary variables.
Dim acadApp As Object
Dim acadDoc As Object
Dim acadBlock 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
'Activate the coordinates sheet and find the last row.
With Sheets("ADD SECTION")
.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("ADD SECTION")
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
'Set the optional parameters (if there are values on the corresponding ranges).
If .Range("E" & i).Value <> vbNullString Then BlockScale.X = .Range("E" & i).Value
If .Range("F" & i).Value <> vbNullString Then BlockScale.Y = .Range("F" & i).Value
If .Range("G" & i).Value <> vbNullString Then BlockScale.Z = .Range("G" & i).Value
If .Range("H" & i).Value <> vbNullString Then RotationAngle = .Range("H" & i).Value
'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 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
'Inform the user about the process.
MsgBox "The blocks were successfully inserted in AutoCAD!", vbInformation, "Finished"
End Sub
Sub ClearAll()
Dim LastRow As Long
'Find the last row and clear all the input data..
With Sheets("ADD SECTION")
.Activate
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("A2:H" & LastRow).ClearContents
.Range("A2").Select
End With
End Sub
页:
[1]