CAD VBA 输出WMF文件和导入WMF文件 -

'输出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

[本日志由田草于 2008-07-17 10:22 AM 编辑]

分享到： QQ空间新浪微博腾讯微博微信更多

tiancao1001 于 2008-12-02 12:24 AM 发表评论：

'输出wmf文件
Public Function WMFOut(P1 As Variant, P2 As Variant, FileName As String)
    ThisDrawing.Application.ZoomAll
    '创建空选择集
    Dim SSet As AcadSelectionSet
    Set SSet = CreateSelectionSet("XXX")

    '为选择集添加对象
    SSet.Select acSelectionSetWindow, P1, P2

    '将选择集中对象传递给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 X As Double
    Dim Y As Double
    X = Abs(P1(0) - P2(0)) '图形宽度
    Y = Abs(P1(1) - P2(1)) '图形高度

    Dim Xy As Double

    Xy = X / Y '图形宽高比

    X = 600 '文档视口宽度

    Y = 600 / Xy '文档视口高度

    ThisDrawing.Width = X
    ThisDrawing.Height = Y

    ThisDrawing.Application.ZoomWindow P1, P2

    '导出wmf文件
    If UCase(Right(FileName, 4)) = ".WMF" Then
       FileName = Left(FileName, Len(FileName) - 4)
    End If
    ThisDrawing.Export FileName, "WMF", SSet
End Function

田草于 2008-07-17 10:22 AM 发表评论：

Function ImportWMF(P As String)
    '输入文件
    If Dir(P) <> "" Then    '判断文件是否存在
        ThisDrawing.Import P, Point3D(0, 0, 0), 2
    Else
        Prompt "程序使用的临时文件不存在,请重新运行程序！"
        Exit Function
    End If
End Function

发表评论 - 不要忘了输入验证码哦！

作者：

用户：密码：注册？验证：