8-5l.cls

vb6.0编程实例详解,很详细的介绍,对学习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 = "DrawLine"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"DrawObject"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'自定义局部变量
Private mvarPoint1 As POINT
Private mvarPoint2 As POINT
Private mvarPoint As POINT

'保持属性值的局部变量
Private mvarColor As Long '局部复制

Public Sub SetPoint(Position As Long, x As Long, y As Long)
    Select Case Position
        Case 1 '设置第一点坐标
            mvarPoint1.x = x
            mvarPoint1.y = y
        Case 2 '设置第二点坐标
            mvarPoint2.x = x
            mvarPoint2.y = y
    End Select
End Sub

Public Property Let Color(ByVal vData As Long)
'向属性指派值时使用，位于赋值语句的左边。
'Syntax: X.Color = 5
    mvarColor = vData
End Property

Public Property Get Color() As Long
'检索属性值时使用，位于赋值语句的右边。
'Syntax: Debug.Print X.Color
    Color = mvarColor
End Property

Public Sub SetOldPoint(x As Long, y As Long)
'设置参考点坐标
    mvarPoint.x = x
    mvarPoint.y = y
End Sub

Public Sub Move(Drawing As Object, x As Long, y As Long, Optional Style As Long = 0)
'以不同方式移动线段
    Dim mStyle As Long
    Dim mColor As Long
    Dim mMode As Long
    
    mMode = Drawing.DrawMode '保存绘图模式
    mColor = Drawing.ForeColor '保存前景色
    
    Drawing.DrawMode = 7 '设置为“异或”模式
    Drawing.ForeColor = Drawing.BackColor Xor Color '设置异或模式前景色
                            '异或模式的前景色为复制模式前景色与绘图区背景色的异或值
    '删除原来图元显示
    Drawing.Line (mvarPoint1.x, mvarPoint1.y)-(mvarPoint2.x, mvarPoint2.y)
    Select Case Style
        Case 1
            mvarPoint1.x = x '更新第一点坐标
            mvarPoint1.y = y
        Case 2
            mvarPoint2.x = x '更新第二点坐标
            mvarPoint2.y = y
        Case 3
            mvarPoint1.x = mvarPoint1.x + x - mvarPoint.x '更新线段坐标
            mvarPoint1.y = mvarPoint1.y + y - mvarPoint.y
            mvarPoint2.x = mvarPoint2.x + x - mvarPoint.x
            mvarPoint2.y = mvarPoint2.y + y - mvarPoint.y
            mvarPoint.x = x '更新参考点坐标
            mvarPoint.y = y
    End Select
    '重绘图元
    Drawing.Line (mvarPoint1.x, mvarPoint1.y)-(mvarPoint2.x, mvarPoint2.y)
    
    '恢复绘图区原始设置
    Drawing.ForeColor = mColor
    Drawing.DrawMode = mMode
End Sub

Private Function OnLine(x As Long, y As Long) As Boolean
'计算点是否在线段上
    Dim A As Single
    Dim B As Single
    Dim C As Single
    
    If mvarPoint1.x = mvarPoint2.x Then
    '该线段为垂线（斜率为无穷大）
        If (y - mvarPoint1.y) * (y - mvarPoint2.y) < 0 And Abs(x - mvarPoint1.x) < MAXDISTANCE Then
            OnLine = True
            Exit Function
        End If
    ElseIf (x - mvarPoint1.x) * (x - mvarPoint2.x) < 0 Then
    '应用直线的两点方程推导其一般方程
    '应用一般方程点到直线的距离解算
        A = (mvarPoint2.y - mvarPoint1.y) / (mvarPoint2.x - mvarPoint1.x)
        B = -1
        C = mvarPoint1.y - A * mvarPoint1.x
        If (A * x + B * y + C) * (A * x + B * y + C) / (A * A + B * B) < MAXDISTANCE * MAXDISTANCE Then
            OnLine = True
            Exit Function
        End If
    End If
    
    '点不在直线上
    OnLine = False
End Function

Public Function IsCurrent(x As Long, y As Long) As Long
'判断（X，Y）是否在当前线段上

    '假设指定点不在当前线段上
    IsCurrent = 0
    
    '开始判断输入点与线段的关系
    If (mvarPoint1.x - x) * (mvarPoint1.x - x) + (mvarPoint1.y - y) * (mvarPoint1.y - y) < MAXDISTANCE * MAXDISTANCE Then
    '指向第一点
        IsCurrent = 1
    ElseIf (mvarPoint2.x - x) * (mvarPoint2.x - x) + (mvarPoint2.y - y) * (mvarPoint2.y - y) < MAXDISTANCE * MAXDISTANCE Then
    '指向第二点
        IsCurrent = 2
    ElseIf OnLine(x, y) Then
    '指向线段本身
        IsCurrent = 3
    End If
End Function

Public Sub Draw(Drawing As Object)
Attribute Draw.VB_Description = "绘制当前直线"
'绘制线段
    Dim mColor As Long
    Dim mMode As Long
    
    mMode = Drawing.DrawMode '保存绘图模式
    mColor = Drawing.ForeColor '保存前景色
    
    Drawing.DrawMode = 13 '设置为“复制”模式
    Drawing.ForeColor = mvarColor '设置前景色
    
    '绘制线
    Drawing.Line (mvarPoint1.x, mvarPoint1.y)-(mvarPoint2.x, mvarPoint2.y)
    
    '恢复绘图区原始设置
    Drawing.ForeColor = mColor
    Drawing.DrawMode = mMode
End Sub

Public Sub Save(File As Integer)
'写线段图元数据
    Write #File, 1, mvarPoint1.x, mvarPoint1.y, mvarPoint2.x, mvarPoint2.y, mvarColor
End Sub

Public Sub Load(File As Integer)
'读线段图元数据
    Input #File, mvarPoint1.x, mvarPoint1.y, mvarPoint2.x, mvarPoint2.y, mvarColor
End Sub

Public Sub PrintObject(Drawing As Object)
'打印线段
    Dim mColor As Long
    
    On Error Resume Next '执行错误处理
    mColor = Drawing.ForeColor '保存前景色
    Drawing.ForeColor = mvarColor '设置前景色
    '绘制线
    Drawing.Line (mvarPoint1.x, mvarPoint1.y)-(mvarPoint2.x, mvarPoint2.y)
    Drawing.ForeColor = mColor '恢复前景色
    Exit Sub
End Sub