圖片上傳的WebForm(自動生成所略圖)

　　因自己的程序中需對一個窗體區域頻繁進行彩色轉灰度處理為此專門寫了個函數處理對象是一塊經常變化的動態區域且是一系列繪圖中的一部分速度要求較高算法上力求簡單所以采用以下兩步方案
　　
　　基於DDB來寫雖然轉入DIB可不必面對各種色深會統一算法但轉換過程會讓速度上慢很多再者這只是針對屏幕位圖的函數並無保存需要
　　考慮實際情況我只寫了位三種色深下的算法其實兩種位圖是最快的了不管多大的圖只需處理與次運算可是現在哪有人的屏幕還使用這兩種顯示模式呢？想想就沒這個必要了
　　相比之下位時最快位時最慢心裡有點不滿意但好在速度都不慢差距也不超過%
　　
　　灰度算法本來就不復雜但我還是做了簡化正常處理時一般需對RGB做加權平均取個值來統一三基色但這需涉及浮點運算速度上不去效果卻不見得有多好
　　我的方法很簡單就是取三基色之一的值統一起來考慮人眼對綠色最敏感所以算法就成RGB轉GGG了嚴格的說這不叫彩轉灰叫綠轉灰更合適RGB的排列G是在中間的想利用高速Long運算用B值最快的但已經夠簡化了再簡下去自己都過意不去（用B值時位下速度還可快/）
　　這種算法當然有缺陷主要是對一些偏色圖效果不好但好在這種情況在色彩豐富的界面中不存在
　　
　　CG M WinXP SP下的測試情況
　　IDE環境下
　　 X 的位圖
　　位屏幕 毫秒
　　位屏幕 毫秒
　　
　　N代碼編譯全部優化打開
　　 X 的位圖
　　位屏幕 毫秒
　　位屏幕 毫秒
　　
　　注沒有位環境所以也就沒測了
　　
　　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 gdi Alias GetObjectA (ByVal hObject As Long ByVal nCount As Long lpObject As Any) As Long
　　Private Declare Function SelectObject Lib gdi (ByVal hdc As Long ByVal hObject As Long) As Long
　　Private Declare Function DeleteObject Lib gdi (ByVal hObject As Long) As Long
　　Private Declare Function DeleteDC Lib gdi (ByVal hdc As Long) As Long
　　Private Declare Function BitBlt Lib gdi (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 gdi (ByVal hdc As Long) As Long
　　Private Declare Function CreateCompatibleBitmap Lib gdi (ByVal hdc As Long ByVal nWidth As Long ByVal nHeight As Long) As Long
　　Private Declare Function GetBitmapBits Lib gdi (ByVal hBitmap As Long ByVal dwCount As Long lpBits As Any) As Long
　　Private Declare Function SetBitmapBits Lib gdi (ByVal hBitmap As Long ByVal dwCount As Long lpBits As Any) As Long
　　
　　Private Declare Function GetTickCount Lib kernel () As Long
　　Private Declare Sub CopyMemory Lib kernel 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 = 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 <> And obm <> Then SelectObject hdc obm
　　If nobmp = False And Bmp <> Then DeleteObject Bmp
　　If hdc <> 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 dBits() As Integer
　　Dim dBits() As Long
　　On Error GoTo last
　　With tmpdc
　　tmpdc = NewMyHdc(dHdc w h)
　　GetObj Bmp Len(Bm) Bm
　　If BmbmBitsPixel < Then GoTo last
　　BitBlt hdc w h dHdc x y vbSrcCopy
　　LineBytes = BmbmWidthBytes
　　AllBytes = LineBytes * h
　　Select Case BmbmBitsPixel
　　Case
　　ReDim dBits(AllBytes \ )
　　GetBitmapBits Bmp AllBytes dBits()
　　For i = To AllBytes \
　　dBits(i) = ((dBits(i) And &HFF&) \ &H) * &H
　　dBits(i) = (dBits(i) And &HFF) * &H用B值運算
　　Next
　　SetBitmapBits Bmp AllBytes dBits()
　　GrayBmp =
　　Case
　　ReDim dBits(AllBytes )
　　GetBitmapBits Bmp AllBytes dBits()
　　For j = To h
　　m = j * LineBytes
　　For i = m To m + w * Step
　　dBits(i) = dBits(i + )
　　dBits(i + ) = dBits(i)
　　Next
　　Next
　　SetBitmapBits Bmp AllBytes dBits()
　　GrayBmp =
　　Case
　　按格式運算
　　ReDim dBits(AllBytes \ )
　　GetBitmapBits Bmp AllBytes dBits()
　　For j = To h
　　m = j * LineBytes \
　　For i = m To m + w
　　l = dBits(i) And &HC&
　　l = l * + l + l \
　　CopyMemory dBits(i) l 　這句沒辦法不用CopyMemory會溢出低效源於此
　　Next
　　Next
　　SetBitmapBits Bmp AllBytes dBits()
　　GrayBmp =
　　End Select
　　BitBlt dHdc x y w h hdc vbSrcCopy
　　End With
　　last:
　　DelMyHdc tmpdc
　　End Function
　　Private Sub Form_Load()
　　ScaleMode =
　　AutoRedraw = True
　　Picture = LoadPicture(f:\jpg)
　　CommandCaption = 測試
　　End Sub
　　
　　測試用代碼
　　Private Sub Form_Resize()
　　PaintPicture Picture ScaleWidth ScaleHeight
　　End Sub
　　
　　Private Sub Command_Click()
　　Dim t As Long s As String s As String i As Long
　　t = GetTickCount
　　GrayBmp hdc ScaleWidth ScaleHeight
　　Refresh
　　MsgBox GetTickCount t & s
　　End Sub
　　

From:http://tw.wingwit.com/Article/program/net/201311/13229.html