rail.cls

用VB语言编写铁路的图例

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "Rail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
'2005年10月8日于郑州大学
'赵老师的方法
'先用黑色画笔画实心线,然后用白色画笔分块填充
'类名:Rail2
'功能:画黑白交叉的铁路线
'接口:
'    属性:
'        RailWidth(ByVal tieLength As Double)铁路的宽度
'        RailLength(ByVal tieSpacing As Double)铁路的长度
'    方法:
'       SetupDC(hdc As Long, dpi As Double, baseSym As Object) 初始化设备环境,hdc:
'       设备场景;dpi:?;baseSym:当前对象的Symbol属性
'       Sub Draw(hdc As Long, points As Long, partCounts As Long, numParts As Long)
'       画线函数,hdc:设备场景;points:所有点的坐标;partCounts:指针,指向各段所包括点的个数
'       numparts:段数,总共有多少段
'       ResetDC(hdc As Long)删除类中不用的对象,hdc:设备环境
'是否需要设置颜色属性?
Option Explicit

Private Type LineSegment                                    '线段的用户定义类型
  x1 As Long
  x2 As Long
  y1 As Long
  y2 As Long
End Type

Private Type POINTAPI                                       '点的用户定义类型
  x As Long
  y As Long
End Type

Dim g_hOldPen As Long                                       '原来的画笔
Dim g_blackPen As Long                                      '黑色画笔
Dim g_whitePen As Long                                      '白色画笔
    
Private g_RailWidth As Double                               '铁路单元的宽度
Private g_RailLength As Double                               '铁路单元的长度

Private Declare Function Polyline Lib "gdi32" (ByVal hdc As Long, lppt As POINTAPI, ByVal cCount As Long) As Long
Private Declare Function PolylineL Lib "gdi32" Alias "Polyline" (ByVal hdc As Long, ByVal lppt As Long, ByVal cCount As Long) As Long

Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

Private Declare Function MoveTo Lib "gdi32" Alias "MoveToEx" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpPoint As Long) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'求线段的长度
Private Function Length(ln As LineSegment) As Double
  Length = Sqr((ln.x1 - ln.x2) * (ln.x1 - ln.x2) + (ln.y1 - ln.y2) * (ln.y1 - ln.y2))
End Function
'求线段的角度
Private Function Angle(ln As LineSegment) As Double
  Dim x As Double
  Dim y As Double
  
  x = CDbl(ln.x2 - ln.x1)
  y = CDbl(ln.y2 - ln.y1)
  
  Dim result As Double
  If x = 0 Then     ' vertical
    result = Atn(1) * 2 ' 90 degrees
  Else
    result = Atn(y / x)
  End If
  
  ' adjust angle to quadrant.  Atn(1) = 45 degrees
  result = Abs(result)
  If 0 <= x And 0 <= y Then     'quadrant 1
    Angle = result
  ElseIf x < 0 And 0 <= y Then  'quadrant 2
    Angle = Atn(1) * 4 - result
  ElseIf x < 0 And y < 0 Then   'quadrant 3
    Angle = -Atn(1) * 4 + result
  Else                          'quadrant 4
    Angle = -result
  End If
End Function

Public Sub SetupDC(hdc As Long, dpi As Double, baseSym As Object)
  '如果没有设置线的长度或宽度，使用默认值
  If g_RailLength = 0 Then g_RailLength = 6
  If g_RailWidth = 0 Then g_RailWidth = 4
  ' Set pen attributes to match base symbol
  g_blackPen = CreatePen(baseSym.Style, g_RailWidth, moBlack)
  '将白色的画笔设的窄些,以把黑色的边框露出来
  g_whitePen = CreatePen(baseSym.Style, g_RailWidth - 1.9, moWhite)
  g_hOldPen = SelectObject(hdc, g_blackPen)
End Sub

Public Sub Draw(hdc As Long, points As Long, partCounts As Long, numParts As Long)
  Dim pl As New MoHelper.MultiShape                         ' new polyline
  pl.Init points, partCounts, numParts
  Dim l As MoHelper.Shape                                   ' line pointer

  Dim i As Long
  For i = 0 To numParts - 1
    Set l = pl.Part(i)                                      ' point to next line
    'Debug.Print "count: " + CStr(i) + ":" + CStr(l.Count)
    SelectObject hdc, g_blackPen                            '将黑色画笔选入
    PolylineL hdc, l.Pointer, l.count                       '画黑色线
    SelectObject hdc, g_whitePen                            '将白色画笔选入
     DrawRail hdc, l                                        '画白色的点画线(即用白色的短线覆盖)
   Next i
