VBA图片处理技巧-优快云博客

将两个图片框添加到窗体。

将两个图片框的ScaleMode属性设置为3像素。

一般声明

--------------------------------


Const ubx = 1000
Const uby = 500
Dim pixels(1 To ubx, 1 To uby) As Long

将图片从一个图片盒复制到另一个像素。

===========================================

添加以下代码

--------------------------------------


Private Sub CMDCOPY_Click()
Dim X As Integer, Y As Integer
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = 1 To ubx
For Y = 1 To uby
Picture2.PSet (X, Y), pixels(X, Y)
Next Y
Next X
End Sub

要将灰度图片从一个图片框复制到另一图片框。

===========================================

添加以下代码

--------------------------------------


Private Sub CMDGRAY_Click()
Dim X As Integer, Y As Integer
Dim R As Integer, G As Integer, B As Integer, A As Integer
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = 1 To ubx
For Y = 1 To uby
R = pixels(X, Y) And &HFF
G = ((pixels(X, Y) And &HFF00) / &H100) Mod &H100
B = ((pixels(X, Y) And &HFF0000) / &H10000) Mod &H100
A = (R + G + B) / 3
pixels(X, Y) = RGB(A, A, A)
Next Y
Next X
For X = 1 To ubx
For Y = 1 To uby
Picture2.PSet (X, Y), pixels(X, Y)
Next Y
Next X 
End Sub

将图片的压印副本从一个图片盒复制到另一个。

================================================== ====

添加以下代码

--------------------------------------


Private Sub CMDEMBOSS_Click()
Dim X As Integer, Y As Integer
Dim R As Integer, G As Integer, B As Integer, A As Integer  
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = ubx To 2 Step -1
For Y = uby To 2 Step -1
R = ((pixels(X - 1, Y - 1) And &HFF) - (pixels(X, Y) And &HFF)) + 128
G = (((pixels(X - 1, Y - 1) And &HFF00) / &H100) Mod &H100 - ((pixels(X, Y) And &HFF00) / &H100) Mod &H100) + 128
B = (((pixels(X - 1, Y - 1) And &HFF0000) / &H10000) Mod &H100 - ((pixels(X, Y) And &HFF0000) / &H10000) Mod &H100) + 128 
A = Abs((R + G + B) / 3) 
pixels(X, Y) = RGB(A, A, A) 
Next Y
Next X 
For X = 1 To ubx
For Y = 1 To uby
Picture2.PSet (X - 2, Y - 2), pixels(X, Y)
Next Y
Next X 
End Sub

将图片的雕刻副本从一个图片盒复制到另一个图片盒。

================================================== ====

添加以下代码

--------------------------------------


Private Sub CMDENGRAVE_Click()
Dim X As Integer, Y As Integer
Dim R As Integer, G As Integer, B As Integer, A As Integer
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = 2 To ubx Step -1
For Y = 2 To uby Step -1
R = ((pixels(X + 1, Y + 1) And &HFF) - (pixels(X, Y) And &HFF)) + 128
G = (((pixels(X + 1, Y + 1) And &HFF00) / &H100) Mod &H100 - ((pixels(X, Y) And &HFF00) / &H100) Mod &H100) + 128
B = (((pixels(X + 1, Y + 1) And &HFF0000) / &H10000) Mod &H100 - ((pixels(X, Y) And &HFF0000) / &H10000) Mod &H100) + 128 
A = (R + G + B) / 3
pixels(X, Y) = RGB(A, A, A)
Next Y
Next X
For X = 1 To ubx
For Y = 1 To uby
Picture2.PSet (X, Y), pixels(X, Y)
Next Y
Next X
End Sub

将图片的模糊副本从一个图片盒复制到另一个图片盒。

================================================== ==

添加以下代码

--------------------------------------


Private Sub CMDBLUR_Click()
Dim X As Integer, Y As Integer
Dim R As Integer, G As Integer, B As Integer, A As Integer
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = 1 To ubx - 1
For Y = 1 To uby
R = Abs((pixels(X + 1, Y) And &HFF) + (pixels(X, Y) And &HFF)) / 2
G = Abs(((pixels(X + 1, Y) And &HFF00) / &H100) Mod &H100 + ((pixels(X, Y) And &HFF00) / &H100) Mod &H100) / 2
B = Abs(((pixels(X + 1, Y) And &HFF0000) / &H10000) Mod &H100 + ((pixels(X, Y) And &HFF0000) / &H10000) Mod &H100) / 2 
pixels(X, Y) = RGB(R, G, B)
Next Y
Next X
For X = 1 To ubx
For Y = 1 To uby
Picture2.PSet (X, Y), pixels(X, Y)
Next Y
Next X 
End Sub

将一个图片盒中的图像扫描（模糊）到另一个。

=============================================

添加以下代码

--------------------------------------


Private Sub CMDSWEEP_Click()
Dim X As Integer, Y As Integer
Dim R As Integer, G As Integer, B As Integer, A As Integer
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = ubx - 1 To 1 Step -1
For Y = uby - 1 To 1 Step -1
R = Abs((pixels(X + 1, Y + 1) And &HFF) + (pixels(X, Y) And &HFF)) / 2
G = Abs(((pixels(X + 1, Y + 1) And &HFF00) / &H100) Mod &H100 + ((pixels(X, Y) And &HFF00) / &H100) Mod &H100) / 2
B = Abs(((pixels(X + 1, Y + 1) And &HFF0000) / &H10000) Mod &H100 + ((pixels(X, Y) And &HFF0000) / &H10000) Mod &H100) / 2 
pixels(X, Y) = RGB(R, G, B)
Next Y
Next X
For X = 1 To ubx
For Y = 1 To uby
Picture2.PSet (X, Y), pixels(X, Y)
Next Y
Next X 
End Sub

从背面将图片从一个图片盒复制到另一个。

================================================== =

添加以下代码

--------------------------------------


Private Sub CMDREVERSE_Click()
Dim X As Integer, Y As Integer
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = ubx To 1 Step -1
For Y = uby To 1 Step -1
Picture2.PSet (X, Y), pixels(X, Y)
Next Y
Next X
End Sub

将图像从一个图片框切换到另一图片框。

===================================

添加以下代码

--------------------------------------


Private Sub CMDFLIP_Click()
Picture2.PaintPicture Picture1.Picture, Picture1.ScaleWidth, 0, -1 * Picture1.ScaleWidth, Picture1.ScaleHeight
End Sub

从另一个图片盒中的图像中删除颜色。

================================================== =

在窗体中添加一个文本框，以输入要删除颜色的值。

添加以下代码

--------------------------------------


Private Sub CMDLIGHT_Click()
Dim X As Integer, Y As Integer, addon As Integer
addon = Val(Text1.Text)
Dim R As Integer, G As Integer, B As Integer
For X = 1 To ubx
For Y = 1 To uby
pixels(X, Y) = Picture1.Point(X, Y)
Next Y
Next X 
For X = 1 To ubx
For Y = 1 To uby
R = pixels(X, Y) And &HFF
G = ((pixels(X, Y) And &HFF00) / &H100) Mod &H100
B = ((pixels(X, Y) And &HFF0000) / &H10000) Mod &H100 
R = R + addon
If R > 255 Then R = 255
G = G + addon
If G > 255 Then G = 255
B = B + addon
If B > 255 Then B = 255 
pixels(X, Y) = RGB(R, G, B)
Next Y
Next X 
For X = 1 To ubx
For Y = 1 To uby
Picture2.PSet (X, Y), pixels(X, Y)
Next Y
Next X
End Sub