[VBA函数]：请教晓东

luln

请问:晓东为什么我的这个程序对于如下图所示的多义线有的向外偏移，有的向里偏移？
   程序如下：
Public Sub main()
       Call InRdsComp
       Call OutRdsComp
      
End Sub

Sub InRdsComp()
Dim rds As Double

rds = InputBox("请输入偏移距离", "输入")
Dim Insets As AcadSelectionSet
Dim snum As Integer
Dim existf As Boolean
    For snum = 0 To ThisDrawing.SelectionSets.Count - 1
        If ThisDrawing.SelectionSets.Item(snum).Name = "InEnts" Then
          existf = True
    Exit For
        End If
    Next
    If existf = True Then
        Set Insets = ThisDrawing.SelectionSets.Item("InEnts")
        Insets.Clear
    Else
        Set Insets = ThisDrawing.SelectionSets.Add("InEnts")
    End If
Dim gpCode(0) As Integer
gpCode(0) = 8
Dim dataValue(0) As Variant
dataValue(0) = "InlayerBAid"
Dim groupCode, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
Insets.Select acSelectionSetAll, , , groupCode, dataCode  
Dim i, entsnum As Integer
Dim ent As AcadEntity
Dim entry As Variant
entsnum = Insets.Count
For i = 0 To entsnum - 1
    Set ent = Insets.Item(i)
    ent.Highlight (True)
    MsgBox "this is" & ent.ObjectName
   
    If StrComp(ent.ObjectName, "AcDbCircle", 1) = 0 Or StrComp(ent.ObjectName, "AcDbEllipse", 1) = 0 Then
     entry = ent.Offset(-rds)
     entry(0).Color = acRed
     Else
     entry = ent.Offset(rds)
     entry(0).Color = acRed
   End If
Next

End Sub
Sub OutRdsComp()

Dim rds As Double
rds = InputBox("请输入偏移距离", "输入")
Dim Outsets As AcadSelectionSet
Dim snum As Integer
Dim existf As Boolean
    For snum = 0 To ThisDrawing.SelectionSets.Count - 1
        If ThisDrawing.SelectionSets.Item(snum).Name = "OutEnts" Then
          existf = True
    Exit For
        End If
    Next
    If existf = True Then
        Set Outsets = ThisDrawing.SelectionSets.Item("OutEnts")
        Outsets.Clear
    Else
        Set Outsets = ThisDrawing.SelectionSets.Add("OutEnts")
    End If
Dim gpCode(0) As Integer
gpCode(0) = 8
Dim dataValue(0) As Variant
dataValue(0) = "OutlayerBAid"
Dim groupCode, dataCode As Variant
groupCode = gpCode
dataCode = dataValue
Outsets.Select acSelectionSetAll, , , groupCode, dataCode  
Dim i, entsnum As Integer
Dim ent As AcadEntity
Dim entry As Variant
entsnum = Outsets.Count
For i = 0 To entsnum - 1
    Set ent = Outsets.Item(i)
    ent.Highlight (True)
    MsgBox "this is" & ent.ObjectName
   
    If StrComp(ent.ObjectName, "AcDbCircle", 1) = 0 Or StrComp(ent.ObjectName, "AcDbEllipse", 1) = 0 Then
     entry = ent.Offset(rds)
      entry(0).Color = acBlue
    Else
     entry = ent.Offset(-rds)
      entry(0).Color = acBlue
     End If
Next

End Sub

                               
登录/注册后可看大图

luln

我执行程序后运行的结果如图

XDSoft

最初由 luln 发布
[B]我执行程序后运行的结果如图 [/B]

对于曲线，除LINE外，输入正值，是往曲线增大的趋势偏移。