formmain.txt

来自「一个用vb的经典的图形编辑程序」· 文本 代码 · 共 1,047 行 · 第 1/3 页

  For j = 0 To 10
  DoEvents
  Next j
Next i
Loop
End Sub

Private Sub jianqie_Click(Index As Integer)
  Dim width1 As Single, height1 As Single
  width1 = xnow11 - x11: height1 = ynow11 - y11
  PicBackup.Picture = PicMain.Image
  PicBaocun.Width = width1: PicBaocun.Height = height1
  PicBaocun.PaintPicture PicMain.Picture, 0, 0, width1, height1, x11, y11, width1, height1, vbSrcCopy
  PicMain.Line (xnow11, ynow11)-(x11, y11), vbWhite, BF
  Clipboard.Clear
  Clipboard.SetData PicBaocun.Image
End Sub

Private Sub jiaquanping_Click()
Dim ping0 As Long
  PicBackup.Picture = PicMain.Image
  cx = PicMain.ScaleWidth
  cy = PicMain.ScaleHeight
  ReDim Arrycol(2, cx, cy)
  For i = 1 To cx
   For j = 1 To cy
     tmlcolor = GetPixel(FormMain.PicMain.hdc, i, j)
     r = tmlcolor Mod 256
     g = ((tmlcolor And &HFF00) / 256) Mod 256
     b = (tmlcolor And &HFF0000) / 65536
     ping0 = (3 * r + 6 * g + b) / 10
     Arrycol(0, i, j) = ping0
     Arrycol(1, i, j) = ping0
     Arrycol(2, i, j) = ping0
     Next j
  Next i
  For i1 = 0 To cx - 1
     For j1 = 0 To cy - 1
    r1 = Arrycol(0, i1, j1)
    g1 = Arrycol(1, i1, j1)
    b1 = Arrycol(2, i1, j1)
     PicMain.PSet (i1, j1), RGB(r1, g1, b1)
    Next j1
  Next i1
End Sub

Private Sub K1_Click()
  PicBackup.Picture = PicMain.Image
  cx = PicMain.ScaleWidth
  cy = PicMain.ScaleHeight
  ReDim Arrycol(2, cx, cy)
  For i = 1 To cx
   For j = 1 To cy
     tmlcolor = GetPixel(FormMain.PicMain.hdc, i, j)
     r2 = tmlcolor Mod 256
     g2 = ((tmlcolor And &HFF00) / 256) Mod 256
     b2 = (tmlcolor And &HFF0000) / 65536
     Arrycol(0, i, j) = r2
     Arrycol(1, i, j) = g2
     Arrycol(2, i, j) = b2
     Next j
  Next i
   For i1 = 2 To cx - 2
     For j1 = 2 To cy - 2
      Np1 = Int(Rnd * 3 + i1 - 1)                         '产生随即的从i1-1 到i1+1的数值
      Np2 = Int(Rnd * 3 + j1 - 1)                         '产生随即的从j1-1到j1+1的数值
      r1 = Arrycol(0, Np1, Np2)
      g1 = Arrycol(1, Np1, Np2)
      b1 = Arrycol(2, Np1, Np2)
      PicMain.PSet (i1, j1), RGB(r1, g1, b1)
     Next j1
     Pg.value = i1 * 100 \ (cx - 1)
   Next i1
     Pg.value = 0
End Sub

Private Sub L_Click()
Dim DWidth As Single
Dim DHeight As Single
PicZoom.Cls
PicBackup.Picture = PicMain.Image
DWidth = ccx * 1.5
DHeight = ccy * 1.5
PicZoom.Width = DWidth
PicZoom.Height = DHeight
PicZoom.PaintPicture PicBackup.Picture, 0, 0, DWidth, DHeight
'Zoom2 (2)
PicMain.Picture = PicZoom.Image
End Sub
Private Sub liangdu_Click()
Dim liangdu As Single
liangdu = InputBox("请输入一个恰当的数值", , 20, 0)
Dim tmlcolor As Long
Dim r As Long, g As Long, b As Long
Dim r1 As Long, g1 As Long, b1 As Long
Dim ArryColor() As Long
PicBackup.Picture = PicMain.Image
cx = PicMain.ScaleWidth
cy = PicMain.ScaleHeight
PicCHULI.Width = cx: PicCHULI.Height = cy
ReDim ArryColor(2, cx, cy)
For i = 0 To cx
   For j = 0 To cy
   tmlcolor = PicMain.Point(i, j)
    r = tmlcolor Mod 256
    g = ((tmlcolor And &HFF00) / 256) Mod 256
    b = (tmlcolor And &HFF0000) / 65536
   ArryColor(0, i, j) = r
   ArryColor(1, i, j) = g
   ArryColor(2, i, j) = b
   Next j
 Next i
 For i = 0 To cx
   For j = 0 To cy
   r1 = ArryColor(0, i, j) + liangdu
   g1 = ArryColor(1, i, j) + liangdu
   b1 = ArryColor(2, i, j) + liangdu
   If r1 > 255 Then r1 = 255
      If r1 < 0 Then r1 = 0
      If g1 > 255 Then g1 = 255
      If g1 < 0 Then g1 = 0
      If b1 > 255 Then b1 = 255
      If b1 < 0 Then b1 = 0
   PicCHULI.PSet (i, j), RGB(r1, g1, b1)
   Next j
 Next i
 PicMain.Picture = PicCHULI.Image
