作为图像爱好者，我以我的方式表示对震亡同胞们的默哀----彩色图像<<真正，即32bpp->8bpp>>转为灰度图像（源代码）。

Question

    今天很多网站也实现了真彩色转为灰度图像来作为主页，作为图像的研究者，特此放送严格意义上的32->8位图像的转变，并实现保存功能。
    此代码为我自己写的Cimage类中摘取的部分内容并作了大量简化和大量注释，如有疑问欢迎和群30417248内的其他高手交流。     
一下代码请贴如一个新建的Cimage类中：Option Explicit
Private Type BITMAPFILEHEADER
    bfType      As Integer
    bfSize      As Long
    bfReserved1 As Integer
    bfReserved2 As Integer
    bfOffBits   As Long
End TypePrivate Type BITMAPINFOHEADER
    biSize          As Long
    biWidth         As Long
    biHeight        As Long
    biPlanes        As Integer
    biBitCount      As Integer
    biCompression   As Long
    biSizeImage     As Long
    biXPelsPerMeter As Long
    biYPelsPerMeter As Long
    biClrUsed       As Long
    biClrImportant  As Long
End TypePrivate Type bitmap
    bmType       As Long
    bmWidth      As Long
    bmHeight     As Long
    bmWidthBytes As Long
    bmPlanes     As Integer
    bmBitsPixel  As Integer
    BmBits       As Long
End TypePrivate Type RGBQUAD
    Blue As Byte
    Green As Byte
    Red As Byte
    Reserved As Byte
End TypePrivate Type BITMAPINFO
    bmiHeader As BITMAPINFOHEADER
    bmiColors As RGBQUAD
End TypePrivate Const BI_bitfields = 3&                 '带掩码的
Private Const BI_RGB = 0                        '正常
Private Const DIB_RGB_COLORS = 0                '真彩色
Private Const OBJ_BITMAP = 7                    '位图对象
Private Const SRCCOPY = &HCC0020                '直接拷贝
Private Const IMAGE_BITMAP = 0                  'LoadImage函数的载入类型，位图
Private Const LR_LOADFROMFILE = &H10            '从文件载入
Private Const LR_CREATEDIBSECTION = &H2000      '如果指定了IMAGE_BITMAP，就返回DIBSection的句柄，而不是位图的句柄
Private Const STRETCH_ANDSCANS = 1              '默认设置。剔除的线段与剩下的线段进行AND运算。这个模式通常应用于采用了白色背景的单色位图
Private Const STRETCH_ORSCANS = 2               '剔除的线段被简单的清除。这个模式通常用于彩色位图
Private Const STRETCH_DELETESCANS = 3           '剔除的线段与剩下的线段进行OR运算。这个模式通常应用于采用了白色背景的单色位图
Private Const STRETCH_HALFTONE = 4              '目标位图上的像素块被设为源位图上大致近似的块。这个模式要明显慢于其他模式'******************************************** 用于图像方面的相关API ********************************************Private Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, lpBitsInfo As BITMAPINFOHEADER, ByVal wUsage As Long, lpBits As Long, ByVal handle As Long, ByVal dw As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, lpRGBQuad As Any) As Long
Private Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long'******************************************** 用于系统输出的相关API ********************************************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 StretchBlt Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long'******************************************** 用于内存处理的相关API ********************************************Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Private Declare Function VarPtrArray Lib "msvbvm50" Alias "VarPtr" (Ptr() As Any) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlMoveMemory" (dest As Any, ByVal numBytes As Long)
'******************************************** 公共常用的API函数 ********************************************Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) 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 mHdc                As Long                 '保存了内存DC
Private mhDib               As Long                 '当前DibSection的句柄
Private mhOldDib            As Long                 '原始DibSection的句柄
Private mPtr                As Long                 '当前DibSection的内存地址
Private mWidthBytes         As Long                 '当前图像的扫描行字节数
Private mBmpInfo            As BITMAPINFOHEADER     '当前图像的文件信息Private Sub Class_Terminate()
    Destroy
End SubPublic Property Get Width() As Long
    Width = mBmpInfo.biWidth
