有谁知道关于图象三源色处理的控件，个位，小弟很急，有分先上，另外再追加

[LIKEVB]

我使用pset方法，但是TMD严重失真，而且很慢，有谁知道方法，感激不进

[iamfancy]

有个问题，不知道你的色彩模式怎么样？如果是用的256色模式，画真彩色的东西，当然会失真，不过该怎么设置我也不知道。这个意见你可以参考参考。

[cofei]

详细一点吧！否则没法帮。

[enmity]

就是，把代码贴出来好了！

[LIKEVB]

UP
我试过biblt,但是颜色不纯,而且图像边缘有马赛克
游说有更好的办法
??

[prefix]

setpixel的速度是pset的50倍以上.

[Seedling]

'图象三源色处理且速度很快


'Module

Option Explicit

Public Type BITMAPINFOHEADER
biSize As Long '结构长度
biWidth As Long '指定位图的宽度，以像素为单位
biHeight As Long '" " 高度 " "
biPlanes As Integer '指定目标设备的级数(必须为 1 )
biBitCount As Integer '每一个像素的位(1，4，8，16，24，32)
biCompression As Long '指定压缩类型(BI_RGB 为不压缩)
biSizeImage As Long '指定图象的大小，以字节为单位
biXPelsPerMeter As Long '指定设备水平分辨率，以每米的像素为单位
biYPelsPerMeter As Long '垂直分辨率，其他同上
biClrUsed As Long '在颜色表中实际使用的色彩索引的个数，用O表示全要使用
biClrImportant As Long '指定认为重要的颜色索引个数，用 0 表示所有颜色均重要
End Type

Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte '保留，必须为 0
End Type

Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER '一个 BITMAPINFOHEADER
bmiColors As RGBQUAD '一个 RGBQUAD结构组成的数组
End Type



Public Type BITMAP
bmType As Long '指定了位图的类型。对于逻辑位图，这个成员必须为0。
bmWidth As Long '指定了位图的宽度，以像素为单位。宽度必须大于0
bmHeight As Long '指定了位图的高度，以扫描行为单位。高度必须大于0
bmWidthBytes As Long '指定了每个扫描行中字节的数目。
bmPlanes As Integer '指定了位图中颜色平面的数目。
bmBitsPixel As Integer '指定了每个位平面中用于定义一个像素所需的颜色位数。
bmBits As Long '指向位图中位值的位置。bmBits成员必须是一个指向单字节数组的长指针。
End Type

Public 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)
Public Declare Function DeleteDC& Lib "gdi32" (ByVal hDC As Long)
Public Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal hDC As Long)
Public 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)
Public Declare Function StretchDIBits& 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 wSrcWidth As Long, ByVal wSrcHeight As Long, lpBits As Any, lpBitsInfo As BITMAPINFO, _
ByVal wUsage As Long, ByVal dwRop As Long)
Public Declare Function GetDeviceCaps& Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long)
Public Declare Function GetObjectAPI& Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, _
ByVal nCount As Long, lpObject As Any)

Public Const RASTERCAPS& = 38
Public Const RC_DIBTODEV& = &H200
Public Const DIB_RGB_COLORS& = 0

'==================================================================================

Public Function SetGrayBitmap(ByVal hDC As Long, ByVal hBitmap As Long, R As Integer, G As Integer, B As Integer) As Boolean

Dim i As Long
Dim j As Long
Dim tcolor() As Byte

Dim tempptr As Long
Dim lcolor As Long

Dim DIBWidth As Long '扫描行长度 (字节)
Dim bufSize As Long 'Size of buffer
Dim bi As BITMAPINFO
Dim bm As BITMAP
Dim tempDC As Long
Dim dl As Long

SetGrayBitmap = False
tempDC = CreateCompatibleDC(hDC)

'Get the info for the picture bitmap
dl = GetObjectAPI(hBitmap, Len(bm), bm)

'Can this DC handle the DIB?
If (GetDeviceCaps(tempDC, RASTERCAPS) And RC_DIBTODEV = 0) Then
Exit Function
End If

