请问各位高手帮改代码。

Question

下面的代码是从网上下来的，其功能是提取PICTURE1中图片的全部像素，然后复制到PICTURE2中，我想如何增加代码，能实现在复制图片的同时，能将图片中的全部红色替换成白色，请高手帮忙，谢谢！
'获取像素   DibGet()
'图像输出   DIBPut()
'Copy 数组  CopyData()'用于存放从DIB输入的像素值(获取的像素数组)    ColVal()
'注 第一维: 0= B 值  1= G 值  2= R 值  3= Alpha 
'   第二维: X 值
'   第三维: Y 值'删除一个DC
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
'删除一个对象
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'选择当前对象
Private Declare Function GetCurrentObject Lib "gdi32" (ByVal hdc As Long, ByVal uObjectType As Long) As Long
'获取DIB
Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BitMapInfo, ByVal wUsage As Long) As Long
'获取系统时间
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
'输出图像
Private Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dx As Long, ByVal dy As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BitMapInfo, ByVal wUsage As Long) As Long
'内存操作
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
      
'数据结构定义:
Private Type BitMapInfoHeader '文件信息头——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 Type
  
Private Type RGBQuad
    rgbBlue   As Byte
    rgbGreen   As Byte
    rgbRed   As Byte
    'rgbReserved   As   Byte
End Type
  
Private Type BitMapInfo
  bmiHeader   As BitMapInfoHeader
  bmiColors   As RGBQuad
End Type
  
'过程中用到的全局变量:
Private Const Bits As Long = 32         '颜色深度，这里把所有图像都按照32位来处理
Public Done As Boolean                  '用于标记一个过程是否结束
Public TimeGet As Long                  '用于记录输入过程处理所花费的时间
Public TimePut As Long                  '用于记录输出过程处理所花费的时间
Dim ColVal() As Byte                    '用于存放从DIB输入的像素值
Dim ColOut() As Byte                    '用于存放向DIB输出的像素值
Dim InPutHei As Long                    '用于记录输入图像的高度
Dim InPutWid As Long                    '用于记录输入图像的宽度
Dim bi24BitInfo As BitMapInfo           '定义BMP信息'获取像素
Public Sub DibGet(ByVal IdSource As Long, XBegin As Long, ByVal YBegin As Long, ByVal XEnd As Long, ByVal YEnd As Long)
  Dim iBitmap     As Long
  Dim iDC     As Long
  Dim I     As Long
  Dim W     As Long
  Dim H     As Long
    
  On Error GoTo ErrLine
  Done = False
  TimeGet = timeGetTime
  InPutWid = XEnd - XBegin
  InPutHei = YEnd - YBegin
  
  W = InPutWid + 1
  H = InPutHei + 1
    
  I = (Bits \ 8) - 1
  ReDim ColVal(I, InPutWid, InPutHei)
  With bi24BitInfo.bmiHeader
    .biBitCount = Bits
    .biCompression = 0&
    .biPlanes = 1
    .biSize = Len(bi24BitInfo.bmiHeader)
    .biWidth = W
    .biHeight = H
  End With
    
  iBitmap = GetCurrentObject(IdSource, 7&)
  GetDIBits IdSource, iBitmap, 0&, H, ColVal(0, 0, 0), bi24BitInfo, 0&
  DeleteObject iBitmap
  Done = True
  TimeGet = timeGetTime - TimeGet
  Exit Sub
ErrLine:
  MsgBox "错误号:" & Err.Number & ":" & Err.Description
End Sub'图像输出
Private Sub DIBPut(ByVal IdDestination As Long, Width As Long, Height As Long)
  Dim W As Long
  Dim H As Long
  Dim LineBytes As Long  On Error GoTo ErrLine
    Done = False
    TimePut = timeGetTime
    
    W = Width + 1
    H = Height + 1
    
    With bi24BitInfo.bmiHeader
      .biWidth = W
      .biHeight = H
      LineBytes = ((W * Bits + 31) And &HFFFFFFE0) \ 8
      .biSizeImage = LineBytes * H
    End With
    SetDIBitsToDevice IdDestination, 0, 0, W, H, 0, 0, 0, H, ColOut(0, 0, 0), bi24BitInfo, 0    Done = True
    TimePut = timeGetTime - TimePut
    Exit Sub
  On Error GoTo 0
