图片上传的WebForm(自动生成所略图)

　　
　　因自己的程序中需对一个窗体区域频繁进行彩色转灰度处理，为此专门写了个函数。处理对象是一块经常变化的动态区域，且是一系列绘图中的一部分，速度要求较高，算法上力求简单，所以采用以下两步方案：
　　
　　1、基于DDB来写，虽然转入DIB，可不必面对各种色深，会统一算法，但转换过程会让速度上慢很多，再者这只是针对屏幕位图的函数，并无保存需要。
　　考虑实际情况，我只写了16、24、32位三种色深下的算法，其实4、8两种位图是最快的了，不管多大的图只需处理16与256次运算，可是现在哪有人的屏幕，还使用这两种显示模式呢？想想就没这个必要了。
　　相比之下，32位时最快，16位时最慢，心里有点不满意，但好在速度都不慢。差距也不超过50%。
　　
　　2、灰度算法本来就不复杂，但我还是做了简化，正常处理时一般需对RGB做加权平均，取个值来统一三基色，但这需涉及浮点运算，速度上不去，效果却不见得有多好。
　　我的方法很简单，就是取三基色之一的值，统一起来，考虑人眼对绿色最敏感，所以算法就成RGB转GGG了。严格的说，这不叫彩转灰，叫绿转灰更合适。RGB的排列G是在中间的，想利用高速Long运算，用B值最快的，但已经够简化了，再简下去，自己都过意不去。（用B值时32位下，速度还可快1/3）
　　这种算法当然有缺陷，主要是对一些偏色图效果不好，但好在这种情况在色彩丰富的界面中不存在。
　　
　　C2.4G 256M WinXP SP2下的测试情况
　　IDE环境下
　　1024 X 768的位图
　　32位屏幕 219毫秒
　　16位屏幕 314毫秒
　　
　　N代码编译，全部优化打开
　　1024 X 768的位图
　　32位屏幕 62毫秒
　　16位屏幕 75毫秒
　　
　　注：没有24位环境，所以也就没测了
　　
　　Option Explicit
　　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
　　Private Type MemHdc
　　hdc As Long
　　Bmp As Long
　　obm As Long
　　End Type
　　Private Declare Function GetObj Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
　　Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
　　Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
　　Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
　　Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
　　
　　Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
　　Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) 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 Declare Function GetTickCount Lib "kernel32" () As Long
　　Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
　　'平时常做图形处理，自己的两个公用函数也就用上了
　　Private Function NewMyHdc(dHdc As Long, w As Long, h As Long, Optional Bm As Long) As MemHdc
　　With NewMyHdc
　　.hdc = CreateCompatibleDC(dHdc)
　　If Bm = 0 Then
　　.Bmp = CreateCompatibleBitmap(dHdc, w, h)
　　Else
　　.Bmp = Bm
　　End If
　　.obm = SelectObject(.hdc, .Bmp)
　　End With
　　End Function
　　
　　Private Function DelMyHdc(MyHdc As MemHdc, Optional nobmp As Boolean) As MemHdc
　　With MyHdc
　　If .hdc <> 0 And .obm <> 0 Then SelectObject .hdc, .obm
　　If nobmp = False And .Bmp <> 0 Then DeleteObject .Bmp
　　If .hdc <> 0 Then DeleteDC .hdc
　　End With
　　End Function
　　
　　'灰度处理主函数
　　Private Function GrayBmp(dHdc As Long, x As Long, y As Long, w As Long, h As Long) As Long
　　Dim tmpdc As MemHdc
　　Dim i As Long, j As Long, m As Long, k As Byte, l As Long
　　Dim Bm As BITMAP, AllBytes As Long, LineBytes As Long
　　Dim dBits() As Byte
　　Dim dBits1() As Integer
　　Dim dBits2() As Long
　　On Error GoTo last
　　With tmpdc
　　tmpdc = NewMyHdc(dHdc, w, h)
　　GetObj .Bmp, Len(Bm), Bm
　　If Bm.bmBitsPixel < 16 Then GoTo last
　　BitBlt .hdc, 0, 0, w, h, dHdc, x, y, vbSrcCopy
　　LineBytes = Bm.bmWidthBytes
　　AllBytes = LineBytes * h
　　Select Case Bm.bmBitsPixel
　　Case 32
　　ReDim dBits2(AllBytes \ 4 - 1)
　　GetBitmapBits .Bmp, AllBytes, dBits2(0)
　　For i = 0 To AllBytes \ 4 - 1
　　dBits2(i) = ((dBits2(i) And &HFF00&) \ &H100) * &H10101
　　'dBits2(i) = (dBits2(i) And &HFF) * &H10101'用B值运算
　　Next
　　SetBitmapBits .Bmp, AllBytes, dBits2(0)
　　GrayBmp = 32
　　Case 24
　　ReDim dBits(AllBytes - 1)
　　GetBitmapBits .Bmp, AllBytes, dBits(0)
　　For j = 0 To h - 1
　　m = j * LineBytes
　　For i = m To m + w * 3 - 1 Step 3
　　dBits(i) = dBits(i + 1)
　　dBits(i + 2) = dBits(i)
　　Next
　　Next
　　SetBitmapBits .Bmp, AllBytes, dBits(0)
　　GrayBmp = 24
　　Case 16
　　'按565格式运算
　　ReDim dBits1(AllBytes \ 2 - 1)
　　GetBitmapBits .Bmp, AllBytes, dBits1(0)
　　For j = 0 To h - 1
　　m = j * LineBytes \ 2
　　For i = m To m + w - 1
　　l = dBits1(i) And &H7C0&
　　l = l * 32 + l + l \ 64
　　CopyMemory dBits1(i), l, 2　'这句没办法，不用CopyMemory，会溢出，低效源于此
　　Next
　　Next
　　SetBitmapBits .Bmp, AllBytes, dBits1(0)
　　GrayBmp = 16
　　End Select
　　BitBlt dHdc, x, y, w, h, .hdc, 0, 0, vbSrcCopy
　　End With
　　last:
　　DelMyHdc tmpdc
　　End Function
　　Private Sub Form_Load()
　　ScaleMode = 3
　　AutoRedraw = True
　　Picture = LoadPicture("f:\1.jpg")
　　Command1.Caption = "测试"
　　End Sub
　　
　　'测试用代码
　　Private Sub Form_Resize()
　　PaintPicture Picture, 0, 0, ScaleWidth, ScaleHeight
　　End Sub
　　
　　Private Sub Command1_Click()
　　Dim t As Long, s As String, s1 As String, i As Long
　　t = GetTickCount
　　GrayBmp hdc, 0, 0, ScaleWidth, ScaleHeight
　　Refresh
　　MsgBox GetTickCount - t & s
　　End Sub
　　
　　

查看本文来源