第一读取文件加载 picturebox里 地球人都会这里就不说了
’下面建立一个模块
view plaincopy to clipboardprint?
·········10········20········30········40········50········60········70········80········90········100·······110·······120·······130·······140·······150
Option Explicit
’算法二要的API
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits 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 GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
’算法一要的API
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function SetPixelV Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal crColor As Long) As Long
’算法二 提高速度约2秒 是方法1的46倍速度
Public Function TurnBmp(hSrcBmp As Long, Optional hDestBmp As Long = 0) As Boolean
Dim x As Long, Y As Long
Dim BytesPixel As Long
If hDestBmp = 0 Then hDestBmp = hSrcBmp
Dim tSBmpInfo As BITMAP, tDBmpInfo As BITMAP
Dim sBits() As Byte, dBits() As Byte
’获得位图信息
Call GetObject(hSrcBmp, Len(tSBmpInfo), tSBmpInfo)
Call GetObject(hDestBmp, Len(tDBmpInfo), tDBmpInfo)
’申请空间
ReDim sBits(1 To tSBmpInfo.bmWidthBytes, 1 To tSBmpInfo.bmHeight)
ReDim dBits(1 To tDBmpInfo.bmWidthBytes, 1 To tDBmpInfo.bmHeight)
’获得源图与目标图二进制位
Call GetBitmapBits(hSrcBmp, tSBmpInfo.bmWidthBytes * tSBmpInfo.bmHeight, sBits(1, 1))
Call GetBitmapBits(hDestBmp, tDBmpInfo.bmWidthBytes * tDBmpInfo.bmHeight, dBits(1, 1))
’计算颜色值占用多少字节
BytesPixel = tSBmpInfo.bmBitsPixel / 8
Dim l As Integer
Dim b As Long
’旋转
For Y = 1 To tSBmpInfo.bmHeight
For x = 1 To tSBmpInfo.bmWidth
b = (x - 1) * BytesPixel + 1
l = sBits(b, Y) * 0.114 + sBits(b + 1, Y) * 0.587 + sBits(b + 2, Y) * 0.299
dBits(b, Y) = l
dBits(b + 1, Y) = l
dBits(b + 2, Y) = l
’l = dBits((x - 1) * BytesPixel + 1, Y) * 0.114 + dBits((x - 1) * BytesPixel + 2, Y) * 0.587 + dBits((x - 1) * BytesPixel + 3, Y) * 0.299
’dBits((x - 1) * BytesPixel + 1, Y) = l
’dBits((x - 1) * BytesPixel + 2, Y) = l
’dBits((x - 1) * BytesPixel + 3, Y) = l
Next x
Next Y
Call SetBitmapBits(hDestBmp, tDBmpInfo.bmWidthBytes * tDBmpInfo.bmHeight, dBits(1, 1))
End Function
’算法2.2 提高速度约2秒 是方法1的46倍速度 参数不一样
Public Function TurnPicGray(hSrcBmp As Long) As Boolean
Dim x As Long, Y As Long
Dim BytesPixel As Long
Dim tSBmpInfo As BITMAP
Dim sBits() As Byte
’获得位图信息
Call GetObject(hSrcBmp, Len(tSBmpInfo), tSBmpInfo)
’申请空间
ReDim sBits(1 To tSBmpInfo.bmWidthBytes, 1 To tSBmpInfo.bmHeight)
’获得源图与目标图二进制位
Call GetBitmapBits(hSrcBmp, tSBmpInfo.bmWidthBytes * tSBmpInfo.bmHeight, sBits(1, 1))
’计算颜色值占用多少字节
BytesPixel = tSBmpInfo.bmBitsPixel / 8
Dim l As Integer
Dim b As Long
’旋转
For Y = 1 To tSBmpInfo.bmHeight
For x = 1 To tSBmpInfo.bmWidth
b = (x - 1) * BytesPixel + 1
l = sBits(b, Y) * 0.114 + sBits(b + 1, Y) * 0.587 + sBits(b + 2, Y) * 0.299
sBits(b, Y) = l
sBits(b + 1, Y) = l
sBits(b + 2, Y) = l
Next x
Next Y
Call SetBitmapBits(hSrcBmp, tSBmpInfo.bmWidthBytes * tSBmpInfo.bmHeight, sBits(1, 1))
End Function
’算法
Public Sub SetPicGray(Pic As PictureBox)
Dim width5 As Long, heigh5 As Long, rgb5 As Long
Dim hdc5 As Long, i As Long, j As Long
责任编辑：小草
