本帖最后由 Kye 于 2016-4-1 09:21 编辑
ttthhh_hb 发表于 2016-3-31 16:40 static/image/common/back.gif
我用delphi进行CAD二次开发，delphi语言和VB语言很相似。在编写Activex dll供lisp程序调用时，有个问题没解 ...
这个你问问VBCAD大侠（明经通道也看过他的贴），我看过他提出的解决办法，但忘了是在那个论坛
''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''
特意搜了下，看看4L是不是你想要的，我没有遇到类似问题,所以也没有测试
http://www.cad8.net/forum.php?mod=viewthread&tid=9222&extra=page%3D1
Kye 发表于 2016-3-31 23:09 static/image/common/back.gif
这个你问问VBCAD大侠（明经通道也看过他的贴），我看过他提出的解决办法，但忘了是在那个论坛
''''''' ...
谢谢！我试一下。
本帖最后由 imustsun 于 2016-4-4 16:01 编辑
你好，楼主，请教个问题，我是在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 参数无效，不知道问题出在哪里了
imustsun 发表于 2016-4-4 15:59 static/image/common/back.gif
你好，楼主，请教个问题，我是在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>"
imustsun 发表于 2016-4-4 15:59 static/image/common/back.gif
你好，楼主，请教个问题，我是在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"
不过，问问题，请新开一贴！不要在我这个帖子里问不是我帖子内容的事儿
见谅，程序顺利实现功能，多谢指导，下次注意了
本帖最后由 Kye 于 2016-4-6 16:46 编辑
加入一段错误处理就好了，不过还是谢谢老师！
----------------------
请教老师一个问题
当点击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
Set Thisdrawing = acadApp.ActiveDocument
这种方式并不是最好的。。
很强大 学习学习
牛！！！！！！！！！！！！！！！！！！！！！！！