form1.frm

用vb做的一个关于学生信息管理的系统

    Toolbar1.Buttons("Delete").Enabled = False
End Sub

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 Green_Click()
    ChangeColor vbGreen
    Toolbar2.Buttons("Black").Value = tbrUnpressed
    Toolbar2.Buttons("Red").Value = tbrUnpressed
    Toolbar2.Buttons("Green").Value = tbrPressed
    Toolbar2.Buttons("Blue").Value = tbrUnpressed
    Toolbar2.Buttons("Yellow").Value = tbrUnpressed
End Sub

Private Sub Line_Click()
    CurrentSel = 1
    Picture1.MousePointer = 2 '设置鼠标光标
    Toolbar1.Buttons("Delete").Enabled = False
End Sub

Private Sub New_Click()
    '初始化数据
    If mObject.Count > 0 Then
        Response = MsgBox("保存工作吗？", vbYesNoCancel)
        If Response = vbYes Then
            Save_Click
        ElseIf Response = vbNo Then
            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
            Toolbar2.Buttons("Black").Value = tbrPressed
            '初始化绘图区
            Picture1.Cls
            Picture1.MousePointer = 0
        End If
    End If
End Sub

Private Sub Open_Click()
    Dim File As Integer
    
    If mObject.Count > 0 Then
        Response = MsgBox("保存工作吗？", vbYesNoCancel)
        If Response = vbYes Then
            Save_Click
        ElseIf Response = vbNo Then
            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
            Toolbar2.Buttons("Black").Value = tbrPressed
            '初始化绘图区
            Picture1.Cls
            Picture1.MousePointer = 0
            CommonDialog1.InitDir = App.Path '设置初始路径
            CommonDialog1.FileName = "" '清除文件名
            CommonDialog1.ShowOpen '显示“打开”对话框
            FileName = CommonDialog1.FileName '保存文件名
            If Len(CommonDialog1.FileName) > 0 Then
                File = FreeFile() '获得可用文件号
                Open FileName For Input As File '打开文件
                mObject.Load File '读文件
                Close File '关闭文件
                mObject.Draw Picture1 '显示图形
            End If
        End If
    Else
            CommonDialog1.InitDir = App.Path '设置初始路径
            CommonDialog1.FileName = "" '清除文件名
            CommonDialog1.ShowOpen '显示“打开”对话框
            FileName = CommonDialog1.FileName '保存文件名
            If Len(CommonDialog1.FileName) > 0 Then
                File = FreeFile() '获得可用文件号
                Open FileName For Input As File '打开文件
                mObject.Load File '读文件
                Close File '关闭文件
                mObject.Draw Picture1 '显示图形
            End If
    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 DrawRec
            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 3
            Set CurrentObject = New DrawCircle
            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 '将当前图元加入集合
        Case 3 '完成增加圆形操作
        '增加矩形图元
            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 Rec_Click()
    CurrentSel = 2
    Picture1.MousePointer = 2 '设置鼠标光标
    Toolbar1.Buttons("Delete").Enabled = False

End Sub

Private Sub Red_Click()
    ChangeColor vbRed
    Toolbar2.Buttons("Black").Value = tbrUnpressed
    Toolbar2.Buttons("Red").Value = tbrPressed
    Toolbar2.Buttons("Green").Value = tbrUnpressed
    Toolbar2.Buttons("Blue").Value = tbrUnpressed
    Toolbar2.Buttons("Yellow").Value = tbrUnpressed
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 SaveAs_Click()
    Dim File As Integer
    
    CommonDialog1.InitDir = App.Path '设置初始路径
    CommonDialog1.FileName = "" '初始化文件名
    CommonDialog1.ShowSave
    FileName = CommonDialog1.FileName
    
    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 "Circle" '单击工具条按钮6（圆形）
            CurrentSel = 3
            Picture1.MousePointer = 2 '设置鼠标光标
            Toolbar1.Buttons("Delete").Enabled = False
        Case "Delete" '单击工具条按钮7（删除）
            DeleteObject
    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
            Toolbar2.Buttons("Red").Value = tbrPressed
        Case vbGreen
            Toolbar2.Buttons("Green").Value = tbrPressed
        Case vbBlue
            Toolbar2.Buttons("Blue").Value = tbrPressed
        Case vbYellow
            Toolbar2.Buttons("Yellow").Value = tbrPressed
        Case vbBlack
            Toolbar2.Buttons("Black").Value = tbrPressed
    End Select
End Sub

Private Sub Toolbar2_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
        Case "Red" '单击工具条按钮2（红色）
            ChangeColor vbRed
        Case "Green" '单击工具条按钮3（绿色）
            ChangeColor vbGreen
        Case "Blue" '单击工具条按钮4（蓝色）
            ChangeColor vbBlue
        Case "Yellow" '单击工具条按钮5（黄色）
            ChangeColor vbYellow
        Case "Black" '单击工具条按钮1（黑色）
            ChangeColor vbBlack
    End Select
End Sub

Private Sub Yellow_Click()
    ChangeColor vbYellow
    Toolbar2.Buttons("Black").Value = tbrUnpressed
    Toolbar2.Buttons("Red").Value = tbrUnpressed
    Toolbar2.Buttons("Green").Value = tbrUnpressed
    Toolbar2.Buttons("Blue").Value = tbrUnpressed
    Toolbar2.Buttons("Yellow").Value = tbrPressed
End Sub