frmmain.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{6B7E6392-850A-101B-AFC0-4210102A8DA7}#1.3#0"; "COMCTL32.OCX"
Begin VB.Form frmMain 
   Caption         =   "可以与PhotoShop媲美的各种图象滤镜"
   ClientHeight    =   3690
   ClientLeft      =   165
   ClientTop       =   735
   ClientWidth     =   4605
   LinkTopic       =   "Form1"
   ScaleHeight     =   246
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   307
   StartUpPosition =   3  '窗口缺省
   Begin ComctlLib.ProgressBar pg1 
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   3360
      Width           =   3975
      _ExtentX        =   7011
      _ExtentY        =   450
      _Version        =   327682
      Appearance      =   1
   End
   Begin VB.Frame fratemp 
      Height          =   15
      Left            =   0
      TabIndex        =   4
      Top             =   0
      Width           =   8175
   End
   Begin VB.HScrollBar scrHorz 
      Height          =   255
      Left            =   -360
      TabIndex        =   3
      Top             =   3000
      Width           =   4455
   End
   Begin VB.VScrollBar scrVert 
      Height          =   3015
      Left            =   4080
      TabIndex        =   2
      Top             =   0
      Width           =   255
   End
   Begin VB.PictureBox picBack 
      Height          =   2895
      Left            =   120
      ScaleHeight     =   189
      ScaleMode       =   3  'Pixel
      ScaleWidth      =   261
      TabIndex        =   0
      Top             =   120
      Width           =   3975
      Begin MSComDlg.CommonDialog comDiag 
         Left            =   4320
         Top             =   120
         _ExtentX        =   847
         _ExtentY        =   847
         _Version        =   393216
      End
      Begin VB.PictureBox picMain 
         AutoRedraw      =   -1  'True
         AutoSize        =   -1  'True
         BackColor       =   &H00FFFFFF&
         Height          =   2820
         Left            =   0
         ScaleHeight     =   184
         ScaleMode       =   3  'Pixel
         ScaleWidth      =   256
         TabIndex        =   1
         Top             =   0
         Width           =   3900
      End
   End
   Begin VB.Label lblCoords 
      Height          =   255
      Left            =   120
      TabIndex        =   6
      Top             =   6480
      Width           =   2175
   End
   Begin VB.Menu mnuFile 
      Caption         =   "文件(&L)"
      Begin VB.Menu mnuNew 
         Caption         =   "&New"
      End
      Begin VB.Menu mnuOpen 
         Caption         =   "&Open"
      End
      Begin VB.Menu mnuSep1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit 
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuFilters 
      Caption         =   "滤镜(&F)"
      Begin VB.Menu mnuEmboss 
         Caption         =   "&Emboss"
      End
      Begin VB.Menu mnuSharpen 
         Caption         =   "&Sharpen"
      End
      Begin VB.Menu mnuDiffuse 
         Caption         =   "&Diffuse"
      End
      Begin VB.Menu mnuRects 
         Caption         =   "&Rects"
      End
      Begin VB.Menu mnuBright 
         Caption         =   "&Brightness"
      End
      Begin VB.Menu mnuIce 
         Caption         =   "&Ice"
      End
      Begin VB.Menu mnuDark 
         Caption         =   "&Dark"
      End
      Begin VB.Menu mnuHeat 
         Caption         =   "&Heat"
      End
      Begin VB.Menu mnuStrange 
         Caption         =   "&Strange"
      End
      Begin VB.Menu mnuAqua 
         Caption         =   "&Aqua"
      End
      Begin VB.Menu mnuNight 
         Caption         =   "&Night"
      End
      Begin VB.Menu mnuAfrika 
         Caption         =   "&Afrika"
      End
      Begin VB.Menu mnuBlur 
         Caption         =   "&Blur"
      End
      Begin VB.Menu mnuBAndW 
         Caption         =   "&Greyscale"
      End
      Begin VB.Menu mnuComic 
         Caption         =   "C&omic"
      End
      Begin VB.Menu mnuBaW 
         Caption         =   "B&lack and White"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Sub Form_Load()
    cX = picMain.ScaleWidth
    cY = picMain.ScaleHeight
    scrHorz.Value = 0
    scrHorz.Max = picMain.Width - 5
    scrVert.Value = 0
    scrVert.Max = picMain.Height - 5
    tColors.lBCol = vbBlue
    tColors.lFCol = vbBlack
  
