土木在线论坛 \ 建筑设计 \ CAD下载及教程 \ [转帖]重复偏移程序原代码!

[转帖]重复偏移程序原代码!

发布于:2004-01-10 22:17:10 来自:建筑设计/CAD下载及教程 [复制转发]

感谢测绘网友myfreemind的提供!

这个程序主要是针对在AUTOCAD中做表格用的,可以根据距离重复做平行线,做表格非常方便! 原代码如下:


Sub callp()

On Error GoTo err
Dim keyWord As String


'选择偏移模式
ThisDrawing.Utility.InitializeUserInput 0, "Add Noadd"
keyWord = ThisDrawing.Utility.GetKeyword _
(vbCrLf & "输入选项 <分段偏移(a) 长偏移(n)> : <分段偏移> ")

If keyWord = "" Then keyWord = "Add" '若为空则默认分段偏移
'MsgBox keyWord
Select Case keyWord
Case "Add"
Call soffset1
Case "Noadd"
Call soffset2
End Select

err:
Exit Sub
End Sub
Sub soffset1() '分段进行偏移
'偏移命令中的偏移值是正值的情况,将在线进向的左,否在右
On Error GoTo err
Dim offdist(58) As Variant
Dim s As Integer
Dim i As Integer
Dim spnt As Variant
Dim epnt As Variant
Dim ts As String
Dim points As Variant


Dim sset As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next

Set sset = ThisDrawing.SelectionSets.Add("offsetobj")
sset.SelectOnScreen

If sset.Item(0).ObjectName = "AcDbPolyline" Then
points = sset.Item(0).Coordinates


If points(1) > points(3) Then
ts = "请输入偏移距离: <正值向左,负值向右> "

ElseIf points(1) < points(3) Then
ts = "请输入偏移距离: <正值向右,负值向左> "
ElseIf points(1) = points(3) And points(0) < points(2) Then
ts = "请输入偏移距离: <正值向下,负值向上> "
ElseIf points(1) = points(3) And points(0) > points(2) Then
ts = "请输入偏移距离: <正值向上,负值向下> "

End If

ElseIf sset.Item(0).ObjectName = "AcDb2dPolyline" Then
points = sset.Item(0).Coordinates
If points(1) > points(4) Then
ts = "请输入偏移距离: <正值向左,负值向右> "

ElseIf points(1) < points(4) Then
ts = "请输入偏移距离: <正值向右,负值向左> "
ElseIf points(1) = points(4) And points(0) < points(3) Then

ts = "请输入偏移距离: <正值向下,负值向上> "
ElseIf points(1) = points(4) And points(0) > points(3) Then
ts = "请输入偏移距离: <正值向上,负值向下> "
End If

ElseIf sset.Item(0).ObjectName = "AcDbLine" Then
spnt = sset.Item(0).StartPoint
epnt = sset.Item(0).EndPoint
If spnt(1) < epnt(2) Then
ts = "请输入偏移距离: <正值向左,负值向右> "
ElseIf spnt(1) > epnt(1) Then
ts = "请输入偏移距离: <正值向右,负值向左> "
ElseIf spnt(1) = epnt(1) And spnt(0) < epnt(0) Then
ts = "请输入偏移距离: <正值向上,负值向下> "
ElseIf spnt(1) = epnt(1) And spnt(0) > epnt(0) Then
ts = "请输入偏移距离: <正值向下,负值向上> "
End If
End If


Dim offobj As Variant
offdist(0) = 0

s = 1
ss:


offdist(s) = ThisDrawing.Utility.GetReal(ts)


offdist(s) = offdist(s) + offdist(s - 1)

offobj = sset.Item(0).Offset(offdist(s))
offobj(0).Color = acGreen
s = s + 1
GoTo ss
Exit Sub
err:

Exit Sub

End Sub

Sub soffset2() '以总长进行偏移

On Error GoTo err
Dim offdist(58) As Variant
Dim s As Integer
Dim i As Integer
Dim ts As String
Dim points As Variant

Dim sset As AcadSelectionSet
For i = 0 To ThisDrawing.SelectionSets.Count - 1
ThisDrawing.SelectionSets.Item(i).Clear
ThisDrawing.SelectionSets.Item(i).Delete
Next

Set sset = ThisDrawing.SelectionSets.Add("offsetobj")
sset.SelectOnScreen
If sset.Item(0

全部回复(3 )

只看楼主 我来说两句
  • eobser
    eobser 沙发

    看不大懂了,是否有误?
    2007-10-17 16:21:17

    回复 举报
    赞同0
  • kqh5000
    kqh5000 板凳
    谢谢提供!下载学习!
    2007-10-17 13:22:17

    回复 举报
    赞同0
加载更多
这个家伙什么也没有留下。。。

CAD下载及教程

返回版块

52.07 万条内容 · 656 人订阅

猜你喜欢

阅读下一篇

[分享]一个模型空间里的批量打印lisp,支持200x

(defun c:Mploty () (alert (strcat "===模型空间批量出图程序1.0版=== 2003.8.31 \n" "\n" "感谢使用本程序,欢迎提出修改意见 \n" "保留所有权利 \n" "\n" " 免费软件请勿做商业用途 \n" "\n" " QQ:55255953 \n" ) )      (setq p_1 (getpoint "\n\tFirst CORNER(最下方第一张图纸的左下角):")

回帖成功

经验值 +10