End PropertyPublic Property Get Height() As Long
    Height = mBmpInfo.biHeight
End PropertyPublic Property Get hdc() As Long
    hdc = mHdc
End PropertyPublic Property Get DataPtr() As Long
    DataPtr = mPtr
End PropertyPublic Property Get WidthBytes() As Long
    WidthBytes = mWidthBytes
End Property

Answer 1

'*****************************************************************************************
'**    函 数 名 ：  CreateDib
'**    输    入 ：  Width       -   DIB的宽度
'                   Height      -   DIB的高度
'                   Bits        -   位图的位数，默认为32
'**    输    出 ：  返回是否创建成功
'**    功能描述 ：  创建新的DIB
'**    开发日期 ：  2008-5-19
'**    作    者 ：  laviewpbt
'**    修改日期 ：
'**    版    本 ：  Version 1.3.1
'****************************************************************************************Private Function CreateDib(ByVal Width As Long, ByVal Height As Long, Optional ByVal Bits As Integer = 32) As Boolean
    Dim i As Long
    Destroy                                 '销毁以前的DIB
    mHdc = CreateCompatibleDC(0)            '创建DIB设备场景
    If mHdc <> 0 Then
        With mBmpInfo                       '位图信息头
            .biSize = Len(mBmpInfo)
            .biPlanes = 1
            .biBitCount = Bits
            .biWidth = Width
            .biHeight = Height
            .biCompression = BI_RGB
            Select Case Bits                '保证每个扫描行必须是4的倍数
'                Case 1
'                    mWidthBytes = (((.biWidth + 7) \ 8 + 3) And &HFFFFFFFC)
'                Case 4
'                    mWidthBytes = (((.biWidth + 1) \ 2 + 3) And &HFFFFFFFC)
                Case 8
                    mWidthBytes = ((.biWidth + 3) And &HFFFFFFFC)
'                Case 16
'                    mWidthBytes = ((.biWidth * 2 + 3) And &HFFFFFFFC)
'                Case 24
'                    mWidthBytes = ((.biWidth * 3 + 3) And &HFFFFFFFC)
                Case 32
                    mWidthBytes = .biWidth * 4
                Case Else
                    Exit Function
            End Select
            .biSizeImage = mWidthBytes * .biHeight
        End With
        mhDib = CreateDIBSection(mHdc, mBmpInfo, DIB_RGB_COLORS, mPtr, 0, 0)    '创建DIB，mPtr就是指向这个创建的DIBSECTION的内存地址
        If mhDib <> 0 Then
            mhOldDib = SelectObject(mHdc, mhDib)                                '选入设备场景
            If Bits = 8 Then                                                    '如果是8位，我们认为它是灰度图像，建立起调色板
                ReDim ColorTable(0 To 255) As RGBQUAD
                For i = 0 To 255
                    ColorTable(i).Red = i
                    ColorTable(i).Green = i
                    ColorTable(i).Blue = i
                Next
                SetDIBColorTable mHdc, 0, 256, ColorTable(0)                    '设置调色板数据
            End If
            CreateDib = True
        End If
    End If
End Function
Public Function LoadPictureFormFile(Filename As String) As Boolean
    On Error Resume Next                                            '防止LoadPicture加载不支持的图片文件或非图片文件时出错
    Dim StdPic As StdPicture
    Dim Width As Long, Height As Long
    If Dir(Filename) <> "" Then
        Set StdPic = LoadPicture(Filename)
        If Not StdPic Is Nothing Then
            Width = ConvertHimetrix2Pixels(StdPic.Width, True)      'StdPicture宽度中的单位是Himetrics
            Height = ConvertHimetrix2Pixels(StdPic.Height, False)
            If CreateDib(Width, Height, 32) = True Then             '创建一个空白的Dib
                StdPic.Render mHdc + 0, 0, 0, Width + 0, Height + 0, 0, StdPic.Height, StdPic.Width, -StdPic.Height, ByVal 0   '类似于BMP的逆序存储，所以用-StdPic.Height
            End If
            Set StdPic = Nothing
        End If
    End If
