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

Kye

ttthhh_hb 发表于 2016-3-31 16:40
我用delphi进行CAD二次开发，delphi语言和VB语言很相似。在编写Activex dll供lisp程序调用时，有个问题没解 ...

这个你问问VBCAD大侠（明经通道也看过他的贴），我看过他提出的解决办法，但忘了是在那个论坛

''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''
特意搜了下，看看4L是不是你想要的，我没有遇到类似问题,所以也没有测试

http://www.cad8.net/forum.php?mod=viewthread&tid=9222&extra=page%3D1

ttthhh_hb

Kye 发表于 2016-3-31 23:09
这个你问问VBCAD大侠（明经通道也看过他的贴），我看过他提出的解决办法，但忘了是在那个论坛

''''''' ...

谢谢！我试一下。

imustsun

你好，楼主，请教个问题，我是在VB6中运行以下代码：
Private Sub Command1_Click()

Dim dblStart As Double, dblStep As Double
Dim dblStart0 As Double
On Error Resume Next
dblStart = 0
dblStep = 1

Form1.Hide
ConnectAutoCAD


dblStart = ThisDrawing.Utility.GetReal(vbCrLf + "请输入起始高程值(0): ")

If Err.Number = -2145320928 Then Err.Clear
dblStart0 = dblStart
dblStep = ThisDrawing.Utility.GetReal("请输入增量高程值(1): ")
If Err.Number = -2145320928 Then Err.Clear

Dim index As Integer

loop1:
'接受输入起止点
dblStart = dblStart0
On Error GoTo ExitLabel
Dim Pnt1 As Variant, Pnt2 As Variant
Pnt1 = ThisDrawing.Utility.GetPoint(, "请输入起点： ")
Pnt2 = ThisDrawing.Utility.GetPoint(Pnt1, "请输入终点： ")  '选择线段经过的多段线， 构成选择集

'选择线段经过的多段线，构成选择集
On Error Resume Next
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets("CONTOUR_SSET")
If ssetObj Is Nothing Then
Set ssetObj = ThisDrawing.SelectionSets.Add("CONTOUR_SSET")
Err.Clear
End If
Dim FilterType(0 To 4) As Integer, FilterData(0 To 4) As Variant

'填充类型和填充数据
FilterType(0) = -4
FilterData(0) = "< OR"
FilterType(1) = 0
FilterData(1) = "LWPOLYLINE" 'olyline" '轻义多段线
FilterType(2) = 0
FilterData(2) = "POLYLINE"  'olyline"   '二维多段线
FilterType(3) = 0
FilterData(3) = "LINE" 'ine"
FilterType(4) = -4
FilterData(4) = "OR> "

Dim PntList(0 To 5) As Double
PntList(0) = Pnt1(0): PntList(1) = Pnt1(1): PntList(2) = Pnt1(2)
PntList(3) = Pnt2(0): PntList(4) = Pnt2(1): PntList(5) = Pnt2(2)
'/////
ssetObj.Clear

Set ssetObj = ThisDrawing.SelectionSets.Add("CONTOUR_SSET")

ssetObj.SelectByPolygon acSelectionSetFence, PntList, FilterType, FilterData

'依次为选择集中每条多段线设置高程

'Dim ent As AcadSelectionSet
Dim ent As Object
Dim NP As Variant
Dim i As Integer

For Each ent In ssetObj
Select Case TypeName(ent)

Case "IAcadLine"
'给直线的起止点赋高程
NP = ent.StartPoint
NP(2) = dblStart
ent.StartPoint = NP
NP = ent.EndPoint
NP(2) = dblStart
ent.EndPoint = NP

Case "IAcadLWPolyline"
'给 LWPolyline 赋高程
ent.Elevation = dblStart

Case "IAcadPolyline"
'给 LWPolyline 赋高程
ent.Elevation = dblStart

Case Else    '给 3DPolyline 赋高程
ReDim NPS(UBound(ent.Coordinates)) As Double
NPS = ent.Coordinates
For i = 2 To UBound(ent.Coordinates) Step 3
NPS(i) = dblStart
Next i
ent.Coordinates = NPS
End Select
ent.Color = acRed
dblStart = dblStart + dblStep
Next

'输出执行结果汇报
If Err.Number = 0 Then
ThisDrawing.Utility.Prompt "已成功的为等高线设置高程。 " + vbCrLf
Else
ThisDrawing.Utility.Prompt "执行过程中出现错误。 " + vbCrLf
MsgBox Err.Description
End If
GoTo loop1
ThisDrawing.SelectionSets("CONTOUR_SSET").Delete
Exit Sub
ExitLabel:
MsgBox Err.Description
Form1.Show
End Sub
这段代码运行后总提示 ssetObj.SelectByPolygon 参数无效，不知道问题出在哪里了

zzyong00

imustsun 发表于 2016-4-4 15:59
你好，楼主，请教个问题，我是在VB6中运行以下代码：
Private Sub Command1_Click()

Dim FilterType(0 To 10) As Integer, FilterData(0 To 10) As Variant

'填充类型和填充数据
FilterType(0) = -4
FilterData(0) = "<Or"
FilterType(1) = -4
FilterData(1) = "<And"
FilterType(2) = 0
FilterData(2) = "LINE"
FilterType(3) = -4
FilterData(3) = "And>"
FilterType(4) = -4
FilterData(4) = "<And"
FilterType(5) = 0
FilterData(5) = "POLYLINE"
FilterType(6) = -4
FilterData(6) = "And>"
FilterType(7) = -4
FilterData(7) = "<And"
FilterType(8) = 0
FilterData(8) = "LWPOLYLINE"
FilterType(9) = -4
FilterData(9) = "And>"
FilterType(10) = -4
FilterData(10) = "Or>"

zzyong00

imustsun 发表于 2016-4-4 15:59
你好，楼主，请教个问题，我是在VB6中运行以下代码：
Private Sub Command1_Click()

最省事儿的是这样：
Dim FilterType(0 To 0) As Integer, FilterData(0 To 0) As Variant

'填充类型和填充数据
FilterType(0) = 0
FilterData(0) = "LINE,POLYLINE,LWPOLYLINE"


不过，问问题，请新开一贴！不要在我这个帖子里问不是我帖子内容的事儿

imustsun

见谅，程序顺利实现功能，多谢指导，下次注意了

Kye

加入一段错误处理就好了，不过还是谢谢老师！

----------------------

请教老师一个问题

当点击vb命令时，忘了先打开AutoCAD文件，然后就出现下图页面，指向问题代码为下面蓝色行.请问我应该加入那些代码可以避免这种情况，即如果忘了先打开CAD，先提个醒。请老师给点源码 谢谢


    Dim acadApp As Object  'AcadApplication
    Dim Thisdrawing As Object  'AcadDocument
    Set acadApp = GetObject(, "AutoCAD.Application")
    If Err Then
        Err.Clear
        Set acadApp = CreateObject("AutoCAD.Application")
        If Err Then
            MsgBox Err.Description
            End
            Exit Sub
        End If
    End If
    acadApp.Visible = True
    Set Thisdrawing = acadApp.ActiveDocument

zzyong00

Set Thisdrawing = acadApp.ActiveDocument
这种方式并不是最好的。。

happy訫誶

很强大 学习学习

215863568

牛！！！！！！！！！！！！！！！！！！！！！！！