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