frmmain.frm

VB图像编辑程序

        picMain.Width = x
        picMain.Height = y
        Call ResizePicBoxes
    End If
End Sub

Private Sub picBack_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    lblCoords.Caption = vbNullString
End Sub

Private Sub picBCol_Click()
    On Error Resume Next
    
    comDiag.CancelError = True
    comDiag.ShowColor
    If Not Err Then
        picBCol.BackColor = comDiag.Color
        tColors.lBCol = comDiag.Color
    End If
End Sub

Private Sub picFCol_Click()
    On Error Resume Next
    
    comDiag.CancelError = True
    comDiag.ShowColor
    If Not Err Then
        picFCol.BackColor = comDiag.Color
        tColors.lFCol = comDiag.Color
    End If
End Sub

Private Sub picMain_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim sTmp As String
    Dim points(2) As cPoint, cCount As Double, cDetails As Double
    Dim col As Long, r As Long, a As Double, u As Long, v As Long
    
    sX = x
    sY = y
    If Button = 1 Then
        Call savPic
        If curTools = Tools.sCircle Or curTools = Tools.sStLine Or curTools = Tools.sFCircle Or curTools = Tools.sFRect Or curTools = Tools.sRect Then
            picMain.PSet (sX, sY), vbBlack
            Exit Sub
        End If
        
        If curTools = Tools.sPolygon Then
            If Not stat Then
                stat = True
                curX = x
                curY = y
            End If
            sX = x
            sY = y
            If Shift = 1 Then
                picMain.Line (wX1, wY1)-(curX, curY), tColors.lFCol
                stat1 = False
                stat = False
                Exit Sub
            End If
            If Not stat1 Then
                picMain.PSet (x, y), tColors.lFCol
                wX1 = x
                wY1 = y
                stat1 = True
            Else
                picMain.Line (wX1, wY1)-(x, y), tColors.lFCol
            End If
            Exit Sub
        End If
        
        If curTools = Tools.sUDefPolygon Then
            upX = x
            upY = y
        End If
        
        If curTools = Tools.sFillRegions Then
            Call Filling(picMain.Point(x, y), propFillStyle, x, y)
            
        End If
        
        If curTools = Tools.sText Then
            picMain.CurrentX = x
            picMain.CurrentY = y
            sTmp = InputBox("Type in the Text!", "SEK - Paint 1.0")
            picMain.Print sTmp
        End If
        
        If curTools = Tools.sHammer Then
            On Error Resume Next
            
            Call Save
            r = InputBox("Please type in the radius!  (1-150)", "B閦ier")
            If Err Or r < 0 Or r > 150 Then
                MsgBox "Please type in a number between 1 and 150!", vbCritical, "Error"
                Exit Sub
            End If
            a = ((r / 50) * 360)
        
            For i = 0 To a
                points(0).cX = r * Cos(i) + x
                points(0).cY = r * Sin(i) + y
                points(1).cX = x
                points(1).cY = y
                points(2).cX = x
                points(2).cY = y
        
                cCount = 0
                cDetails = 1 / (r * 2)
        
                Do
                    col = GetPixel(picMain.hdc, points(0).cX, points(0).cY)
                    u = points(0).cX * (cCount * cCount) + points(1).cX * (2 * cCount * (1 - cCount)) + points(2).cX * ((1 - cCount) * (1 - cCount))
                    v = points(0).cY * (cCount * cCount) + points(1).cY * (2 * cCount * (1 - cCount)) + points(2).cY * ((1 - cCount) * (1 - cCount))
                    picMain.PSet (sX, sY), col
                    SetPixel picMain.hdc, u, v, col
                    cCount = cCount + cDetails
                Loop While cCount <= 1
                pg1.Value = i * 100 \ (a - 1)
            Next i
            pg1.Value = 0
        End If
        
        If curTools = Tools.sReplaceColor Then
            If FirstChoose Then
                tmpCol1 = picMain.Point(x, y)
                FirstChoose = False
            Else
                tmpCol2 = picMain.Point(x, y)
                Call ReplaceColor
            End If
        End If
    End If
End Sub