End Sub
 
Public Sub ResetDC(hdc As Long)
  ' clean up pen
  If Not g_blackPen = 0 Then
    SelectObject hdc, g_hOldPen
    DeleteObject g_blackPen
  End If
  
   If Not g_whitePen = 0 Then
    SelectObject hdc, g_hOldPen
    DeleteObject g_whitePen
    End If
End Sub
'铁路的宽度属性
Property Get RailWidth() As Double
  RailWidth = g_RailWidth
End Property
'铁路的宽度属性
Property Let RailWidth(ByVal tieLength As Double)
  If tieLength < 0 Then
    Err.Raise Number:=vbObjectError + 6000, Description:="Length less than zero"
  Else
    g_RailWidth = tieLength
  End If
End Property
'铁路的长度属性
Property Get RailLength() As Double
  RailLength = g_RailLength
End Property
'铁路的长度属性
Property Let RailLength(ByVal tieSpacing As Double)
  If tieSpacing < 0 Then
    Err.Raise Number:=vbObjectError + 6001, Description:="Spacing less than zero"
  Else
    g_RailLength = tieSpacing
  End If
End Property

Private Sub DrawRail(hdc As Long, l As MoHelper.Shape)
  Dim measure As Double                                     '从开始点到当前点的长度
  Dim runningSegLength As Double                            '前一段的长度
  Dim dblRailLength As Double                               '存储铁路长度的double型
  Dim segLength As Double                                   '存储当前一段的长度
  Dim ang As Double                                         '存储当前一段的角度
  Dim sina As Double                                        '存储当前一段的正弦
  Dim cosa As Double                                        '存储当前一段的余弦
  Dim curLength As Double                                   '存储当前线段的起点到当前点的长度
  Dim tie(2) As POINTAPI                                    '存储要画的线段的两个端点
  Dim IsOrNotInflex As Integer                              '是不是拐点
  Dim j As Integer                                          'tie的下标,以判断是否画线

  'total distance to the current position
  runningSegLength = 0                                      '前一线段的长度
'  dblRailWidth = CDbl(g_RailWidth)
  dblRailLength = CDbl(g_RailLength)
  measure = dblRailLength                                   '设置开始点距离铁路线的起始点长度为一个铁路单元长度
    
  Dim i As Long
  For i = 1 To l.count - 1
    Dim seg As LineSegment
    seg.x1 = l.x(i - 1)
    seg.y1 = l.y(i - 1)
    seg.x2 = l.x(i)
    seg.y2 = l.y(i)
    segLength = Length(seg)
    ang = Angle(seg)
    sina = Sin(ang)
    cosa = Cos(ang)
   
    'loop until we go past the end of the segment
    Do While (measure <= (runningSegLength + segLength))

      'compute the length along the current segment
      curLength = measure - runningSegLength

      tie(j).x = seg.x1 + cosa * curLength                  '存储线段的端点
      tie(j).y = seg.y1 + sina * curLength
      j = j + 1
      'draw the tie and update the measure
      If j = 2 Then                                         '如果是线段的末端
        MoveTo hdc, tie(0).x, tie(0).y, 0                   '就用白色画笔画
        LineTo hdc, tie(1).x, tie(1).y
        j = 0                                               '将j置为0,供后面的使用
        measure = measure + dblRailLength                   '黑色线段
      Else
        measure = measure + dblRailLength                   '白色线段
    End If
    
    Loop
    If j = 1 Then                                           '如果当前段应该填充白色
        tie(1).x = seg.x2: tie(1).y = seg.y2                '恰好又是当前段的末端,
        MoveTo hdc, tie(0).x, tie(0).y, 0                   '那么先填充当前不足一个
        LineTo hdc, tie(1).x, tie(1).y                      '铁路单元的部分,将应填充
        tie(0) = tie(1)                                     '铁路单元的起点设置为下一段的起点
    End If
    'we've finished with this segment, update the running segment length
    runningSegLength = runningSegLength + segLength         '更新前面线段的长度
  Next i
End Sub