End Sub

Private Sub lie_Click()
Dim t As Integer, h As Integer
PicMain.Picture = LoadPicture("")
h = 0
t = 1
Do While Int(PicBackup.ScaleWidth) - 2 < h <= Int(PicBackup.ScaleWidth) + 2
  PicMain.PaintPicture PicBackup.Picture, h, 0, t, PicMain.ScaleHeight, h, 0, t, PicMain.ScaleHeight, vbSrcCopy
  h = h + 1
 For i = 0 To 100
  For j = 0 To 10
  DoEvents
  Next j
Next i
Loop

End Sub

Private Sub Line_Click()
  drawact = 2
End Sub
Private Sub New_Click()
NewFile
End Sub
Private Sub Open_Click()
Dim tixing As VbMsgBoxResult
Time1 = Time1 + 1
If Time1 <> 1 Then
    tixing = MsgBox("是否保存当前正在编辑的文件", vbYesNoCancel, "是否保存")
If tixing = vbCancel Then
   Exit Sub
   ElseIf tixing = vbYes Then
    Save1_Click
End If
End If
On Error Resume Next
ComDiag.Filter = "IMAGE|*.gif;*.jpg;*.bmp;*.ico"
Me.ComDiag.ShowOpen
If Me.ComDiag.FileName <> "" And Me.ComDiag.FileName <> name1 Then
      name1 = Me.ComDiag.FileName
      PicMain.Picture = LoadPicture(name1)
      Me.Caption = name1
End If
ccx = PicMain.ScaleWidth
ccy = PicMain.ScaleHeight
PicBackup.Picture = PicMain.Image
End Sub
Private Sub P_Click()
Dim ping As Boolean
ping = True
If ping Then
   Pg.Visible = False
   PicFCol.Visible = False
   Label1.Visible = False
End If
Dim PicW_sng As Single
Dim PicH_sng As Single
Dim X As Single
Dim Y As Single
PicW_sng = PicMain.ScaleWidth
PicH_sng = PicMain.ScaleHeight
Y = 0
Do While Y < FormMain.ScaleHeight
   X = 0
   Do While X < FormMain.ScaleWidth
    FormMain.PaintPicture PicMain.Picture, X, Y
    X = X + PicW_sng
   Loop
  Y = Y + PicH_sng
Loop
End Sub


Private Sub Pen_Click()
23362  drawact = 1
End Sub