Private Sub picMain_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim tmpbX As Integer, tmpbY As Integer
    
    lblCoords.Caption = x & " X " & y
    If Button = 1 Then
        Select Case curTools
            Case Tools.sPencil:
                picMain.Line (sX, sY)-(x, y), tColors.lFCol
                sX = x
                sY = y
                
            Case Tools.sStar:
                picMain.Line (sX, sY)-(x, y), tColors.lFCol
            
            Case Tools.sErase:
                picMain.Line (sX, sY)-(x, y), vbWhite
                sX = x
                sY = y
            
            Case Tools.sCross:
                picMain.Line (x - 5, y - 5)-(x + 5, y + 5), tColors.lFCol
                picMain.Line (x + 5, y - 5)-(x - 5, y + 5), tColors.lFCol
            
            Case Tools.sCrossND:
                picMain.Line (x - 5, y)-(x + 5, y), tColors.lFCol
                picMain.Line (x, y - 5)-(x, y + 5), tColors.lFCol
                
            Case Tools.sDiagLineLR:
                picMain.Line (x, y)-(x - 5, y + 5), tColors.lFCol
                
            Case Tools.sDiagLineRL:
                picMain.Line (x, y)-(x + 5, y + 5), tColors.lFCol
            
            Case Tools.sUDefPolygon:
                picMain.Line (sX, sY)-(x, y), tColors.lFCol
                sX = x
                sY = y
            
            Case Tools.sHorzLine:
                picMain.Line (x - 5, y)-(x + 5, y), tColors.lFCol
                
            Case Tools.sVertLine:
                picMain.Line (x, y - 5)-(x, y + 5), tColors.lFCol
        
            Case Tools.sBrush:
                For i = 0 To 25
                    tmpbX = Int(Rnd * 14 - 7)
                    tmpbY = Int(Rnd * 14 - 7)
                    picMain.PSet (x + tmpbX, y + tmpbY), tColors.lFCol
                Next i
            
        End Select
    End If
    wX = x
    wY = y
End Sub

Private Sub picMain_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    Dim r
    
    If Button = 1 Then
        If curTools = Tools.sCircle Then
            r = Sqr((sX - x) * (sX - x) + (sY - y) * (sY - y))
            picMain.Circle (sX, sY), r, tColors.lFCol
            picMain.PSet (sX, sY), picMain.Point(sX + 1, sY)
            
        ElseIf curTools = Tools.sRect Then
            picMain.Line (sX, sY)-(x, y), tColors.lFCol, B
            
        ElseIf curTools = Tools.sStLine Then
            picMain.Line (sX, sY)-(x, y), tColors.lFCol
        
        ElseIf curTools = Tools.sFCircle Then
            picMain.FillStyle = 0
            picMain.FillColor = tColors.lBCol
            r = Sqr((sX - x) * (sX - x) + (sY - y) * (sY - y))
            picMain.Circle (sX, sY), r, tColors.lFCol
            picMain.FillStyle = 1
        
        ElseIf curTools = Tools.sFRect Then
            picMain.Line (sX, sY)-(x, y), tColors.lBCol, BF
            
        ElseIf curTools = Tools.sPolygon Then
            picMain.Line (sX, sY)-(wX, wY), tColors.lFCol
            wX1 = x
            wY1 = y
            
        ElseIf curTools = Tools.sUDefPolygon Then
            picMain.Line (upX, upY)-(x, y), tColors.lFCol

        End If
        
    End If
End Sub

Private Sub scrHorz_Change()
    picMain.Left = -scrHorz.Value
End Sub

Private Sub scrVert_Change()
    picMain.Top = -scrVert.Value
End Sub
Private Sub mnuExit_Click()
    End
End Sub

Private Sub mnuInvert_Click()
    Call ResizePicBoxes
    Call Save
    SavePicture picMain.Image, App.Path & "\Invert.tmp"
    
    With picTemp
        picMain.Picture = LoadPicture(App.Path & "\Invert.tmp")
        .Picture = picMain.Picture
        picMain.PaintPicture .Picture, 0, 0, .Width, .Height, 0, 0, .Width, .Height, vbNotSrcCopy
    End With
    Kill App.Path & "\Invert.tmp"
End Sub


