VB代码VB小程序:将彩色图像转变为黑白图像

VB代码VB小程序：将彩色图像转变为黑白图像

本程序使用两种方法将一幅彩色图像转变为黑白图像：用 API 方法、用 VB 控件方法。通过比较两种方法不难发现：

用 VB 控件进行转换，过程直观，代码好理解，对学习和理解 VB 绘图语句很有帮助，但速度慢。

用 API 方法进行转换，需操作二进制数组，像素点的行列定位较复杂，但转换速度快，几乎是瞬间就完成了转换。

' '以下是窗体代码，在 VB6 调试通过

'需在窗体放置 5 个控件：Command1、Command2、Command3、Picture1、Text1

'本人原创，转载请注明文章来源：/100bd/blog/item/

Dim ctExit As Boolean

Private Type BitMap

bmType As Long '图像类型：0 表示是位图

bmWidth As Long '图像宽度（像素）

bmHeight As Long '图像高度（像素）

bmWidthBytes As Long '每一行图像的字节数

bmPlanes As Integer '图像的图层数

bmBitsPixel As Integer '图像的位数

bmBits As Long '位图的内存指针

End Type

Private Declare Function GetObject Lib "gdi32" Alias

"GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As

Long

Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long,

ByVal dwCount As Long, lpBits As Any) As Long

Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long,

ByVal dwCount As Long, lpBits As Any) As Long

Private Sub Form_Load()

n = "转变为黑白图片"

= & ""

n = "打开": pText = "打开指定的图片文件"

n = "转换1": pText = "用 API 方法转变为黑白图片"

n = "转换2": pText = "用 VB 控件方法转换为黑白图像"

ze = True: draw = True

ode = 3

pText = "如果已转换为黑白图像，双击恢复为原来的图像"

'设置控件位置，实际可以在设计窗体时完成

Dim W1 As Long

W1 = dth("A")

W1, W1, W1 * 6, W1 * 3

W1 * 8, W1, W1 * 7, W1 * 3

W1 * 15, W1, W1 * 7, W1 * 3

W1 * 22, W1, W1 * 80, W1 * 3

W1, W1 * 5, W1 * 40, W1 * 40

Call RndImg(Picture1) '随机画一些图像

End Sub

Private Sub RndImg(Kj As Object)

'随机画一些图像

Dim I As Long

Randomize

dth = 3

For I = 1 To 100

(idth * Rnd, eight * Rnd)-Step(50, 50), &HFFFFFF * Rnd,

BF

(idth * Rnd, eight * Rnd), 30 * Rnd, &HFFFFFF * Rnd

Next

dth = 1

= 24: = True

tX = 10: tY = 10: lor = &H777777

n

tX = 11: tY = 11: lor = RGB(0, 0, 210)

n

e =

End Sub

Private Sub Form_Unload(Cancel As Integer)

ctExit = True '防止绘图未完成前用户关闭窗口时无法正常终止程序

End Sub

Private Sub Command1_Click()

'打开图片文件

Dim F As String

On Error GoTo Err1

F = Trim()

e = LoadPicture(F)

Exit Sub

Err1:

MsgBox "无法读取文件：" & vbCrLf & F, vbInformation

End Sub

Private Sub Command2_Click()

'用 API 方法转变为黑白图片

Dim BMPs() As Byte, Bs As Long, Ps As Long, MapInf As BitMap

Dim R As Long, G As Long, B As Long, S As Long, I As Long

GetObject , Len(MapInf), MapInf '用 MapInf 得到 Picture1 的图像信息

Ps = hBytes h '每像素字节数=行字节数宽度

Bs = h * ht * Ps '总字节数=宽度*高度*每个像素字节

ReDim BMPs(0 To Bs - 1)

GetBitmapBits , Bs, BMPs(0) '将 Picture1 的图像颜色值读入二进数组 BMPs()

'每像素占用的字节数也可用 Ps=Pixel8 计算，一般为 4

'第1字节为蓝色，第2字节为绿色，第3字节为红色，第4字节未使用

'BMPs() 数组序号 I 与图像坐标的关系是：

' X = (I Mod hBytes) Ps '列序号：0 到 h-1

' Y = I hBytes '行序号：0 到 ht-1

'反过来，图像 X,Y 坐标处的的 RGB 颜色在数组中的序号是：

' I = Y* hBytes+X*Ps

' BMPs(I+ 2)，BMPs(I + 1)，BMPs(I ) 的数值就是三原色红、绿、蓝

For I = 0 To Bs - 1 Step Ps

B = BMPs(I + 2): G = BMPs(I + 1): R = BMPs(I) '红、绿、蓝

S = R * 0.3 + G * 0.5 + B * 0.2 '转变为黑白灰度值，各通道颜色比例可根据不同的图片调整

BMPs(I + 2) = S: BMPs(I + 1) = S: BMPs(I) = S

Next

SetBitmapBits , Bs, BMPs(0) '将 Picture1 的图像设置为二进数组 BMPs()

End Sub

Private Sub Command3_Click()

'用 VB 控件方法转换为黑白图像

Dim X As Long, Y As Long, Se As Long, Ci As Long

d = False: d = False: d = False

For X = 0 To idth - 1

For Y = 0 To eight - 1

Se = (X, Y) '取得 x,y 坐标处像素点的颜色值

(X, Y), SeBlack(Se) '设置成转换后的颜色

Ci = Ci + 1

If Ci > 1000 Then '因时间较长，防止出现假死状态

Ci = 0: DoEvents

If ctExit Then Exit Sub

End If

Next

Next

d = True: d = True: d = True

End Sub

Private Function SeBlack(Se As Long) As Long

'转换为：黑白

Dim R As Long, G As Long, B As Long, S As Long

GetRGB Se, R, G, B '分解出三原色 R, G, B

S = R * 0.3 + G * 0.5 + B * 0.2 '转变为黑白灰度值，各通道颜色比例可根据不同的图片调整

SeBlack = RGB(S, S, S)

End Function

Private Sub GetRGB(ByVal Se As Long, R As Long, G As Long, B As Long)

'从 Se 中分解出三原色 R, G, B

B = Se 65536: Se = Se Mod 65536

G = Se 256: R = Se Mod 256

B = B Mod 256

End Sub

Private Sub Picture1_DblClick()

If d Then

End Sub

''本人原创，转载请注明文章来源：/100bd/blog/item/

查看文档来源：/100bd/item/b5906c1592abe1051894ecc6