'Fill the BITMAPINFO for the desired DIB.
bi.bmiHeader.biSize = Len(bi.bmiHeader)
bi.bmiHeader.biWidth = bm.bmWidth
bi.bmiHeader.biHeight = bm.bmHeight
bi.bmiHeader.biPlanes = 1
bi.bmiHeader.biBitCount = 24
bi.bmiHeader.biCompression = 0& 'BI_RGB

'Calculate the data buffer size needed
bufSize& = bi.bmiHeader.biWidth
bufSize& = bufSize * 3
bufSize& = ((bufSize + 3) / 4) * 4
DIBWidth = bufSize
bufSize& = bufSize * bi.bmiHeader.biHeight

ReDim tcolor(bufSize)

'Get Dib data to buffer
dl& = GetDIBits(tempDC, hBitmap, 0, _
bm.bmHeight, tcolor(0), bi, DIB_RGB_COLORS)

'Set gray colors
For i = 0 To bm.bmHeight - 1
tempptr = i * DIBWidth
For j = 0 To DIBWidth - 1 Step 3
If tcolor(tempptr + j + 2) + R>255 Then
tcolor(tempptr + j + 2) =255
ElseIf tcolor(tempptr + j + 2) + R<0 Then
tcolor(tempptr + j + 2) =0
Else
tcolor(tempptr + j + 2) =tcolor(tempptr + j + 2) + R
End If
If tcolor(tempptr + j + 1) + G>255 Then
tcolor(tempptr + j + 1) =255
ElseIf tcolor(tempptr + j + 1) + G<0 Then
tcolor(tempptr + j + 1) =0
Else
tcolor(tempptr + j + 1) =tcolor(tempptr + j + 1) + G
End If
If tcolor(tempptr + j ) + B>255 Then
tcolor(tempptr + j ) =255
ElseIf tcolor(tempptr + j ) + B<0 Then
tcolor(tempptr + j ) =0
Else
tcolor(tempptr + j ) =tcolor(tempptr + j ) + B
End If


Next
Next

'Set DIB data to device DC
dl& = StretchDIBits(hDC, 0, 0, bm.bmWidth, bm.bmHeight, _
0, 0, bm.bmWidth, bm.bmHeight, tcolor(0), bi, DIB_RGB_COLORS, vbSrcCopy)
dl = DeleteDC(tempDC)

SetGrayBitmap = True

End Function

'/////////////////////////////////////////////////////////


'Form

Private Sub Command1_Click()
'预先在Picture1中加载图片文件
'例：红色分量减少50,绿色、兰色分量不变(R=-50,G=0,B=0)
SetGrayBitmap Picture1.hDC, Picture1.Image.Handle, -50, 0, 0
End Sub

Private Sub Form_Load()
Picture1.AutoRedraw = True
Picture1.ScaleMode = 3

'Picture1.Picture = LoadPicture( FilePath & "\" & FileName)

End Sub

[LIKEVB]

UP
问一下县,打印效果如何???

[LIKEVB]

up
好像效果还不如biblt

[LIKEVB]

up!!!
有没有人理亚

[Seedling]

上述提供的方法对某些图片来说效果确实不佳：会出现间隔条缝！
本人写了内存操作的方法，可消除以上缺点，若要请留下"妹儿"！

[liusuanse]

to seedling
谢谢
[e-mail]
万分感谢
带源码的么??

[LIKEVB]

up to seedling
帮帮了,找你好久了
[e-mail]
liusuanse(菜鸟一)就是我的人
我是likevb

[LIKEVB]

UP
TO SEEDLING
被外星人绑架了么???

[LIKEVB]

UP

[qyh]

呵呵，我没有这方面的经验，只好关注了。

[raeck]

up

[Seedling]

to LIKEVB(我应该叫什么？？):
我已将原代码邮出(请不要随便分发)，请查收。
此原码经适当改进可以用来作图像处理，祝你好运。
别忘了给务！

[LIKEVB]

UP TOO
TO BICOM
谢谢

[Seedling]

???

[MonkeyLin]

GetPixel and SetPixel