Private Sub mnuBAndW_Click()
    Dim c As Integer
    
    Call Save
    Call PrepareImg
    For i = 0 To cX
        For j = 0 To cY
            c = larrCol(0, i, j) * 0.3 + larrCol(1, i, j) * 0.59 + larrCol(2, i, j) * 0.11
            SetPixel picMain.hdc, i, j, RGB(c, c, c)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuEmboss_Click()
   
    Call Save
    Call PrepareImg
    For i = 0 To cX - 1
        For j = 0 To cY - 1
            r = Abs(larrCol(0, i, j) - larrCol(0, i + 1, j + 1) + 128)
            g = Abs(larrCol(1, i, j) - larrCol(1, i + 1, j + 1) + 128)
            b = Abs(larrCol(2, i, j) - larrCol(2, i + 1, j + 1) + 128)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuSharpen_Click()
    
    Call Save
    Call PrepareImg
    For i = 1 To cX
        For j = 1 To cY
            r = larrCol(0, i, j) + 0.5 * (larrCol(0, i, j) - larrCol(0, i - 1, j - 1))
            g = larrCol(1, i, j) + 0.5 * (larrCol(1, i, j) - larrCol(1, i - 1, j - 1))
            b = larrCol(2, i, j) + 0.5 * (larrCol(2, i, j) - larrCol(2, i - 1, j - 1))
            
            If r > 255 Then r = 255
            If r < 0 Then r = 0
            If g > 255 Then g = 255
            If g < 0 Then g = 0
            If b > 255 Then b = 255
            If b < 0 Then b = 0

            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuBright_Click()
    Dim c As Long

    Call Save
    Call PrepareImg
    For i = 0 To cX
        For j = 0 To cY
            c = Abs((larrCol(0, i, j) + larrCol(1, i, j) + larrCol(2, i, j)) \ 3)
            r = Abs(larrCol(0, i, j) + c)
            g = Abs(larrCol(1, i, j) + c)
            b = Abs(larrCol(2, i, j) + c)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuDiffuse_Click()
    Dim nP1 As Integer, nP2 As Integer, nP3 As Integer
    
    Call Save
    Call PrepareImg
    For i = 2 To cX - 3
        For j = 2 To cY - 3
            nP1 = Int(Rnd * 5 - 2)
            nP2 = Int(Rnd * 5 - 2)
            nP3 = Int(Rnd * 5 - 2)
            r = Abs(larrCol(0, i, j + nP1))
            g = Abs(larrCol(1, i + nP2, j))
            b = Abs(larrCol(2, i + nP3, j + nP3))
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuDark_Click()
    
    Call Save
    Call PrepareImg
    For i = 0 To cX
        For j = 0 To cY
            r = Abs(larrCol(0, i, j) - 64)
            g = Abs(larrCol(1, i, j) - 64)
            b = Abs(larrCol(2, i, j) - 64)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuStrange_Click()
    
    Call Save
    Call PrepareImg
    For i = 0 To cX
        For j = 0 To cY
            If (larrCol(1, i, j) = 0) Or (larrCol(2, i, j) = 0) Then
                larrCol(1, i, j) = 1
                larrCol(2, i, j) = 1
            End If
            r = Abs(Sin(Atn(larrCol(1, i, j) / larrCol(2, i, j))) * 125 + 20)
            g = Abs(Sin(Atn(larrCol(0, i, j) / larrCol(2, i, j))) * 125 + 20)
            b = Abs(Sin(Atn(larrCol(0, i, j) / larrCol(1, i, j))) * 125 + 20)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuAqua_Click()
    Dim tColQ As Long
    
    Call Save
    For i = 0 To cX
        For j = 0 To cY
            tColQ = GetPixel(picMain.hdc, i, j)
            r = tColQ Mod 256
            g = (tColQ \ 256) Mod 256
            b = tColQ \ 256 \ 256
            r = (g - b) ^ 2 / 125
            g = (r - b) ^ 2 / 125
            b = (r - g) ^ 2 / 125
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuNight_Click()
    
    Call Save
    Call PrepareImg
    For i = 0 To cX
        For j = 0 To cY
            r = Abs((larrCol(0, i, j) * larrCol(0, i, j)) / 256)
            g = Abs((larrCol(1, i, j) * larrCol(1, i, j)) / 256)
            b = Abs((larrCol(2, i, j) * larrCol(2, i, j)) / 256)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuAfrika_Click()
    Dim TColA
    
    Call Save
    For i = 0 To cX
        For j = 0 To cY
            TColA = GetPixel(picMain.hdc, i, j)
            r = TColA Mod 256
            g = (TColA \ 256) Mod 256
            b = TColA \ 256 \ 256
            r = Abs((g * b) / 256)
            g = Abs((b * r) / 256)
            b = Abs((r * g) / 256)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub

Private Sub mnuBlur_Click()
    
    Call Save
    Call PrepareImg
    For i = 1 To cX - 1
        For j = 1 To cY - 1
            r = Abs(larrCol(0, i - 1, j - 1) + larrCol(0, i, j - 1) + larrCol(0, i + 1, j - 1) + larrCol(0, i - 1, j) + larrCol(0, i, j) + larrCol(0, i + 1, j) + larrCol(0, i - 1, j + 1) + larrCol(0, i, j + 1) + larrCol(0, i + 1, j + 1))
            g = Abs(larrCol(1, i - 1, j - 1) + larrCol(1, i, j - 1) + larrCol(1, i + 1, j - 1) + larrCol(1, i - 1, j) + larrCol(1, i, j) + larrCol(1, i + 1, j) + larrCol(1, i - 1, j + 1) + larrCol(1, i, j + 1) + larrCol(1, i + 1, j + 1))
            b = Abs(larrCol(2, i - 1, j - 1) + larrCol(2, i, j - 1) + larrCol(2, i + 1, j - 1) + larrCol(2, i - 1, j) + larrCol(2, i, j) + larrCol(2, i + 1, j) + larrCol(2, i - 1, j + 1) + larrCol(2, i, j + 1) + larrCol(2, i + 1, j + 1))
            SetPixel picMain.hdc, i, j, RGB(r / 10, g / 10, b / 10)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    picMain.Refresh
    pg1.Value = 0
End Sub