用VB6进行Autocad的二次开发(原创)

szj612

很好很强大，受教了，感谢楼主!能不能讲一些用vb6改写VBA源码的知识，我想发布一些vba程序，但又不希望别人看到源码，所以希望用VB6编译一下，这样就相对安全一些，呵呵，不知道这样弄了之后在使用上有些什么区别？还请赐教!

zzyong00

用VB和VBA开发的人实在太少了，本版块真是人气凋零啊

szj612

谢谢赐教，我再好好消化一下前面的内容

jinmaji

pmq

谢谢楼主，学习了。

MTC

太牛了  好好消化一下

wycl8

支持，楼主辛苦了

zjy2999

xuexile!!!!!!!!!!!!

xsshhl

向你好好学习学习

zzyong00

今天看见一个用三维多线段作的地形图，没用拟合平滑。这种线，看着闹心，所以写个小代码转成多线段了！

1.   On Error GoTo err1
   
2.     Dim blnDel As Boolean
   
3.     blnDel = IIf(MsgBox("是否删除源三维多线段？" & vbCrLf & "提示：如果三维多线段采用'拟合/平滑'，转换后不准确！", vbYesNo + vbQuestion, "MEA") = vbYes, True, False)
   
4.    
   
5.     AppActivate objCad.Caption
   
6.     Dim objSset As AcadSelectionSet
   
7.     Dim objDoc As AcadDocument
   
8.     Set objDoc = ThisDrawing()
   
9.     SelectLots "MEA~PL~TMP~123", "POLYLINE" ' 三维多线段
   
10.     Set objSset = objDoc.SelectionSets("MEA~PL~TMP~123")
    
11.     If objSset.Count = 0 Then Exit Sub
    
12.     Dim obj1 As Acad3DPolyline  
    
13.     Dim objPL As AcadLWPolyline
    
14.     Dim coords As Variant, coords2() As Double, dblElv As Double, flag As Boolean
    
15.     Dim i As Long, j As Long
    
16.     For Each obj1 In objSset
    
17.         'Debug.Print obj1.ObjectName
    
18.         flag = False
    
19.         dblElv = 0
    
20.         i = 0: j = 0
    
21.         coords = obj1.Coordinates
    
22.         ReDim coords2(CLng((UBound(coords) + 1) / 3 * 2) - 1)
    
23.         For i = 0 To UBound(coords)
    
24.             If (i + 1) Mod 3 = 0 Then
    
25.                 If Not flag Then 'z坐标不一致，放弃对标高的转换，全为0
    
26.                     If i = 2 Then
    
27.                         dblElv = coords(2)
    
28.                     Else
    
29.                         If Abs(dblElv - coords(i)) > 0.00001 Then flag = True: dblElv = 0 '放弃标高
    
30.                     End If
    
31.                 End If
    
32.             Else
    
33.                 coords2(j) = coords(i)
    
34.                 j = j + 1
    
35.             End If
    
36.         Next i
    
37.         Set objPL = objDoc.ModelSpace.AddLightWeightPolyline(coords2)
    
38.         objPL.Elevation = dblElv
    
39.         objPL.Update
    
40.         If blnDel Then obj1.Delete
    
41.     Next obj1
    
42.     Exit Sub
    
43. err1:
    
44.     Err.Clear
    
45.     Debug.Print "三维多线段转多线段出错！"

  On Error GoTo err1<br />     Dim blnDel As Boolean<br />     blnDel = IIf(MsgBox("是否删除源三维多线段？" & vbCrLf & "提示：如果三维多线段采用'拟合/平滑'，转换后不准确！", vbYesNo + vbQuestion, "MEA") = vbYes, True, False)<br />     <br />     AppActivate objCad.Caption<br />     Dim objSset As AcadSelectionSet<br />     Dim objDoc As AcadDocument<br />     Set objDoc = ThisDrawing()<br />     SelectLots "MEA~PL~TMP~123", "POLYLINE" ' 三维多线段<br />     Set objSset = objDoc.SelectionSets("MEA~PL~TMP~123")<br />     If objSset.Count = 0 Then Exit Sub<br />     Dim obj1 As Acad3DPolyline  <br />     Dim objPL As AcadLWPolyline<br />     Dim coords As Variant, coords2() As Double, dblElv As Double, flag As Boolean<br />     Dim i As Long, j As Long<br />     For Each obj1 In objSset<br />         'Debug.Print obj1.ObjectName<br />         flag = False<br />         dblElv = 0<br />         i = 0: j = 0<br />         coords = obj1.Coordinates<br />         ReDim coords2(CLng((UBound(coords) + 1) / 3 * 2) - 1)<br />         For i = 0 To UBound(coords)<br />             If (i + 1) Mod 3 = 0 Then<br />                 If Not flag Then 'z坐标不一致，放弃对标高的转换，全为0<br />                     If i = 2 Then<br />                         dblElv = coords(2)<br />                     Else<br />                         If Abs(dblElv - coords(i)) > 0.00001 Then flag = True: dblElv = 0 '放弃标高<br />                     End If<br />                 End If<br />             Else<br />                 coords2(j) = coords(i)<br />                 j = j + 1<br />             End If<br />         Next i<br />         Set objPL = objDoc.ModelSpace.AddLightWeightPolyline(coords2)<br />         objPL.Elevation = dblElv<br />         objPL.Update<br />         If blnDel Then obj1.Delete<br />     Next obj1<br />     Exit Sub<br /> err1:<br />     Err.Clear<br />     Debug.Print "三维多线段转多线段出错！"