End Function
Public Function ChangeToGreyMode() As Boolean
    Dim i                   As Long, j                  As Long
    Dim DataArr(0 To 2)     As Byte, pDataArr(0 To 0)   As Long
    Dim OldArrPtr           As Long, OldpArrPtr         As Long
    Dim DataArrC(0 To 2)    As Byte, pDataArrC(0 To 0)  As Long
    Dim OldArrPtrC          As Long, OldpArrPtrC        As Long
    Dim LineAddBytes        As Long
    Dim PixelAddBytes       As Long, mPtrC              As Long
    Const Blue              As Long = 28
    Const Green             As Long = 150     '用long可以方便的避免VB的溢出错误
    Const Red               As Long = 77
    If mHdc <> 0 And mBmpInfo.biBitCount = 32 Then
        MakePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr        '绑定模拟指针
        MakePoint VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC
        mPtrC = GlobalAlloc(GPTR, mBmpInfo.biSizeImage)
        CopyMemory ByVal mPtrC, ByVal mPtr, mBmpInfo.biSizeImage        '复制真彩色图像的数据，其实就是一片连续的内存而已
        If CreateDib(Width, Height, 8) = True Then                      '新建一个8位位图
            pDataArr(0) = mPtr
            pDataArrC(0) = mPtrC
            LineAddBytes = mWidthBytes - mBmpInfo.biWidth               '保证每个扫描行的宽度
            For i = 1 To mBmpInfo.biHeight
                For j = 1 To mBmpInfo.biWidth
                    DataArr(0) = (DataArrC(0) * Blue + DataArrC(1) * Green + DataArrC(2) * Red) \ 255  '灰度算法
                    pDataArrC(0) = pDataArrC(0) + 4
                    pDataArr(0) = pDataArr(0) + 1
                Next
                pDataArr(0) = pDataArr(0) + LineAddBytes                '32位的位图不需要这个
            Next
        End If
        GlobalFree mPtrC                                                '释放分配的内存
        FreePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
        FreePoint VarPtrArray(DataArrC), VarPtrArray(pDataArrC), OldArrPtrC, OldpArrPtrC        '取消模拟指针
    End If
    ChangeToGreyMode = True
End FunctionPublic Function OutPut(ByVal OutDC As Long, Optional ByVal x As Long = 0, Optional ByVal y As Long = 0, Optional ByVal Width As Long, Optional ByVal Height As Long, Optional ByVal Srcx As Long = 0, Optional ByVal Srcy As Long = 0, Optional ByVal dwRop As RasterOpConstants = vbSrcCopy) As Boolean
    If Width = 0 Then Width = mBmpInfo.biWidth
    If Height = 0 Then Height = mBmpInfo.biHeight
    OutPut = BitBlt(OutDC, x, y, Width, Height, mHdc, Srcx, Srcy, dwRop)
End Function
Public Sub Destroy()
    If mHdc <> 0 Then
        If mhDib <> 0 Then
            SelectObject mHdc, mhOldDib
            DeleteObject mhDib
        End If
        DeleteObject mHdc
        mBmpInfo.biBitCount = 0
        mBmpInfo.biWidth = 0
        mBmpInfo.biHeight = 0
        mBmpInfo.biSizeImage = 0
    End If
    mHdc = 0:   mPtr = 0:       mWidthBytes = 0
    mhDib = 0:  mhOldDib = 0:
End Sub
' 将Himetrics转变为 Pixels
Private Function ConvertHimetrix2Pixels(HiMetrix As Long, Horizontally As Boolean) As Long
    If Horizontally Then
        ConvertHimetrix2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelX
    Else
        ConvertHimetrix2Pixels = HiMetrix * 1440 / 2540 / Screen.TwipsPerPixelY
    End If
End Function

Answer 2

