8-5.frm

vb6.0编程实例详解,很详细的介绍,对学习VB有帮助

Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim mObject As DrawObject
Dim CurrentObject As Object
Dim CurrentIndex As Long
Dim CurrentSel As Long
Dim CurrentColor As Long
Dim MoveMode As Long
Dim Moving As Boolean
Dim FileName As String


Private Sub Form_Load()
    Set mObject = New DrawObject
End Sub

Private Sub Form_Resize()
    Picture1.Left = ScaleLeft
    Picture1.Top = Toolbar1.Height
    Picture1.Width = ScaleWidth
    If ScaleHeight - StatusBar1.Height > Toolbar1.Height Then
    'Height 属性不能小于“0”
        Picture1.Height = ScaleHeight - Toolbar1.Height - StatusBar1.Height
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set CurrentObject = Nothing
    Set mObject = Nothing
End Sub

Private Sub New_Click()
    '初始化数据
    CurrentSel = 0
    CurrentColor = 0
    MoveMode = 0
    Moving = False
    CurrentIndex = 0
    Set CurrentObject = Nothing
    FileName = ""
    Set mObject = New DrawObject
    '初始化工具条
    Toolbar1.Buttons("Delete").Enabled = False
    Toolbar1.Buttons("Select").Value = tbrPressed
    Toolbar1.Buttons("Black").Value = tbrPressed
    '初始化绘图区
    Picture1.Cls
    Picture1.MousePointer = 0
End Sub

Private Sub Open_Click()
    Dim File As Integer
    
    CommonDialog1.InitDir = App.Path '设置初始路径
    CommonDialog1.FileName = "" '清除文件名
    CommonDialog1.ShowOpen '显示“打开”对话框
    If Len(CommonDialog1.FileName) > 0 Then
        New_Click '初始化数据
        FileName = CommonDialog1.FileName '保存文件名
        File = FreeFile() '获得可用文件号
        Open FileName For Input As File '打开文件
        mObject.Load File '读文件
        Close File '关闭文件
        mObject.Draw Picture1 '显示图形
    End If
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button <> 1 Then Exit Sub '如果未按左键则退出
    
    Select Case CurrentSel
        Case 0
            CurrentIndex = mObject.IsObject(Int(x), Int(y), CurrentObject, MoveMode)
            If CurrentIndex > 0 Then
                Call CurrentObject.SetOldPoint(Int(x), Int(y))
                Toolbar1.Buttons("Delete").Enabled = True
                Moving = True
                ChangeObject
            Else
                Toolbar1.Buttons("Delete").Enabled = False
            End If
        Case 1
            Set CurrentObject = New DrawLine
            Call CurrentObject.SetPoint(1, Int(x), Int(y))
            Call CurrentObject.SetPoint(2, Int(x), Int(y))
            Call CurrentObject.SetOldPoint(Int(x), Int(y))
            CurrentObject.Color = CurrentColor
            MoveMode = 2
            Moving = True
        Case 2
            Set CurrentObject = New DrawReg
            Call CurrentObject.SetPoint(1, Int(x), Int(y))
            Call CurrentObject.SetPoint(2, Int(x), Int(y))
            Call CurrentObject.SetOldPoint(Int(x), Int(y))
            CurrentObject.Color = CurrentColor
            MoveMode = 2
            Moving = True
    End Select
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not Moving Then Exit Sub '如果无移动动作退出
    
    Call CurrentObject.Move(Picture1, Int(x), Int(y), MoveMode)
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Not Moving Then Exit Sub '如果无移动动作退出
    Moving = False '取消移动标志
    
    Select Case CurrentSel
        Case 0 '完成移动图元操作
        '重绘全部图元
            mObject.Draw Picture1
        Case 1 '完成增加线段操作
        '增加线段图元
            Call CurrentObject.Draw(Picture1) '重绘当前图元
            mObject.Add CurrentObject '将当前图元加入集合
        Case 2 '完成增加矩形操作
        '增加矩形图元
            Call CurrentObject.Draw(Picture1)
            mObject.Add CurrentObject '将当前图元加入集合
    End Select
End Sub

Private Sub Picture1_Paint()
    Call mObject.Draw(Picture1) '重绘所有图元
End Sub

Private Sub Print_Click()
    If mObject.Count > 0 And Printers.Count > 0 Then
    '集合中有图元
        mObject.PrintObject Printer  '在输出设备中绘制图元
        Printer.EndDoc '完成绘图，开始打印
    ElseIf mObject.Count = 0 Then
    '集合中无图元
        MsgBox "无可打印的图元数据 ！", , "提示"
    Else
    '无打印机
        MsgBox "系统未安装打印机 ！", , "提示"
    End If
End Sub

Private Sub Save_Click()
    Dim File As Integer
    
    If Len(FileName) = 0 Then
        CommonDialog1.InitDir = App.Path '设置初始路径
        CommonDialog1.FileName = "" '初始化文件名
        CommonDialog1.ShowSave
        FileName = CommonDialog1.FileName
    End If
    
    If Len(FileName) > 0 Then
    '正确输入（选择）文件名
        File = FreeFile()
        Open FileName For Output As File '打开文件
        mObject.Save File '保存数据
        Close File '关闭文件
    End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
        Case "New" '单击工具条按钮1（新文件）
            New_Click
        Case "Open" '单击工具条按钮2（打开）
            Open_Click
        Case "Save" '单击工具条按钮3（保存）
            Save_Click
        Case "Select" '单击工具条按钮4（箭头）
            CurrentSel = 0
            Picture1.MousePointer = 0 '恢复鼠标光标
            Toolbar1.Buttons("Delete").Enabled = False
            CurrentIndex = 0
            Set CurrentObject = Nothing
        Case "Line" '单击工具条按钮5（直线）
            CurrentSel = 1
            Picture1.MousePointer = 2 '设置鼠标光标
            Toolbar1.Buttons("Delete").Enabled = False
        Case "Reg" '单击工具条按钮6（矩形）
            CurrentSel = 2
            Picture1.MousePointer = 2 '设置鼠标光标
            Toolbar1.Buttons("Delete").Enabled = False
        Case "Delete" '单击工具条按钮7（删除）
            DeleteObject
        Case "Red" '单击工具条按钮8（红色）
            ChangeColor vbRed
        Case "Green" '单击工具条按钮9（绿色）
            ChangeColor vbGreen
        Case "Blue" '单击工具条按钮10（兰色）
            ChangeColor vbBlue
        Case "Black" '单击工具条按钮11（黑色）
            ChangeColor vbBlack
    End Select
End Sub

Private Sub DeleteObject()
    Toolbar1.Buttons("Delete").Enabled = False
    mObject.Remove CurrentIndex
    Set CurrentObject = Nothing
    mObject.Draw Picture1
End Sub

Private Sub ChangeColor(Colour As Long)
'修改当前对象颜色
    CurrentColor = Colour
    If CurrentSel = 0 And CurrentIndex > 0 Then
        CurrentObject.Color = Colour
        CurrentObject.Draw Picture1
    End If
End Sub

Private Sub ChangeObject()
'设置工具条颜色按钮
    Select Case CurrentObject.Color
        Case vbRed
            Toolbar1.Buttons("Red").Value = tbrPressed
        Case vbGreen
            Toolbar1.Buttons("Green").Value = tbrPressed
        Case vbBlue
            Toolbar1.Buttons("Blue").Value = tbrPressed
        Case vbBlack
            Toolbar1.Buttons("Black").Value = tbrPressed
    End Select
End Sub