[转帖]谁要是把这些库用好了,可就是VBA大侠了.

ningyong58

转帖http://objectarx.net/bbs/viewthread.php?tid=2690&page=1&extra=

此函数库节选

'**************************************
' Name: Create New Layer and Set CurrentAutoCAD 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

yagoole

谢谢楼主 ：）

dxhy

比较  深奥！

wxz_56

好东西。初学者有用

2qhx2qhx2

学习学习