hola gente

miren quiero poder , apartir de una imagen que se copia en un hdc (en un picturebox ), poder convertirla a un bitmap. ¿ para que ? . para poder guardarla con savepicture (en realidad no es pecisamente para esto, pero para que se entienda)

Asi como está el ejemplo que les muestro, no me sirve por que savepicture requiere de un valor de tipo "picture", y la imagen que se copia no es válida.

Tampoco sirve hacer Picturebox.picture = pictureox.image, y luego ejecutar SavePicture

Se que la solución está con algunas de las apis CreatecompatibleDc o createcompatibleBitmap o alguna de esas, pero no doy en el clavo

Les paso un ejemplo para que entiendan mas o menos lo que quiero

Este código tiene tres picture. El picture1 y el picture2 contienen un gráfico cargado con load picture

Al presionar un command (command1), se copia en el picture2, la imagen de picture1 con transparencia . DEspues al presionar un Command2, se copia el Hdc del picture2 al picture3. Hasta acá va bien.

El problema está despues de ejecutar el api BitBlt (dentro de command2 ), es decir no se que código poner para poder salvar el contenido como un bitmap


Colocar tres picture ( picture1, picture2 y picture3) y dos command

Código:

Option Explicit

Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd 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 Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type

Private Declare Function GdiAlphaBlend Lib "gdi32.dll" ( _
ByVal hdc As Long, _
ByVal lInt As Long, _
ByVal lInt As Long, _
ByVal lInt As Long, _
ByVal lInt As Long, _
ByVal hdc As Long, _
ByVal lInt As Long, _
ByVal lInt As Long, _
ByVal lInt As Long, _
ByVal lInt As Long, _
ByVal BLENDFUNCT As Long) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32.dll" ( _
Destination As Any, _
Source As Any, _
ByVal Length As Long)

Private Sub Aplicar()


Dim BF As BLENDFUNCTION, lBF As Long

With BF
 .BlendOp = 0
 .BlendFlags = 0
 .SourceConstantAlpha = 75
 .AlphaFormat = 0
End With

RtlMoveMemory lBF, BF, 4
' Copiaal picture2 y mezcla la imagen con la transparencia
GdiAlphaBlend Picture2.hdc, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, _
Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, lBF

Picture2.Refresh
End Sub

Private Sub Command1_Click()
Command1.Enabled = False
Command2.Enabled = True
Call Aplicar
End Sub

Private Sub Command2_Click()
Dim hdc_Pic As Long
 
MsgBox "El codigo que busco va acá !!!!!!!!!!!!!!!!!!!!!!!", vbInformation
 
hdc_Pic = GetWindowDC(Picture2.hwnd)

BitBlt Picture3.hdc, 0, 0, Picture3.ScaleWidth, _
Picture3.ScaleHeight, hdc_Pic, 0, 0, vbSrcCopy

'*****************************************************************
'*****************************************************************
'*****************************************************************
'*****************************************************************
'*****************************************************************

' Acá Falta el Código que busco

' .....para poder guardar la imagen
' SavePicture Picture3.Picture, "c:\a.bmp"


'*****************************************************************
'*****************************************************************
'*****************************************************************
'*****************************************************************
'*****************************************************************
'*****************************************************************

' Esto no sirve !!!!
'Picture3.Picture = Picture3.Image



End Sub

Private Sub Form_Load()


Picture1.Picture = LoadPicture("C:\WINDOWS\Web\Wallpaper\felicidad.bmp")
Picture2.Picture = LoadPicture("C:\WINDOWS\Web\Wallpaper\Energía.jpg")
Picture2.ScaleMode = 3
Picture1.ScaleMode = 3
Picture3.ScaleMode = 3
Picture2.AutoRedraw = True
Command2.Enabled = False

Command1.Caption = "Copiar con transparencia en pic 2"
Command2.Caption = "convertir a bitmap"

End Sub

Thank.

hola mira si entiendo bien en el apiguide hay algo de lo que buscas el apis seria OleCreatePictureIndirect, no se bien con que fin es pero si picture3 no es un picturebox y solo tenes el hwnd para tomar las medidas lo podes hacer con GetWindowRect , en cuantoa como tomas el hdc , vos usas
GetWindowDC este capura los bordes osea si es un formulario te captura los bordes y con GetDc solo la parte central, una cosa que la otra ves nos avia quedadola duda si avia que descargar el cuando haciamos GetDc, bueno con GetDc no hace falta pero con GetWindowDC si hay que usar ReleaseDC sino se incrementa la memoria

Código:

Option Explicit
Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Private Type PALETTEENTRY
 peRed As Byte
 peGreen As Byte
 peBlue As Byte
 peFlags As Byte
End Type
Private Type LOGPALETTE
 palVersion As Integer
 palNumEntries As Integer
 palPalEntry(255) As PALETTEENTRY ' Enough for 256 colors
End Type
Private Type GUID
 Data1 As Long
 Data2 As Integer
 Data3 As Integer
 Data4(7) As Byte
