cline.vb

苏金明编写的《用VB.NET和VC#.NET开发交互式CAD系统》一书的源代码

'直线段类

Imports System.Math

Public Class CLine
    Inherits CGElement

    Private m_Begin, m_End As PointF

    '直线段的起点属性
    Public Property LBegin() As PointF
        Get
            Return m_Begin
        End Get
        Set(ByVal Value As PointF)
            m_Begin = Value
        End Set
    End Property

    '直线段的终点属性
    Public Property LEnd() As PointF
        Get
            Return m_End
        End Get
        Set(ByVal Value As PointF)
            m_End = Value
        End Set
    End Property

    '无参构造函数
    Public Sub New()
        Init()
    End Sub

    '构造函数，用已知的两点构造直线段
    Public Sub New(ByVal pBegin As PointF, ByVal pEnd As PointF)
        Init()
        m_Begin = pBegin
        m_End = pEnd
    End Sub

    '构造函数，用已知的直线段构造直线段
    Public Sub New(ByVal aline As CLine)
        m_Begin = aline.LBegin
        m_End = aline.LEnd
    End Sub

    '初始化直线段
    Private Shadows Sub Init()
        MyBase.Init()
        With m_Begin
            .X = 0
            .Y = 0
        End With
        m_End = m_Begin
    End Sub

    '绘直线段
    Public Overrides Sub Draw(ByVal g As Graphics, ByVal aDrawMode As geDrawMode)

        '将直线段的起点和终点坐标转换为页面坐标
        Dim eb As PointF = WorldtoPage(m_Begin)
        Dim ee As PointF = WorldtoPage(m_End)

        '获取绘图环境的句柄
        Dim hdc As IntPtr
        hdc = g.GetHdc()
        '设置画笔参数
        Dim penPara As Integer() = DrawSettings(hdc, aDrawMode)
        '创建画笔
        Dim aPen As Long = Win32API.CreatePen(penPara(0), penPara(1), penPara(2))
        '把画笔选入绘图环境，并返回原来的画笔
        Dim oldP As Long = Win32API.SelectObject(hdc, aPen)
        '把画笔移动到直线段的起点处
        Win32API.MoveToEx(hdc, eb.X, eb.Y, Nothing)
        '绘直线段到终点
        Win32API.LineTo(hdc, ee.X, ee.Y)
        '把原来的画笔选入绘图环境
        Win32API.SelectObject(hdc, oldP)
        '删除新创建的画笔
        Win32API.DeleteObject(aPen)
        '释放绘图环境句柄
        g.ReleaseHdc(hdc)

    End Sub

    '计算包围矩形
    Public Overrides Function GetBox() As CBox
        Dim aBox As New CBox()
        '分竖直、水平和倾斜三种情况计算直线段的包围矩形
        If m_Begin.X = m_End.X Then
            aBox.minX = m_Begin.X - PickRadius
            aBox.minY = Min(m_Begin.Y, m_End.Y)
            aBox.maxX = m_Begin.X + PickRadius
            aBox.maxY = Max(m_Begin.Y, m_End.Y)
        ElseIf m_Begin.Y = m_End.Y Then
            aBox.minX = Min(m_Begin.X, m_End.X)
            aBox.minY = m_Begin.Y - PickRadius
            aBox.maxX = Max(m_Begin.X, m_End.X)
            aBox.maxY = m_Begin.Y + PickRadius
        Else
            aBox.minX = Min(m_Begin.X, m_End.X)
            aBox.minY = Min(m_Begin.Y, m_End.Y)
            aBox.maxX = Max(m_Begin.X, m_End.X)
            aBox.maxY = Max(m_Begin.Y, m_End.Y)
        End If
        Return aBox
    End Function

    '计算点到直线段的距离
    Private Function distPtoL(ByVal aPos As PointF, ByVal pB As PointF, _
        ByVal pE As PointF) As Single
        Dim kc(1) As Single
        Dim px As Single = aPos.X
        Dim py As Single = aPos.Y
        Dim distX As Single
        Dim distY As Single
        Dim dist As Single

        '获取直线段的截距式方程，返回斜率和截距
        kc = LineKX(pB, pE)
        '如果为水平直线段
        If kc(0) = 0 Then
            distX = 10000
            distY = Abs(py - pB.Y)
            '如果为竖直直线段
        ElseIf kc(0) = 10000 Then
            distX = Abs(px - pB.X)
            distY = 10000
            '如果为斜线
        Else
            distX = Abs(px - (py - kc(1)) / kc(0))
            distY = Abs(py - (kc(0) * px + kc(1)))
        End If
        '返回水平距离和竖直距离之间的小值
        dist = Min(distX, distY)
        Return dist
    End Function

    '计算直线段的截距式方程
    Private Function LineKX(ByVal pB As PointF, ByVal pE As PointF) As Single()
        Dim kc(1) As Single
        '若直线段不为竖直线段
        If pB.X <> pE.X Then
            'Console.WriteLine(Str(pB.X) & Str(pB.Y))
            kc(0) = (pE.Y - pB.Y) / (pE.X - pB.X)
            '如果是竖直线段
        Else
            kc(0) = 10000
        End If
        '计算截距
        kc(1) = pB.Y - kc(0) * pB.X
        Return kc
    End Function

    '拾取直线段
    Public Overrides Function Pick(ByVal aPos As PointF) As Boolean
        Dim geBox As New CBox()

        '判断拾取点是否在测试包围矩形中，若不是，
        '则直线段不被拾取
        If (Not InBox(GetBox, aPos)) Then
            Return False
        Else
            '如果拾取点位于包围矩形中，且到直线段的距离小于拾取半径，
            '则直线段被拾取；否则不被拾取
            If distPtoL(aPos, m_Begin, m_End) <= PickRadius Then
                Return True
            Else
                Return False
            End If
        End If
    End Function

End Class