Private Sub PicMain_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   Select Case drawact
          '铅笔
          Case 1
          canpen = True
          PicBackup.Picture = PicMain.Image
          PicMain.CurrentX = X: PicMain.CurrentY = Y          '设置下一次绘图的水平，竖直坐标
          PicMain.DrawStyle = 0
         '直线
         Case 2
         canline = True
         PicBackup.Picture = PicMain.Image
         x0 = X: y0 = Y
         xnow = X: ynow = Y
         PicMain.DrawMode = 7
         PicMain.DrawWidth = 1
         PicMain.DrawStyle = 0
         '实心圆
         Case 3
         canfcircle = True
         PicBackup.Picture = PicMain.Image
         x0 = X: y0 = Y
         xnow = X: ynow = Y
         PicMain.DrawMode = 7                  'drawmode=7的含义不明白，请老师指教
         PicMain.DrawWidth = 1
         PicMain.DrawStyle = 0
         '空心圆
         Case 4
         cancircle = True
         PicBackup.Picture = PicMain.Image
         x0 = X: y0 = Y
         xnow = X: ynow = Y
         PicMain.DrawMode = 7
         PicMain.DrawWidth = 1
         PicMain.DrawStyle = 0
         '实心矩形
         Case 5
         canfrect = True
         PicBackup.Picture = PicMain.Image
         x0 = X: y0 = Y
         xnow = X: ynow = Y
         PicMain.DrawMode = 7
         PicMain.DrawWidth = 1
         PicMain.DrawStyle = 0
         '空心矩形
         Case 6
         canrect = True
         PicBackup.Picture = PicMain.Image
         x0 = X: y0 = Y
         xnow = X: ynow = Y
         PicMain.DrawMode = 7
         PicMain.DrawWidth = 1
         PicMain.DrawStyle = 0
         '多边形
         Case 7
         canpolo = True
         PicBackup.Picture = PicMain.Image
         x0 = X: y0 = Y
         px = X: py = Y
         PicMain.DrawWidth = 1
         PicMain.DrawStyle = 0
         Times = Times + 1
         If Times > 2 Then
          PicMain.Line (x0, y0)-(px1, py1), PicMain.ForeColor
         End If
         '橡皮
         Case 8
         canrubber = True
         PicBackup.Picture = PicMain.Image
         PicMain.CurrentX = X: PicMain.CurrentY = Y
         PicMain.DrawMode = 13
         PicMain.DrawWidth = 2
         PicMain.DrawStyle = 0
         '刷子
         Case 9
         canbrush = True
         PicBackup.Picture = PicMain.Image
         PicMain.CurrentX = X: PicMain.CurrentY = Y
         PicMain.DrawMode = 13
         PicMain.DrawWidth = 5
         PicMain.DrawStyle = 0
          '油漆桶
         Case 10
         canyouqi = True
          If ((xx11 < X < xxnow11) And (yy11 < X < yynow11)) = True Then
             Label2.Caption = "左上角坐标" & xx11 & "X" & yy11
             Label4.Caption = "当前坐标" & X & "X" & Y
             Label3.Caption = "最右下角坐标" & xxnow11 & "X" & yynow11
             PicBackup.Picture = PicMain.Image
             PicMain.Line (x11, y11)-(xnow11, ynow11), FormToolsBox.PicForeColor.BackColor, BF
         End If
        '吸管
        Case 11
        tmlcolor = PicMain.Point(X, Y)
        FormToolsBox.PicForeColor.BackColor = tmlcolor
        '选定区域
        Case 12
        PicMain.DrawStyle = 2
        If Xuanding = True Then
        PicBackup.Picture = PicMain.Image
        x11 = X: y11 = Y
        xnow11 = X: ynow11 = Y
        xx11 = X: yy11 = Y
        PicMain.DrawMode = 7
        PicMain.DrawWidth = 1
        End If
  End Select
End Sub
Private Sub PicMain_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  Label1.Caption = X & " X " & Y
  Select Case drawact
         '铅笔
         Case 1
         If canpen And Button = 1 Then
            PicMain.Line -(X, Y), PicMain.ForeColor
         End If
         '直线
         Case 2
        If canline And Button = 1 Then
            PicMain.Line (x0, y0)-(xnow, ynow), Not (PicMain.ForeColor)
            PicMain.Line (x0, y0)-(X, Y), Not (PicMain.ForeColor)
            xnow = X: ynow = Y
        End If
        '实心圆
        Case 3
            radius0 = Sqr((xnow - x0) ^ 2 + (ynow - y0) ^ 2)
            radius = Sqr((X - x0) ^ 2 + (Y - x0) ^ 2)
        If canfcircle And Button = 1 Then
           PicMain.Circle (x0, y0), radius0, Not (PicMain.ForeColor)
           PicMain.Circle (x0, y0), radius, Not (PicMain.ForeColor)
           xnow = X: ynow = Y
        End If
        '空心圆
        Case 4
            radius0 = Sqr((xnow - x0) ^ 2 + (ynow - Y) ^ 2)
            radius = Sqr((X - x0) ^ 2 + (Y - x0) ^ 2)
        If cancircle And Button = 1 Then
           PicMain.Circle (x0, y0), radius0, Not (PicMain.ForeColor)
           PicMain.Circle (x0, y0), radius, Not (PicMain.ForeColor)
           xnow = X: ynow = Y
        End If
        '实心矩形
        Case 5
        If canfrect And Button = 1 Then