frmmain.frm

这是一本关于vb的实用编程

End Sub


Private Sub mnuIce_Click()
    Dim TColI As Long
    
    
    For i = 0 To cX
        For j = 0 To cY
            TColI = GetPixel(picMain.hdc, i, j)
            r = TColI Mod 256
            g = (TColI \ 256) Mod 256
            b = TColI \ 256 \ 256
            r = Abs((r - g - b) * 1.5)
            g = Abs((g - b - r) * 1.5)
            b = Abs((b - r - g) * 1.5)
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
End Sub


Private Sub mnuNew_Click()
    picMain.Refresh
    picNew.Height = picMain.Height
    picNew.Width = picMain.Width
    picMain.Picture = picNew.Image
End Sub

Private Sub mnuOpen_Click()
    Dim sFName As String
    
    On Error Resume Next
    comDiag.Filter = "*.bmp;*.jpg;*.gif;*.wmf;"
    comDiag.ShowOpen
    sFName = comDiag.FileName
    
    If sFName = "" Then Exit Sub
    
    If Not FileExist(sFName) Then
        MsgBox "File doesn't exist.", vbCritical, "Error"
        Exit Sub
    End If
    
    picMain.Picture = LoadPicture(sFName)
    If Err Then
        MsgBox "This is not a valid picture!", vbCritical, "Error"
        Exit Sub
    End If
    Call ResizePicBoxes
    cX = picMain.ScaleWidth
    cY = picMain.ScaleHeight
End Sub


Private Sub mnuPrint_Click()

End Sub

Private Sub mnuRects_Click()
    Dim tColR1 As Long, tColR2 As Long, tColR3 As Long, tColR4 As Long, tColR5 As Long
    
    
    For i = 0 To cX
        For j = 0 To cY
            tColR1 = GetPixel(picMain.hdc, i, j)
            tColR2 = GetPixel(picMain.hdc, i + 1, j)
            tColR3 = GetPixel(picMain.hdc, i - 1, j)
            tColR4 = GetPixel(picMain.hdc, i, j + 1)
            tColR5 = GetPixel(picMain.hdc, i, j - 1)
            SetPixel picMain.hdc, i, j, (Abs(tColR1) - (Abs(tColR2 + tColR3 + tColR4 + tColR5) / 4))
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
End Sub




Private Sub mnuSave_Click()

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 mnuBAndW_Click()
    Dim c As Integer
    
    
    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 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 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 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 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 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 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
    
    
    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 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
    
    
    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 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