[求助]铁路线怎么画？？

phoenixdjq

因为文件格式不对，压缩后就能上传了

dzt

我也试了，的确黑白间隔不等，而且拟合后，有些白色的框框数量减少，导致黑白间隔差距更大，这到底为什么？能有更好的处理方法吗？

dianbotang

绘制铁路线的vba程序，适用于将多条多段线转为铁路线，有兴趣的朋友可以据此改进满足自身需要。

对于样条曲线，直线和圆弧，可以先转为多段线。

Option Explicit
'绘制铁路线
Sub Railway()
    On Error GoTo ErrorHandler

    Dim SSet As AcadSelectionSet
    Set SSet = ThisDrawing.PickfirstSelectionSet
    If SSet.Count = 0 Then
      MsgBox "未选择对象"
      Exit Sub
    End If
   
    AppActivate ThisDrawing.Application.Caption
    Dim Width As Double
    Width = ThisDrawing.Utility.GetReal(vbLf & "请输入铁路线宽: ")
    Dim currLTScale As Double
    currLTScale = ThisDrawing.Utility.GetReal(vbLf & "请输入铁路线型比例: ")
    Dim currLinetype As String
    currLinetype = ThisDrawing.Utility.GetString(False, vbLf & "请输入铁路线型: ")
       
    Dim entry As AcadLineType
    Dim found As Boolean
    found = False
    For Each entry In ThisDrawing.Linetypes
        If StrComp(entry.Name, currLinetype, 1) = 0 Then
            found = True
            Exit For
        End If
    Next
    If Not (found) Then ThisDrawing.Linetypes.Load currLinetype, "acad.lin"

    Dim PlineObj As AcadEntity
    Dim OffsetObj1 As Variant
    Dim OffsetObj2 As Variant
    For Each PlineObj In SSet
      If TypeName(PlineObj) Like "IAcad*Polyline" Then
        OffsetObj1 = PlineObj.Offset(Width / 2)
        OffsetObj2 = PlineObj.Offset(-Width / 2)
        PlineObj.ConstantWidth = Width
        PlineObj.LinetypeScale = currLTScale
        PlineObj.Linetype = currLinetype
        PlineObj.LinetypeGeneration = True
      End If
    Next
    ThisDrawing.Regen True
    Exit Sub
   
ErrorHandler:
  MsgBox Err.Description
   
End Sub