重复偏移程序原代码!

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).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


s = 1
ss:

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


offdist(s) = offdist(s)

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

End Sub

无痕

2. 
   
3. ;fff 连续不等距offset------无痕.2000.02
   
4. (defun c:mff (/ ss p1 p2 dis)
   
5.   (princ "\nmff 连续不等距offset------无痕.2000.02")
   
6.   (setq ss (car(entsel))
   
7.         p1 (getpoint "\n <getdist> 1st pt:"))
   
8.   (while (setq p2 (getpoint p1 "\n next point:")
   
9.                dis (distance p1 p2)
   
10.          )     
    
11.          (command ".offset" dis ss p2 "")
    
12.          (setq ss (ssget "l")
    
13.                p1 p2)
    
14.   )(princ)
    
15. )
    

<br /> ;fff 连续不等距offset------无痕.2000.02<br /> (defun c:mff (/ ss p1 p2 dis)<br />   (princ "\nmff 连续不等距offset------无痕.2000.02")<br />   (setq ss (car(entsel))<br />         p1 (getpoint "\n <getdist> 1st pt:"))<br />   (while (setq p2 (getpoint p1 "\n next point:")<br />                dis (distance p1 p2)<br />          )     <br />          (command ".offset" dis ss p2 "")<br />          (setq ss (ssget "l")<br />                p1 p2)<br />   )(princ)<br /> )<br />

BDYCAD

To 無痕:
    看來這個功能有點類似多重復制的做法, 呵呵 :D

无痕

不是多重复制，你试试圆弧，或spline，就知道区别

BDYCAD

O, 我剛考慮到. 謝謝! 你說的正是.

chb801

To 無痕:
你的代码少，搞个VBA的就好了！

无痕

我不懂vba，不过我没太看明白你的话。：s

beijingok

To 無痕，BDYCAD :
呵呵！你们是牛头不对马嘴啊！
我不会，但不会乱回贴啊！
人家的VBA，到你们就是LISP了！看不懂！

5664491

版主有没有办法就是