End Sub

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

Private Sub Form_Resize()
    
    On Error GoTo Fa
    
    With picBack
        .Top = 8
        .Left = 8
        .Width = frmMain.ScaleWidth - 28
        .Height = frmMain.ScaleHeight - 60
    End With
    With scrHorz
        .Left = 8
        .Top = 10 + picBack.ScaleHeight
        .Width = picBack.ScaleWidth + 3
    End With
    With scrVert
        .Left = 8 + picBack.ScaleWidth
        .Top = 8
        .Height = picBack.ScaleHeight + 3
    End With
    With pg1
        .Top = scrHorz.Top + 20
        .Width = picBack.ScaleWidth + 17
    End With
    With lblCoords
        .Left = 8
        .Top = pg1.Top + pg1.Height + 1
    End With
  
    fratemp.Width = frmMain.ScaleWidth
Fa:

End Sub



Private Sub mnuBaW_Click()
    Dim col As Long
    
    
    For i = 0 To picMain.Width
        For j = 0 To picMain.Height
            col = GetPixel(picMain.hdc, i, j)
            r = col Mod 256
            g = (col Mod 256) \ 256
            b = col \ 256 \ 256
            
            If r < 200 And g < 200 And b < 200 Then
                col = vbBlack
            Else
                col = vbWhite
            End If
            SetPixel picMain.hdc, i, j, col
        Next j
        pg1.Value = i * 100 \ (picMain.Width - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
End Sub

Private Sub mnuBrush_Click()
    curTools = Tools.sBrush
End Sub

Private Sub mnuCircle_Click()
    curTools = Tools.sCircle
End Sub

Private Sub mnuComic_Click()
    Dim col As Long
    
    
    For i = 0 To picMain.Width
        For j = 0 To picMain.Height
            col = GetPixel(picMain.hdc, i, j)
            r = Abs(col Mod 256)
            g = Abs((col \ 256) Mod 256)
            b = Abs(col \ 256 \ 256)
            r = Abs(r * (g - b + g + r)) / 256
            g = Abs(r * (b - g + b + r)) / 256
            b = Abs(g * (b - g + b + r)) / 256
            col = RGB(r, g, b)
            r = Abs(col Mod 256)
            g = Abs((col \ 256) Mod 256)
            b = Abs(col \ 256 \ 256)
            r = (r + g + b) / 3
            col = RGB(r, r, r)
            SetPixel picMain.hdc, i, j, col
        Next j
        pg1.Value = i * 100 \ (picMain.Width - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh
    
End Sub

Private Sub mnuCross_Click()
    curTools = Tools.sCross
End Sub

Private Sub mnuCrossND_Click()
    curTools = Tools.sCrossND
End Sub




Private Sub mnuHeat_Click()
    Dim bNo As Boolean
    Dim TColW As Long
    
    
    For i = 0 To cX
        For j = 0 To cY
            TColW = GetPixel(picMain.hdc, i, j)
            r = TColW Mod 256
            g = (TColW \ 256) Mod 256
            b = TColW \ 256 \ 256
            
            r = Abs(((r ^ 2) / ((b + g) + 10)) * 128)
            b = Abs(((b ^ 2) / ((g + r) + 10)) * 128)
            g = Abs(((g ^ 2) / ((r + b) + 10)) * 128)
nOK:
                If r > 32767 Then
                    r = r - 32767
                ElseIf g > 32767 Then
                    g = g - 32767
                ElseIf b > 32767 Then
                    b = b - 32767
                End If
                If r > 32767 Or g > 32767 Or b > 32767 Then
                    GoTo nOK
                End If
            SetPixel picMain.hdc, i, j, RGB(r, g, b)
        Next j
        pg1.Value = i * 100 \ (cX - 1)
    Next i
    pg1.Value = 0
    picMain.Refresh