ErrLine:
  MsgBox Err.Description
End Sub'Copy 数组
Public Sub CopyData(ByVal W As Long, ByVal H As Long)
  Dim Length As Long
  Dim I As Long
  Dim L As Long
  
  I = Bits \ 8
  L = I - 1
  Length = (W + 1&) * (H + 1&) * I
  ReDim ColOut(L, W, H)
  CopyMemory ColOut(0, 0, 0), ColVal(0, 0, 0), Length
End Sub'新建一窗体  添加 Picture1 , Picture2 ,Command1
'给 Picture1 Load 一图片'按钮事件
Private Sub Command1_Click()
  With Picture1
    .AutoRedraw = True
    .AutoSize = True
    .ScaleMode = 3
    .BorderStyle = 0
    DibGet .hdc, 0, 0, .ScaleWidth, .ScaleHeight
  End With
  CopyData InPutHei, InPutWid
  
  With Picture2
    .AutoRedraw = True
    .AutoSize = True
    .ScaleMode = 3
    .BorderStyle = 0
    DIBPut .hdc, InPutWid, InPutHei
    .Refresh
  End With  
End Sub

Answer 1

LZ可对下句的ColOut(0, 0, 0)设置试做改动
SetDIBitsToDevice IdDestination, 0, 0, W, H, 0, 0, 0, H, ColOut(0, 0, 0), bi24BitInfo, 0
例:
SetDIBitsToDevice IdDestination, 0, 0, W, H, 0, 0, 0, H, ColOut(1, 10, 0), bi24BitInfo, 0
具体效果须按试验看.
原图:修改后:

Answer 2

上图是改动后
以下是原图:
http://album.hi.csdn.net/App_Uploads/zdingyun/20080911/121829217.jpg?d=20080921111835531

Answer 3

'图像输出
Private Sub DIBPut(ByVal IdDestination As Long, Width As Long, Height As Long)
  Dim W As Long
  Dim H As Long
  Dim I, j As Long
  Dim LineBytes As Long  On Error GoTo ErrLine
    Done = False
    TimePut = timeGetTime
    
    W = Width + 1
    H = Height + 1
    
    With bi24BitInfo.bmiHeader
      .biWidth = W
      .biHeight = H
      LineBytes = ((W * Bits + 31) And &HFFFFFFE0) \ 8
      .biSizeImage = LineBytes * H
    End With
    '==================================================================
    ' 替换纯色的R 255 G 0 B 0 为 R 0 G 0 B 0
    '
    ' 不知道这个能不能满足你的要求,我搞了好半天
    '
    '==================================================================
    For I = 0 To H - 1
        For j = 0 To W - 1
            If ColOut(2, I, j) = 255 And ColOut(0, I, j) = 0 And ColOut(1, I, j) = 0 Then
               ColOut(2, I, j) = 0
            End If
        Next j
    Next I
    '===================================================================
    SetDIBitsToDevice IdDestination, 0, 0, W, H, 0, 0, 0, H, ColOut(0, 0, 0), bi24BitInfo, 0    Done = True
    TimePut = timeGetTime - TimePut
    Exit Sub
  On Error GoTo 0
ErrLine:
  MsgBox Err.Description
End Sub

Answer 4

'按钮事件
Private Sub Command1_Click()
  With Picture1
    .AutoRedraw = True
    .AutoSize = True
    .ScaleMode = 3
    DibGet .hdc, 0, 0, .ScaleWidth, .ScaleHeight
  End With
  CopyData InPutHei, InPutWid
  
  With Picture2
    .AutoRedraw = True
    .AutoSize = True
    .ScaleMode = 3
    DIBPut .hdc, InPutWid, InPutHei
    .Refresh
  End With
End Sub这里如果设置BORDERSTYLE 会影响到图片的... 所以把它去掉后...就好了,不会出现最下面和右边出现黑线的情况