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

'灰度处理主函数
Public 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

呵呵，看来真的是打击到师兄的积极性了

还打击个屁啊，没见我这两个月都不怎么发源码啦？
回帖大多都是跟个函数名，看得懂就看，看不懂也别问我，问了也不答。