End Type
Private Type PicBmp
 Size As Long
 Type As Long
 hBmp As Long
 hPal As Long
 Reserved As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GdiAlphaBlend Lib "gdi32.dll" (ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal hdc As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal lInt As Long, ByVal BLENDFUNCT As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Sub RtlMoveMemory Lib "kernel32.dll" (Destination As Any, Source As Any, ByVal Length As Long)

Private Type BLENDFUNCTION
 BlendOp As Byte
 BlendFlags As Byte
 SourceConstantAlpha As Byte
 AlphaFormat As Byte
End Type



Private Sub Aplicar()
 Dim BF As BLENDFUNCTION, lBF As Long
 With BF
 .BlendOp = 0
 .BlendFlags = 0
 .SourceConstantAlpha = 75
 .AlphaFormat = 0
 End With
 
 RtlMoveMemory lBF, BF, 4
 ' Copiaal picture2 y mezcla la imagen con la transparencia
 GdiAlphaBlend Picture2.hdc, 0, 0, Picture2.ScaleWidth, Picture2.ScaleHeight, Picture1.hdc, 0, 0, Picture1.ScaleWidth, Picture1.ScaleHeight, lBF

 Picture2.Refresh
End Sub

Private Sub Command1_Click()
 Command1.Enabled = False
 Command2.Enabled = True
 Call Aplicar
End Sub

Private Sub Command2_Click()
 Dim hdc_Pic As Long
 
'hdc_Pic = GetDC(Picture2.hwnd) 'Captura el contenido
 
hdc_Pic = GetWindowDC(Picture2.hwnd) 'Captura el contendido y el borde
'Picture3.AutoRedraw = True
BitBlt Picture3.hdc, 0, 0, Picture3.ScaleWidth, Picture3.ScaleHeight, hdc_Pic, 0, 0, vbSrcCopy
'Picture3.Refresh
SavePicture hDCToPicture(Picture3.hdc, 0, 0, Picture3.Width / Screen.TwipsPerPixelX, Picture3.Height / Screen.TwipsPerPixelY), "C:\Imagen.bmp"
 
End Sub

Private Sub Form_Load()
 
 
 Picture1.Picture = LoadPicture("C:\WINDOWS\Web\Wallpaper\felicidad.bmp")
 Picture2.Picture = LoadPicture("C:\WINDOWS\Web\Wallpaper\Energía.jpg")
 Picture2.ScaleMode = 3
 Picture1.ScaleMode = 3
 Picture3.ScaleMode = 3
 Picture2.AutoRedraw = True
 Command2.Enabled = False
 
 Command1.Caption = "Copiar con transparencia en pic 2"
 Command2.Caption = "convertir a bitmap"
 
End Sub

Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
 Dim R As Long, Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID
 
 With IID_IDispatch
 .Data1 = &H20400
 .Data4(0) = &HC0
 .Data4(7) = &H46
 End With
 
 With Pic
 .Size = Len(Pic)
 .Type = vbPicTypeBitmap
 .hBmp = hBmp
 .hPal = hPal
 End With
 
 R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
 
 Set CreateBitmapPicture = IPic
End Function
Function hDCToPicture(ByVal hDCSrc As Long, ByVal LeftSrc As Long, ByVal TopSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long) As Picture
 Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, R As Long
 Dim hPal As Long, hPalPrev As Long, RasterCapsScrn As Long, HasPaletteScrn As Long
 Dim PaletteSizeScrn As Long, LogPal As LOGPALETTE
 
 hDCMemory = CreateCompatibleDC(hDCSrc)
 
 hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
 
 hBmpPrev = SelectObject(hDCMemory, hBmp)

 RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS) ' Raster
 
 HasPaletteScrn = RasterCapsScrn And RC_PALETTE
 
 PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE) ' Size of
 If HasPaletteScrn And (PaletteSizeScrn = 256) Then
 
 LogPal.palVersion = &H300
 
 LogPal.palNumEntries = 256
 
 R = GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
 
 hPal = CreatePalette(LogPal)
 
 hPalPrev = SelectPalette(hDCMemory, hPal, 0)
 
 R = RealizePalette(hDCMemory)
 End If
 
 R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)
 
 hBmp = SelectObject(hDCMemory, hBmpPrev)
 If HasPaletteScrn And (PaletteSizeScrn = 256) Then
 
 hPal = SelectPalette(hDCMemory, hPalPrev, 0)
 End If
 
 R = DeleteDC(hDCMemory)
 Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function

ahora este codigo ami no me sirve para poder pasar directamente a un imagelist porque las imagenes se vuelven negras la unica forma es si las vuelco a un picture o si las guardo ,pero directamente no funciona ,si alguien save poque que chifle

Saludos

Hola Leandro funciona de 10. .. la verdad por mas de que me hubiese puesto 20 horas, me parece que no lo sacaba mas

Sobre si es en un picture y no en cualquier hdc, si en este caso es sobre un picturebox.

Con lo de RelaseDC buen dato, siempre me había quedado la duda, y es dificil darte cuenta si va incrementando memoria, ya que te podés dar cuenta si hacés muchas llamadas a la función, por que en este caso no se nota el incremento de recursos

Con lo de tu última pregunta, no tengo idea pero si me entero te digo

saludos