'*****************************************************************************************
'**    过 程 名 ：  MakePoint
'**    输    入 ：
'**    功能描述 ：  绑定模拟数组
'**    开发日期 ：  2007-4-02
'**    作    者 ：  laviewpbt
'**    修改日期 ：
'**    版    本 ：  Version 1.2.1
'****************************************************************************************Public Sub MakePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByRef OldArrPtr As Long, ByRef OldpArrPtr As Long)
    Dim Temp As Long, TempPtr As Long
    CopyMemory Temp, ByVal DataArrPtr, 4        '得到DataArrPtr的SAFEARRAY结构的地址
    Temp = Temp + 12                            '这个指针偏移12个字节后就是pvData指针
    CopyMemory TempPtr, ByVal pDataArrPtr, 4    '得到pDataArrPtr的SAFEARRAY结构的地址
    TempPtr = TempPtr + 12                      '这个指针偏移12个字节后就是pvData指针
    CopyMemory OldpArrPtr, ByVal TempPtr, 4     '保存旧地址
    CopyMemory ByVal TempPtr, Temp, 4           '使pDataArrPtr指向DataArrPtr的SAFEARRAY结构的pvData指针
    CopyMemory OldArrPtr, ByVal Temp, 4         '保存旧地址
End Sub'*****************************************************************************************
'**    过 程 名 ：  FreePoint
'**    输    入 ：
'**    功能描述 ：  取消绑定模拟数组
'**    开发日期 ：  2007-4-02
'**    作    者 ：  laviewpbt
'**    修改日期 ：
'**    版    本 ：  Version 1.2.1
'****************************************************************************************Public Sub FreePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByVal OldArrPtr As Long, ByVal OldpArrPtr As Long)
    Dim TempPtr As Long
    CopyMemory TempPtr, ByVal DataArrPtr, 4         '得到DataArrPtr的SAFEARRAY结构的地址
    CopyMemory ByVal (TempPtr + 12), OldArrPtr, 4   '恢复旧地址
    CopyMemory TempPtr, ByVal pDataArrPtr, 4        '得到pDataArrPtr的SAFEARRAY结构的地址
    CopyMemory ByVal (TempPtr + 12), OldpArrPtr, 4  '恢复旧地址
End Sub'*****************************************************************************************
'**    过 程 名 ：  ChkFileWrite
'**    输    入 ：  Filename  -   文件路径，文件不存在，返回错误
'**    功能描述 ：  判断是否可以写入改文件
'**    开发日期 ：  2007-4-02
'**    作    者 ：  laviewpbt
'**    修改日期 ：
'**    版    本 ：  Version 1.2.1
'****************************************************************************************Private Function ChkFileWrite(Filename As String) As Boolean
    Dim FileNum As Long
    FileNum = FreeFile
    On Error Resume Next
    Open Filename For Output As #FileNum
    If Err.Number Then
    Else
        Close #FileNum
        ChkFileWrite = True
    End If
End Function
以下位测试代码：Private Sub Form_Load()
    Me.AutoRedraw = True
    Dim Img As New Cimage
    Img.LoadPictureFormFile "c:\2.bmp"
    Img.ChangeToGreyMode
    Img.OutPut Me.hdc
    Me.Refresh
    Img.SavePictureToFile "c:\3.bmp"    '看看保存后的图像是不是8位的
    Img.Destroy                         '记得一定要销毁哦
End Sub

Answer 3

楼主对此方面的功力可非一般, 造诣挺深的.今天我也将我的彩色旋转图标转为8位的黑白图片了.只可惜, XP 不支援 ImgEdit.ocx 否则也不用那么麻烦了.
'*****************************************
下面代码是 2000 系统下的代码 (XP就别试了)'添加 Command1
'工程部件下找到kodak 第一个 imgedit.ocx 添加此控件到窗体内
Private Sub Form_Load()
   ImgEdit1.Image = "c:\1.jpg" '装载一幅图片
   ImgEdit1.Display '将装载的24位真彩图片显示出来.
End SubPrivate Sub Command1_Click()
   ImgEdit1.SaveAs "c:\test.jpg", 6, 3, 1, 0, True  '保存为8位的黑白图像
   ImgEdit1.Image = "c:\test.jpg"
   ImgEdit1.Display '将8位黑白图像的图片显示出来.
