📄 --
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form Form1
BorderStyle = 1 'Fixed Single
Caption = "滤镜"
ClientHeight = 3840
ClientLeft = 3105
ClientTop = 3030
ClientWidth = 5400
Icon = "滤镜.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 256
ScaleMode = 3 'Pixel
ScaleWidth = 360
Begin MSComDlg.CommonDialog cdSaveAs
Left = 1200
Top = 1680
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
Filter = "图像文件(*.bmp)|*.bmp"
InitDir = "e:\范翔"
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
AutoSize = -1 'True
Height = 1215
Left = 0
ScaleHeight = 77
ScaleMode = 3 'Pixel
ScaleWidth = 349
TabIndex = 0
Top = 0
Visible = 0 'False
Width = 5295
End
Begin MSComDlg.CommonDialog cdOpen
Left = 3240
Top = 2040
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
Filter = "图像文件(*.bmp)|*.bmp;*.gif;*.jpg"
InitDir = "e:\"
End
Begin VB.Menu mnuFile
Caption = "文件(&F)"
Begin VB.Menu mnuLoad
Caption = "加载图片"
Begin VB.Menu mnuPicOpen
Caption = "文件..."
Index = 0
End
Begin VB.Menu mnuPicOpen
Caption = "剪贴板"
Index = 1
End
End
Begin VB.Menu mnuSaveAs
Caption = "另存为..."
End
Begin VB.Menu mnuSep1
Caption = "-"
End
Begin VB.Menu mnuQuit
Caption = "退出(&X)"
End
End
Begin VB.Menu mnuGlass
Caption = "滤镜(&G)"
Begin VB.Menu mnuGlasses
Caption = "柔化"
Index = 0
End
Begin VB.Menu mnuGlasses
Caption = "锐化"
Index = 1
End
Begin VB.Menu mnuGlasses
Caption = "浮雕"
Index = 2
End
Begin VB.Menu mnuGlasses
Caption = "雕刻"
Index = 3
End
Begin VB.Menu mnuGlasses
Caption = "扩散"
Index = 4
End
Begin VB.Menu mnuGlasses
Caption = "曝光"
Index = 5
End
Begin VB.Menu mnuSep2
Caption = "-"
End
Begin VB.Menu mnuCustom
Caption = "定制滤镜..."
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim ImageR() As Integer
Dim ImageG() As Integer
Dim ImageB() As Integer
Private Sub Form_Load()
Dim i As Long
For i = 0 To 5
mnuGlasses(i).Enabled = False
Next i
mnuCustom.Enabled = False
mnuSaveAs.Enabled = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
Erase ImageR, ImageG, ImageB
End
End Sub
Private Sub mnuPicOpen_Click(Index As Integer)
Dim i As Long, x As Long, y As Long
On Error GoTo err
With Form1
Select Case Index
Case 0
cdOpen.ShowOpen
Picture1.Picture = LoadPicture(cdOpen.FileName)
.Caption = App.Title & "-" & cdOpen.FileName & "(" & Picture1.ScaleWidth & "x" & Picture1.ScaleHeight & ")"
Case 1
If Clipboard.GetFormat(2) Or Clipboard.GetFormat(3) Or Clipboard.GetFormat(8) Then
Picture1.Picture = Clipboard.GetData()
.Caption = App.Title & "-" & "Untitled" & "(" & Picture1.ScaleWidth & "x" & Picture1.ScaleHeight & ")"
Else
MsgBox "剪贴板上无图片文件", vbCritical
Exit Sub
End If
End Select
.Refresh
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
If x > 1600 And y > 1200 Then
For i = 0 To 5
mnuGlasses(i).Enabled = False
Next i
mnuCustom.Enabled = False
Picture1.Visible = False
mnuSaveAs.Enabled = False
MsgBox "图像太大,本程序无法处理", vbExclamation
Exit Sub
End If
Picture1.Visible = True
.Width = .ScaleX(Picture1.Width + 6, vbPixels, vbTwips)
If .Width < 5000 Then
.Width = 5000
End If
.Height = .ScaleY(Picture1.Height + 45, vbPixels, vbTwips)
Picture1.Move (.ScaleWidth - .Picture1.ScaleWidth) / 2, 0
LoadImage
For i = 0 To 5
mnuGlasses(i).Enabled = True
Next i
mnuCustom.Enabled = True
mnuSaveAs.Enabled = False
End With
err:
End Sub
Private Sub mnuSaveAs_Click()
On Error GoTo err
cdSaveAs.FileName = cdOpen.FileName
cdSaveAs.ShowSave
SavePicture Picture1.Image, cdSaveAs.FileName
err:
End Sub
Private Sub mnuGlasses_Click(Index As Integer)
Dim a As String
Select Case Index
Case 0
a = "柔化"
Case 1
a = "锐化"
Case 2
a = "浮雕"
Case 3
a = "雕刻"
Case 4
a = "扩散"
Case 5
a = "曝光"
End Select
Form2.Caption = "正在" & a & "图像..."
Glasses (Index)
End Sub
Private Sub mnuCustom_Click()
Form3.Show 1
If NeedShow Then
Dim i As Long, j As Long
Dim kj As Long, ki As Long
Dim r As Long, g As Long, b As Long
Dim hBmp As Long, hDestDc As Long
Dim x As Long, y As Long
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
Form2.Show
Form2.Caption = "正在过滤图像..."
Form2.Refresh
hBmp = CreateCompatibleBitmap(Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)
hDestDc = CreateCompatibleDC(Picture1.hdc)
SelectObject hDestDc, hBmp
For i = 2 To y - 2
For j = 2 To x - 2
For ki = -1 To 1
For kj = -1 To 1
r = r + ImageR(i + ki, j + kj) * Custom(ki + 2, kj + 2)
g = g + ImageG(i + ki, j + kj) * Custom(ki + 2, kj + 2)
b = b + ImageB(i + ki, j + kj) * Custom(ki + 2, kj + 2)
Next kj
Next ki
r = Abs(r / Norm + Bias)
g = Abs(g / Norm + Bias)
b = Abs(b / Norm + Bias)
SetPixelV hDestDc, j, i, RGB(r, g, b)
r = 0: b = 0: g = 0
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
Form2.Hide
BitBlt Picture1.hdc, 1, 1, Picture1.ScaleWidth - 2, Picture1.ScaleHeight - 2, hDestDc, 1, 1, &HCC0020
Picture1.Refresh
Call DeleteDC(hDestDc)
Call DeleteObject(hBmp)
mnuSaveAs.Enabled = True
End If
End Sub
Private Sub mnuQuit_Click()
Unload Me
End
End Sub
Sub Glasses(n As Long)
Dim x As Long, y As Long
Dim i As Long, j As Long
Dim r As Long, g As Long, b As Long
Dim hBmp As Long, hDestDc As Long
Dim a As Long, c As Long
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
hBmp = CreateCompatibleBitmap(Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)
hDestDc = CreateCompatibleDC(Picture1.hdc)
SelectObject hDestDc, hBmp
Form2.Show
Form2.Refresh
Start = GetTime
Select Case n
Case 0
For i = 1 To y - 2
For j = 1 To x - 2
r = ImageR(i - 1, j - 1) + ImageR(i - 1, j) + ImageR(i - 1, j + 1) + ImageR(i, j - 1) + ImageR(i, j) + ImageR(i, j + 1) + ImageR(i + 1, j - 1) + ImageR(i + 1, j) + ImageR(i + 1, j + 1)
g = ImageG(i - 1, j - 1) + ImageG(i - 1, j) + ImageG(i - 1, j + 1) + ImageG(i, j - 1) + ImageG(i, j) + ImageG(i, j + 1) + ImageG(i + 1, j - 1) + ImageG(i + 1, j) + ImageG(i + 1, j + 1)
b = ImageB(i - 1, j - 1) + ImageB(i - 1, j) + ImageB(i - 1, j + 1) + ImageB(i, j - 1) + ImageB(i, j) + ImageB(i, j + 1) + ImageB(i + 1, j - 1) + ImageB(i + 1, j) + ImageB(i + 1, j + 1)
SetPixelV hDestDc, j, i, RGB(r \ 9, g \ 9, b \ 9)
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
Case 1
For i = 1 To y - 2
For j = 1 To x - 2
r = ImageR(i, j) + 0.5 * (ImageR(i, j) - ImageR(i - 1, j - 1))
g = ImageG(i, j) + 0.5 * (ImageG(i, j) - ImageG(i - 1, j - 1))
b = ImageB(i, j) + 0.5 * (ImageB(i, j) - ImageB(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
SetPixelV hDestDc, j, i, RGB(r, g, b)
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
Case 2
For i = 1 To y - 2
For j = 1 To x - 2
r = Abs(ImageR(i, j) - ImageR(i + 1, j + 1) + 128)
g = Abs(ImageG(i, j) - ImageG(i + 1, j + 1) + 128)
b = Abs(ImageB(i, j) - ImageB(i + 1, j + 1) + 128)
SetPixelV hDestDc, j, i, RGB(r, g, b)
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
Case 3
For i = 2 To y - 1
For j = 2 To x - 1
r = Abs(ImageR(i, j) - ImageR(i - 1, j - 1) + 128)
g = Abs(ImageG(i, j) - ImageG(i - 1, j - 1) + 128)
b = Abs(ImageB(i, j) - ImageB(i - 1, j - 1) + 128)
SetPixelV hDestDc, j, i, RGB(r, g, b)
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
Case 4
For i = 2 To y - 3
For j = 2 To x - 3
a = Rnd() * 4 - 2
c = Rnd() * 4 - 2
r = ImageR(i + a, j + c)
g = ImageG(i + a, j + c)
b = ImageB(i + a, j + c)
SetPixelV hDestDc, j, i, RGB(r, g, b)
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
Case 5
For i = 1 To y - 2
For j = 1 To x - 2
r = ImageR(i, j)
g = ImageG(i, j)
b = ImageB(i, j)
If ((r < 128) Or (r > 255)) Then r = 255 - r
If ((g < 128) Or (g > 255)) Then g = 255 - g
If ((b < 128) Or (b > 255)) Then b = 255 - b
SetPixelV hDestDc, j, i, RGB(r, g, b)
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
End Select
ShowTimeDiff
Form2.Hide
BitBlt Picture1.hdc, 1, 1, Picture1.ScaleWidth - 2, Picture1.ScaleHeight - 2, hDestDc, 1, 1, &HCC0020
Picture1.Refresh
Call DeleteDC(hDestDc)
Call DeleteObject(hBmp)
mnuSaveAs.Enabled = True
End Sub
Sub LoadImage()
Dim x As Long, y As Long
Dim i As Long, j As Long, p As Long
Dim r As Long, g As Long, b As Long
Dim hBmp As Long, hDestDc As Long
Dim hdc As Long
hdc = Picture1.hdc
x = Picture1.ScaleWidth
y = Picture1.ScaleHeight
ReDim ImageR(y - 1, x - 1)
ReDim ImageG(y - 1, x - 1)
ReDim ImageB(y - 1, x - 1)
Form2.Show
Form2.Caption = "正在加载图片..."
Form2.Refresh
hBmp = CreateCompatibleBitmap(hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)
hDestDc = CreateCompatibleDC(hdc)
SelectObject hDestDc, hBmp
Start = GetTime
For i = 0 To y - 1
For j = 0 To x - 1
p = GetPixel(hdc, j, i)
r = p And 255
g = (p And &HFF00FF00) / 256
b = ((p And &HFF0000) / 65536)
ImageR(i, j) = r
ImageG(i, j) = g
ImageB(i, j) = b
Next j
Form2.pgrbar.Value = i * 100# / (y - 1)
Next i
ShowTimeDiff
Form2.Hide
Call DeleteDC(hDestDc)
Call DeleteObject(hBmp)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -