form1.frm

这是自己开发的一个绘图软件系统

MsgBox ("这是一个用vb开发的一个绘图软件")
End Sub

Private Sub exit_Click()
Dim gotoval
Dim gointo
gotoval = Me.Height / 2
For gointo = 1 To gotoval
DoEvents
    Me.Height = Me.Height - 10
    If Me.Height <= 11 Then
    End
    End If
Next gointo
Me.Height = 30
gotoval = Me.Width / 2
For gointo = 1 To gotoval
DoEvents
    Me.Width = Me.Width - 10
    If Me.Width <= 11 Then End
    Next gointo
 End
End Sub

Private Sub filenew_Click()
Picture1.Picture = LoadPicture()
    Filename = "Untitled"
    Form1.Caption = Filename

End Sub

Private Sub fileopen_Click()
CommonDialog1.Filter = "bmp文件|*.bmp|所有文件|*.*"
CommonDialog1.Action = 1
'CommonDialog1.ShowOpen
Picture1.Picture = LoadPicture(CommonDialog1.Filename)
End Sub

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

Private Sub filesave_Click()
Dim i
CommonDialog1.Filter = "bmp文件|*.bmp|所有文件|*.*"
    ' 设置缺省过滤器
    CommonDialog1.FilterIndex = 2
    If Filename = "Untitled" Then
        '如果文件尚未命名，则显示保存对话框
        CommonDialog1.ShowSave
        Filename = CommonDialog1.Filename
        If Filename <> "" Then
            SavePicture Picture1.Image, Filename
            Animation2.Open App.Path + "\FILECOPY.AVI"
            Animation2.Play
            Do While i < 28000000#
              i = i + 1
            Loop
             
            If i = 28000000# Then
            Animation2.stop
            Animation2.Close
              End If
        End If
    Else
        '否则直接保存
        SavePicture Picture1.Image, Filename
    End If
    Form1.Caption = Filename
End Sub

Private Sub Form_Load()
    
    Picture1.AutoRedraw = True
    
    Picture1.Picture = LoadPicture()
End Sub

Private Sub inner_Click()
CommonDialog1.Action = 3

Picture1.FillColor = CommonDialog1.Color
End Sub

Private Sub past_Click()
Picture1.Picture = Clipboard.GetData()
End Sub

Private Sub pen_Click()
CommonDialog1.Action = 3
Picture1.ForeColor = CommonDialog1.Color
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
 Select Case drawact
        ' 橡皮
        Case 0
            canrubber = True
            Picture1.CurrentX = x: Picture1.CurrentY = y
            Picture1.DrawMode = 13
            Picture1.drawwidth = 7
        ' 直线
        Case 1
            canline = True
            x0 = x: y0 = y
            xnow = x: ynow = y
            Picture1.DrawMode = 7
            Picture1.drawwidth = 1
        ' 矩形
        Case 2
            canrectangle = True
            x0 = x: y0 = y
            xnow = x: ynow = y
            Picture1.DrawMode = 7
            Picture1.drawwidth = 2
        ' 椭圆
        Case 3
            canellipse = True
            x0 = x: y0 = y
            xnow = x: ynow = y
            Picture1.DrawMode = 7
            Picture1.drawwidth = 1
        ' 铅笔
        Case 4
            canpen = True
            Picture1.CurrentX = x: Picture1.CurrentY = y
            Picture1.DrawMode = 13
        ' 刷子
        Case 5
            canbrush = True
            Picture1.CurrentX = x: Picture1.CurrentY = y
            Picture1.DrawMode = 13
            Picture1.drawwidth = 5
        End Select
End Sub

Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
StatusBar1.Panels(3).Text = "x=" + Str(x)
StatusBar1.Panels(4).Text = "y=" + Str(y)
 
 
 Select Case drawact
        ' 橡皮
        Case 0
            If canrubber Then
                Picture1.Line -(x, y), BackColor
            End If
        ' 直线
        Case 1
            If canline Then
                Picture1.Line (x0, y0)-(xnow, ynow), Not (Picture1.ForeColor)
                Picture1.Line (x0, y0)-(x, y), Not (Picture1.ForeColor)
                xnow = x: ynow = y
            End If
        ' 矩形
        Case 2
            If canrectangle Then
                Picture1.Line (x0, y0)-(xnow, ynow), Not (Picture1.ForeColor), B
                Picture1.Line (x0, y0)-(x, y), Not (Picture1.ForeColor), B
                xnow = x: ynow = y
            End If
        ' 椭圆
        Case 3
                radius0 = Sqr((xnow - x0) ^ 2 + (ynow - y0) ^ 2)
                radius = Sqr((x - x0) ^ 2 + (y - y0) ^ 2)
            If canellipse Then
                Picture1.Circle (x0, y0), radius0, Not (Picture1.ForeColor)
                Picture1.Circle (x0, y0), radius, Not (Picture1.ForeColor)
                xnow = x: ynow = y
            End If
        ' 铅笔
        Case 4
            If canpen Then
                Picture1.Line -(x, y), Picture1.ForeColor
            End If
        ' 刷子
        Case 5
            If canbrush Then
                Picture1.Line -(x, y), Picture1.ForeColor
            End If
            End Select
End Sub

Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
 Select Case drawact
        Case 1
            canline = False
            Picture1.Line (x0, y0)-(xnow, ynow)
            Picture1.DrawMode = 13
            Picture1.Line (x0, y0)-(xnow, ynow), Picture1.ForeColor
        Case 2
            canrectangle = False
            Picture1.Line (x0, y0)-(xnow, ynow), Not (Picture1.ForeColor), B
            Picture1.DrawMode = 13
            Picture1.Line (x0, y0)-(xnow, ynow), Picture1.ForeColor, B
        Case 3
            canellipse = False
            Picture1.Circle (x0, y0), radius, Not (Picture1.ForeColor)
            Picture1.DrawMode = 13
            Picture1.Circle (x0, y0), radius, Picture1.ForeColor
        Case 4
            canpen = False
        Case 5
            canbrush = False
            End Select
End Sub

Private Sub small_Click()
Picture1.drawwidth = 3
End Sub

Private Sub special_Click()
Dim x
Dim y
'Picture1.ForeColor = Picture1.ForeColor
For x = 1 To Picture1.Width Step 20
   For y = 1 To Picture1.Height Step 20
   Picture1.PSet (x, y), Picture1.ForeColor
   Next y
Next x
End Sub

Private Sub StatusBar1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
'StatusBar1.Panels(3).Text = "x=" + Str(x)
'StatusBar1.Panels(4).Text = "y=" + Str(y)

End Sub

Private Sub StatusBar1_PanelClick(ByVal Panel As MSComctlLib.Panel)
' StatusBar1.Width = "3500"
End Sub

Private Sub stop_Click()
Dim gotoval
Dim gointo
gotoval = Me.Height / 2
For gointo = 1 To gotoval
DoEvents
    Me.Height = Me.Height - 10
    If Me.Height <= 11 Then
    End
    End If
Next gointo
Me.Height = 30
gotoval = Me.Width / 2
For gointo = 1 To gotoval
DoEvents
    Me.Width = Me.Width - 10
    If Me.Width <= 11 Then End
    Next gointo
 End
End Sub

Private Sub Timer1_Timer()

time = time - 1
If time = 0 Then
Animation2.Close




End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1
drawact = 0
Case 2
drawact = 1
Case 3
drawact = 2
Case 4
drawact = 3
Case 5
drawact = 4
Case 6
drawact = 5


End Select
End Sub