End Sub这个图标是我转为黑白的,不是CSDN转的

Answer 4

好像没有保存文件的代码
补上：
Public Function SavePictureToFile(Filename As String) As Boolean
    Dim i               As Long, j                  As Long
    Dim FileNumber      As Long, ColorTable()       As RGBQUAD
    Dim BmpInfoHeader   As BITMAPFILEHEADER
    
    If ChkFileWrite(Filename) = True And mHdc <> 0 Then         '目标文件可写且有数据可写
        BmpInfoHeader.bfType = &H4D42                           'BMP文件的标识
        If mBmpInfo.biBitCount = 8 Then                         '只有biBitCount等于1、4、8时才有调色板
            BmpInfoHeader.bfOffBits = 54 + 4 * 256              '调色板的大小
            ReDim ColorTable(0 To 255) As RGBQUAD
            GetDIBColorTable mHdc, 0, 256, ColorTable(0)
        ElseIf mBmpInfo.biBitCount = 32 Then
            BmpInfoHeader.bfOffBits = 54
        End If
        BmpInfoHeader.bfSize = BmpInfoHeader.bfOffBits + mBmpInfo.biSizeImage   '文件大小
        FileNumber = FreeFile
        Open Filename For Binary As #FileNumber
        Put #FileNumber, , BmpInfoHeader                                'BMP文件头
        Put #FileNumber, , mBmpInfo                                     '位图信息头
        If mBmpInfo.biBitCount = 8 Then Put #FileNumber, , ColorTable  '调色板
        ReDim DibBytes(1 To mBmpInfo.biSizeImage) As Byte
        CopyMemory DibBytes(1), ByVal mPtr, mBmpInfo.biSizeImage
        Put #FileNumber, , DibBytes             '位图数据
        Close #FileNumber
        SavePictureToFile = True
    End If
End Function

Answer 5

对css真是不明白啊，不过能把网页中图片的显示颜色也能改了(但实际上，图片的颜色并没有变，下载下来还是正常的)

Answer 6

<style>
 *{filter: Gray;}
</style>这样就行了支持一下楼主.现在VB6里面越来越少能力者了.主要是资源越来越丰富了,人也就越来越懒了....

Answer 7

XP支持ImgEdit.ocx的，不过需要整套软件一并安装！
我做远程控制的时候用过，单个文件注册不让注册，非得整个程序一并安装了才能让你用这个OCX
后来嫌麻烦就不管它了~

Answer 8

不知楼主这个Cimage一共有多少个公共函数？是否还能放出一些？呵呵，我有点贪

Answer 9

100多个吧，慢慢的给出一些，不过CSDN的人气不行了。

Answer 10

CSDN应该学http://www.experts-exchange.com。分二部分，一部分收费，会员交费，解答者收费；一部分free，开发给所有人.

Answer 11

Laview,
如果上面的编码是你CImage的一部分，有些问题与你商榷：Set StdPic = LoadPicture(Filename) 1.LoadPicture仅支持.bmp，.jpg，.emf，.wmf，.ico，.gif等格式。
2.LoadPicture不支持Unicode.把你的XP/Vista的Locale ID 设为1033（English),在读中文的文件名或包含中文的路径，LoadPicture failed.

Answer 12

LoadPicture函数的确实只能支持这些，其他格式我是通过解析的方式或者GDI+做的，这里没有给出代码至于Unicode我一直没在意，因为周围没有英文版的系统，我也没测试，我知道有这个问题。谢谢你的好意

Answer 13

没人给以价值的评论。CSDN真地出了问题。

Answer 14

有没有办法，直接对Pictuerbox里的图像进行转换，然后直接生成灰度图像到pictuerbox中、

Answer 15

stdpicture是不具有保存位8位的功能的，对于已经加载到picturebox中的图像，是可以找到其内存地址的，但是如果要让其变为灰度，在视觉上还是可以的，但实际上内部他还是真彩色。

Answer 16

我是 急功近利的 新人。。貌似 VC实现 这方面 更困难些。。虽然VB没看懂。。