[转帖]谁要是把这些库用好了,可就是VBA大侠了.
转帖=此函数库节选
'**************************************
' Name: Create New Layer and Set Current VBA
' Description:Another AutoCAD VBA example. This is a subroutine that will take a
' string that is the layer name and create the layer if it doesn't exist, then make
' that layer current. You can add more inputs to this like color, linetype, etc.
Private Sub MakeSetLayer(strLayer As String)
Dim layCurrent As AcadLayer
On Error Resume Next
Set layCurrent = ThisDrawing.Layers(strLayer)
If layCurrent Is Nothing Then
Set layCurrent = ThisDrawing.Layers.Add(strLayer)
If layCurrent Is Nothing Then
MsgBox "Error creating layer " & strLayer & "."
Exit Sub
End If
End If
ThisDrawing.ActiveLayer = layCurrent
End Sub
'输出wmf文件，再导入新的cad文件中
'
Sub WMFOut()
'插入wmf之前应该使用明天wmfopts命令设置导入的wmf是否填充和显示线宽
ThisDrawing.SendCommand "wmfopts "
On Error Resume Next
'创建空选择集
Dim SSet As AcadSelectionSet
Set SSet = ThisDrawing.SelectionSets.Add("XXX")
If Err Then
ThisDrawing.SelectionSets("XXX").Delete
Set SSet = ThisDrawing.SelectionSets.Add("XXX")
Err.Clear
End If
'为选择集添加对象
SSet.SelectOnScreen
'将选择集中对象传递给Obj对象数组
Dim Obj() As Object
Dim i As Long
ReDim Obj(0 To SSet.count - 1) As Object
For i = 0 To SSet.count - 1
Set Obj(i) = SSet.Item(i)
Next i
Dim Pmax As Variant
Dim Pmin As Variant
SSet.Item(0).GetBoundingBox Pmin, Pmax
Dim B As acadBlock
Set B = ThisDrawing.Blocks.Add(Pmin, NiMingKuai("WMF")) ' 将数组中的实体复制到块定义中
ThisDrawing.CopyObjects Obj, B
'插入块
Dim EBRef As AcadBlockReference
Set EBRef = ThisDrawing.ModelSpace.InsertBlock(Pmin, B.Name, 1, 1, 1, 0)
EBRef.GetBoundingBox Pmin, Pmax
Dim x As Double
Dim y As Double
x = Abs(Pmin(0) - Pmax(0)) '图形宽度
y = Abs(Pmin(1) - Pmax(1)) '图形高度
Dim Xy As Double
Xy = x / y '图形宽高比
x = 600 '文档视口宽度
y = 600 / Xy '文档视口高度
ThisDrawing.width = x
ThisDrawing.Height = y
ThisDrawing.Application.ZoomWindow Pmin, Pmax
'导出wmf文件
Dim P As String
P = "c:/temp"
ThisDrawing.Export P, "WMF", SSet
'打开新图形
ThisDrawing.Application.Documents.Add "acad.dwt"
ThisDrawing.Import P & ".wmf", Point3D(0, 0, 0), 1
'充满窗口
ThisDrawing.Application.ZoomExtents
End Sub
**** Hidden Message ***** 谢谢楼主 ：）
比较深奥！ 好东西。初学者有用 学习学习
页:
[1]