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 我们做表格就是画直线，然后偏移 呵呵，那就简单了，我做了一个表格绘制程序，放在“编程申请”里，你去下载用吧！
页:
1
[2]