[VBA][紧急求助]关于遍历多段线的问题！！！

weinierxin 发表于 2006-9-29 23:05:00

各位大侠好！
本人现有难题，请大家给予帮忙，在此多谢先！
我有很多autocad2000的旧图，使用了参照的功能，
在旧版软件里面打印时，可以通过设置颜色来统一设置线宽，没有问题。
但是现在更新autocad版本到2006后，这个方法却不管用了，尽管设置了线宽，
但是，每次打印时，在参照块里面的多段线的线宽总是不正确，
导致打印出来的图形线宽粗细不一，非常难看。

现在，一直没有办法解决，
除了就是到每一个参照块里面把所有的多段线都打散（分解）了。
这是一个非常麻烦的工作，由于大量的图纸，这几乎就是不可行的方法了。
所以，本人在想，是否可以做个VBA程序，直接在图纸里面运行，
遍历图中的多段线和参照块，
自动将图纸中的多段线以及所有参照块中的多段线全部分解，这样就省事多了；
或者是否可以在文件目录中，放置编写好的一个小程序，不用打开CAD程序，
直接遍历文件夹中的文件，以及文件中的多段线，并分解，这样是为了避免操作参照块。
以上思路不知道是否可行，还请高人出来指点一二！
谢谢！
<A href="mailto:litsong@126.com" target="_blank" >litsong@126.com</A>

wyj7485 发表于 2006-9-30 09:37:00

Sub test() On Error Resume Next
Dim MySet As AcadSelectionSet Dim FilterType(0) As Integer Dim FilterData(0) As Variant
ThisDrawing.SelectionSets.Item("MySet ").Delete
FilterType(0) = 0: FilterData(0) = "LWPOLYLINE,INSERT" Set MySet = ThisDrawing.SelectionSets.Add("MySet ") MySet.Select acSelectionSetAll, , , FilterType, FilterData
Dim i As Integer
Dim Bobj As Object
For i = 0 To MySet.Count - 1 If MySet(i).ObjectName = "AcDbPolyline" Then MySet(i).Explode MySet(i).Delete Else     For Each Bobj In ThisDrawing.Blocks(MySet(i).Name)     If Bobj.ObjectName = "AcDbPolyline" Then     Bobj.Explode     Bobj.Delete     End If     Next End If Next
End Sub

weinierxin 发表于 2006-10-1 11:14:00

谢谢2楼的兄弟帮忙，给出了代码。
我想问一下，这个应该是不能对参考进行操作吧？
有些代码我还看不太懂

weinierxin 发表于 2006-10-1 11:23:00

能实现在一个文件里面对所有的参照文件都进行操作啊？？

weinierxin 发表于 2006-10-1 11:29:00

还有，就是如果直接使用上面的代码，转而遍历文件夹中所有的*.DWG文件，然后在后台打开并运行宏代码操作。可是每次操作的文件高达2000，这样的话，系统能不能吃得消呢？？真是头疼哦～～

wyj7485 发表于 2006-10-9 11:23:00

vba只能在cad环境下运行,不能在后台运行,要的话建议用vb写

chman 发表于 2006-10-9 19:24:00

块参照多的情况下，也没有多大的影响
最近我刚刚对块进行炸开的操作，用的是过滤器的办法
这样就可以按照楼主的要求做了

weinierxin 发表于 2006-10-11 22:18:00

<A name=34902>wyj7485</A>
说的不错，我正在弄这个，是用VB来实现呢，呵呵
VBA在VB里面着实折腾不出来啊，
能不能提供点代码，以便研究研究啊？
小弟平时会用VB编写一些东西，CAD的vba不太懂，还请多多指教，
<A name=34902>wyj7485</A>还有楼上的兄弟<A name=34935>chman</A>，
多谢先，呵呵
网上，好像针对这方面的资料也不多，真头疼噢：（

weinierxin 发表于 2006-10-12 20:59:00

显示找不到“AcadSelectionSet”？？？
请帮忙分析一下下面的代码，谢谢先～～
 
 
Dim obj_Acad As Object, obj_Doc As Object, obj_ModelSpace As Object  'Application对象、Document对象、ModelSpace对象   Public Sub AutoCADOpen(FileName As String)        '打开AutoCAD子程序 On Error Resume Next Set obj_Acad = GetObject(, "autocad.application") '若AutoCAD已启动,则直接得到Application对象,建议先打开CAD程序 If Err Then    Err.Clear    On Error Resume Next    Set obj_Acad = CreateObject("autocad.application") '若AutoCAD未启动，则运行AutoCAD程序    If Err Then       Err.Clear       MsgBox "不能运行AutoCAD,请检查是否安装！", vbOKOnly, "警告！"       Exit Sub       End If End If obj_Acad.Visible = True   '设置AutoCAD为可见（或者在后台运行,不可见） obj_Acad.Documents.open (FileName)  '打开AutoCAD图形文件 Set obj_Doc = obj_Acad.ActiveDocument '获得当前活动图形文件，即刚打开的图形文件 Set obj_ModelSpace = obj_Doc.ModelSpace '获得当前活动图形文件的模型空间
On Error Resume Next
Dim MySet As AcadSelectionSet Dim FilterType(0) As Integer Dim FilterData(0) As Variant
ThisDrawing.SelectionSets.Item("MySet ").Delete
FilterType(0) = 0: FilterData(0) = "LWPOLYLINE,INSERT" Set MySet = ThisDrawing.SelectionSets.Add("MySet ") MySet.Select acSelectionSetAll, , , FilterType, FilterData
Dim i As Integer
Dim Bobj As Object
For i = 0 To MySet.Count - 1 If MySet(i).ObjectName = "AcDbPolyline" Then MySet(i).explode MySet(i).Delete Else     For Each Bobj In ThisDrawing.Blocks(MySet(i).Name)     If Bobj.ObjectName = "AcDbPolyline" Then     Bobj.explode     Bobj.Delete     End If     Next End If Next
End Sub
MsgBox "运行结束！", vbOKOnly, "工程1！" End Sub

页: [1]

明经CAD社区's Archiver

[VBA][紧急求助]关于遍历多段线的问题！！！