Hola hace tiempo habías puesto un rutina para convertir una
imagen a escala de grises, bien la
pregunta es se podría convertir a la escala que yo quisiera, es decir si tomara
el color del commondialgo y luego
convertir la imagen a esa escala, realmente vi el código pero no pude hacer
nada, en este ejemplo el color gris esta buscado de esta manera

Código:

 









Rojo = lpBits(ContadorX, ContadorY)
Verde = lpBits(ContadorX + 1, ContadorY)
Azul = lpBits(ContadorX + 2, ContadorY)
Gris = (222 * Rojo + 707 * Verde + 71 * Azul) / 1000

La pregunta es si se podría hacer con todos los colores pero
sin tener que programar cada uno de los ellos?







La rutina que habías puesto:

Código:

Option Explicit
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = origen
Public Const DIB_RGB_COLORS = 0 ' tabla de color en RGB (rojo-verde-azul)
Public Const BI_RGB = 0&
Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public 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 Type
Public Type BITMAPINFO24
bmiHeader As BITMAPINFOHEADER
bmiColors() As RGBQUAD
End Type

Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type

Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO24, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
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) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long

Public Sub ConvierteGrises(hDCOrigen As Long, WidthOrigen As Long, HeightOrigen As Long)
Dim BytesPerLine As Long
Dim WinDC As Long
Dim TmpDC As Long
Dim dl As Long
Dim mBmp As Long
Dim AntBmp As Long
Dim Addrs As Long
Dim ContadorX As Long
Dim ContadorY As Long
Dim lpBits() As Byte
Dim mSizeImage As Long
Dim Rojo As Long, Verde As Long, Azul As Long, Gris As Long
Dim M_BitmapInfo As BITMAPINFO24
Dim SA As SAFEARRAY2D

Screen.MousePointer = 11
BytesPerLine = ScanAlign(WidthOrigen * 3)
mSizeImage = BytesPerLine * HeightOrigen
With M_BitmapInfo.bmiHeader
.biSize = Len(M_BitmapInfo.bmiHeader)
.biWidth = WidthOrigen
.biHeight = HeightOrigen
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = mSizeImage
End With
WinDC = GetDC(0)
TmpDC = CreateCompatibleDC(WinDC)
mBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)
dl = ReleaseDC(0, WinDC)
With SA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = HeightOrigen
.Bounds(1).lLbound = 0
.Bounds(1).cElements = BytesPerLine
.pvData = Addrs
End With
CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4
AntBmp = SelectObject(TmpDC, mBmp)
dl = BitBlt(TmpDC, 0, 0, WidthOrigen, HeightOrigen, hDCOrigen, 0, 0, SRCCOPY)
For ContadorY = 0 To HeightOrigen - 1
For ContadorX = 0 To (WidthOrigen * 3) - 1 Step 3
Rojo = lpBits(ContadorX, ContadorY)
Verde = lpBits(ContadorX + 1, ContadorY)
Azul = lpBits(ContadorX + 2, ContadorY)
Gris = (222 * Rojo + 707 * Verde + 71 * Azul) / 1000
lpBits(ContadorX, ContadorY) = Gris
lpBits(ContadorX + 1, ContadorY) = Gris
lpBits(ContadorX + 2, ContadorY) = Gris
Next ContadorX
Next ContadorY
CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
dl = BitBlt(hDCOrigen, 0, 0, WidthOrigen, HeightOrigen, TmpDC, 0, 0, SRCCOPY)
dl = SelectObject(TmpDC, AntBmp)
dl = DeleteObject(mBmp)
dl = DeleteDC(TmpDC)
Screen.MousePointer = 0
End Sub

Private Function ScanAlign(WidthBmp As Long) As Long
ScanAlign = (WidthBmp + 3) And &HFFFFFFFC
End Function

y para llamarla

Código:

Private Sub Picture1_Click()
Call ConvierteGrises(Picture1.hdc, Picture1.ScaleWidth, Picture1.ScaleHeight)
Picture1.Refresh
End Sub

Bien espero tu respuesta almenos por un si o por un no

Muchas gracias de antemano

Saludos










Edited by: Leandro

Acabo de probar el ejemplo de escala de grises y no me produce el efecto, la imagen despues de aplicar la funcion sigue con los colores originales

Salu2...

Hola tienes que ponerle al picture1 en las propiedades AutoRedraw = true y SacaleMode = 3

Creo que tuviera que funcionar bien

Saludos

Genial, ya funciona, era el AutoRedraw del PictureBox

Salu2...

Hola ya esta solucionado era cuestión de buscarle la vuelta,
de todas formas cualquier sugerencia es bienvenida, sinceramente el código esta
muy bueno y me parece seria un buen recurso para la guía, pero creo que te
corresponde ponerlo ya que eres el autor

En el modulo:

Código:

Option Explicit
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = origen
Public Const DIB_RGB_COLORS = 0 ' tabla de color en RGB (rojo-verde-azul)
Public Const BI_RGB = 0&
Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type
Public 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 Type
Public Type BITMAPINFO24
bmiHeader As BITMAPINFOHEADER
bmiColors() As RGBQUAD
End Type

Private Type SAFEARRAYBOUND
cElements As Long
lLbound As Long
End Type

Private Type SAFEARRAY2D
cDims As Integer
fFeatures As Integer
cbElements As Long
cLocks As Long
pvData As Long
Bounds(0 To 1) As SAFEARRAYBOUND
End Type
Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO24, ByVal un As Long, lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
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) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Ptr() As Any) As Long

Public Sub ConvierteColores(Pic As PictureBox, R As Integer, G As Integer, B As Integer)
Dim BytesPerLine As Long
Dim WinDC As Long
Dim TmpDC As Long
Dim dl As Long
Dim mBmp As Long
Dim AntBmp As Long
Dim Addrs As Long
Dim ContadorX As Long
Dim ContadorY As Long
Dim lpBits() As Byte
Dim mSizeImage As Long
Dim Rojo As Long, Verde As Long, Azul As Long, Gris As Long
Dim M_BitmapInfo As BITMAPINFO24
Dim SA As SAFEARRAY2D

Screen.MousePointer = 11
Pic = Pic 'solo para refrescar a la imagen original
Pic.ScaleMode = 3
Pic.AutoRedraw = True
BytesPerLine = ScanAlign(Pic.ScaleWidth * 3)
mSizeImage = BytesPerLine * Pic.ScaleHeight
With M_BitmapInfo.bmiHeader
.biSize = Len(M_BitmapInfo.bmiHeader)
.biWidth = Pic.ScaleWidth
.biHeight = Pic.ScaleHeight
.biPlanes = 1
.biBitCount = 24
.biCompression = BI_RGB
.biSizeImage = mSizeImage
End With
WinDC = GetDC(0)
TmpDC = CreateCompatibleDC(WinDC)
mBmp = CreateDIBSection(WinDC, M_BitmapInfo, DIB_RGB_COLORS, Addrs, 0, 0)
dl = ReleaseDC(0, WinDC)
With SA
.cbElements = 1
.cDims = 2
.Bounds(0).lLbound = 0
.Bounds(0).cElements = Pic.ScaleHeight
.Bounds(1).lLbound = 0
.Bounds(1).cElements = BytesPerLine
.pvData = Addrs
End With
CopyMemory ByVal VarPtrArray(lpBits), VarPtr(SA), 4
AntBmp = SelectObject(TmpDC, mBmp)
dl = BitBlt(TmpDC, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, Pic.hdc, 0, 0, SRCCOPY)
For ContadorY = 0 To Pic.ScaleHeight - 1
For ContadorX = 0 To (Pic.ScaleWidth * 3) - 1 Step 3
Rojo = lpBits(ContadorX, ContadorY)
Verde = lpBits(ContadorX + 1, ContadorY)
Azul = lpBits(ContadorX + 2, ContadorY)
Gris = (Rojo + Verde + Azul) / 7
lpBits(ContadorX, ContadorY) = Gris + B / 2
lpBits(ContadorX + 1, ContadorY) = Gris + G / 2
lpBits(ContadorX + 2, ContadorY) = Gris + R / 2
Next ContadorX
Next ContadorY
CopyMemory ByVal VarPtrArray(lpBits), 0&, 4
dl = BitBlt(Pic.hdc, 0, 0, Pic.ScaleWidth, Pic.ScaleHeight, TmpDC, 0, 0, SRCCOPY)
dl = SelectObject(TmpDC, AntBmp)
dl = DeleteObject(mBmp)
dl = DeleteDC(TmpDC)
Pic.Refresh
Screen.MousePointer = 0
End Sub

Private Function ScanAlign(WidthBmp As Long) As Long
ScanAlign = (WidthBmp + 3) And &HFFFFFFFC
End Function

y en el formulario

Código:

Option Explicit
Sub GetRGB(Color As Long, Red As Integer, Green As Integer, Blue As Integer)
Blue = (Color And &HFF0000) / (2 ^ 16)
Green = (Color And &HFF00&) / (2 ^ 8)
Red = (Color And &HFF&)
End Sub

Private Sub Command1_Click()
Dim R As Integer, G As Integer, B As Integer
CommonDialog1.ShowColor
Call GetRGB(CommonDialog1.Color, R, G, B)
Call ConvierteColores(Picture1, R, G, B)
End Sub

Iniciado por Leandro

sinceramente el código esta
muy bueno y me parece seria un buen recurso para la guía, pero creo que te
corresponde ponerlo ya que eres el autor

Puedes subirlo tu y mencionar a Critico como autor del codigo original en el recurso

Salu2...