codice:
'* x CaptureDesktop
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
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
Dim immagine As String
Dim Ximmagine As Long, Yimmagine As Long
Dim ImmagineModificata As Picture
Dim thePicture As StdPicture
Private Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long
Private Sub Apri_Click()
Dim x As Long
Dim y As Long
'carico il file bitmap nella picuturebox picture1
'
CommonDl.ShowOpen
immagine = CommonDl.FileName
Picture1.Picture = LoadPicture(immagine)
'leggo le dimensioni in pixel della bitmap caricata
'
Set thePicture = Picture1.Picture
Ximmagine = Round(Picture1.ScaleX(thePicture.Width, vbHimetric, vbPixels))
Yimmagine = Round(Picture1.ScaleY(thePicture.Height, vbHimetric, vbPixels))
'modifico la bitmap presente nel picture1.hdc rendendola ad esempio tutta nera
'
Ximmagine = Ximmagine - 1
Yimmagine = Yimmagine - 1
For x = 0 To Ximmagine
For y = 0 To Yimmagine
SetPixel Picture1.hdc, x, y, RGB(0, 0, 0)
Next y
Next x
'Salvo la picture1.hdc modificata nell'oggetto picture ImmagineModificata.
'
Set ImmagineModificata = CaptureImageFromPicturebox(Picture1)
'
'attivo salva
'
Salva.Enabled = True
End Sub
Private Sub Form_Load()
End Sub
Private Sub Salva_Click()
CommonDl.ShowSave
immagine = CommonDl.FileName
SavePicture ImmagineModificata, immagine
End Sub
'
Function CaptureImageFromPicturebox(theBox As PictureBox) As Picture
'***************************************
'********
' Restituisce l'immagine catturata da una picturebox
'***************************************
'********
Dim hImageWnd As Long
Dim hImageDC As Long
Dim rcImage As RECT
Dim x As Long, y As Long
Dim w As Long, h As Long
Dim hDCMemory As Long
Dim hBitmap As Long
Dim hBitmapPrev As Long
Dim SysPalE As Long
Dim hPalette As Long
Dim hPreviousPalette As Long
Dim RasterCaps As Long
Dim HasPalette As Long
Dim PaletteSize As Long
Dim LogPal As LOGPALETTE
hImageWnd = theBox.hwnd
hImageDC = theBox.hdc
GetWindowRect hImageWnd, rcImage '>>>>>>PENSO CHE IL PROBLEMA SIA QUI
x = 0
y = 0
w = rcImage.Right - rcImage.Left ' calcola larghezza e altezza della cattura
h = rcImage.Bottom - rcImage.Top
hDCMemory = CreateCompatibleDC(hImageDC) ' crea un DeviceContext compatibile
hBitmap = CreateCompatibleBitmap(hImageDC, w, h) ' crea una bitmap compatibile
hBitmapPrev = SelectObject(hDCMemory, hBitmap) ' ??? seleziona la bitmap dal device context
RasterCaps = GetDeviceCaps(hImageDC, RasterCaps) ' Ottiene Raster capabilities
HasPalette = RasterCaps And RC_PALETTE ' la bitmap usa PALETTE ?
PaletteSize = GetDeviceCaps(hImageDC, SIZEPALETTE) ' ottiene le dimensioni della PALETTE
If HasPalette And (PaletteSize = 256) Then
LogPal.palVersion = &H300 ' imposta versione palette
LogPal.palNumEntries = 256 ' numero delle palette
SysPalE = GetSystemPaletteEntries(hImageDC, 0, 256, LogPal.palPalEntry(0)) 'system palette entries
hPalette = CreatePalette(LogPal) ' crea la palette
hPreviousPalette = SelectPalette(hDCMemory, hPalette, 0) ' seleziona palette
SysPalE = RealizePalette(hDCMemory) ' relaizza la palette
End If
'Copia l'immagine di origine nel device Context
SysPalE = BitBlt(hDCMemory, 0, 0, w, h, hImageDC, x, y, vbSrcCopy)
hBitmap = SelectObject(hDCMemory, hBitmapPrev) ' ripristina bitmap precedente
' Seleziona la palette
If HasPalette And (PaletteSize = 256) Then hPalette = SelectPalette(hDCMemory, hPreviousPalette, 0)
SysPalE = DeleteDC(hDCMemory) ' elimina device context
Set CaptureImageFromPicturebox = CreateBitmapPicture(hBitmap, hPalette)
End Function
'
Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Picture
Dim lRetVal As Long
Dim pic As PicBmp
Dim IPic As IPicture
Dim IID_IDispatch As GUID
'Fill GUID info
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
'Fill picture info
With pic
.Size = Len(pic) ' dimensioni della struttura
.Type = vbPicTypeBitmap ' tipo di Picture (bitmap)
.hBmp = hBmp ' Handle della bitmap
.hPal = hPal ' Handle della palette
End With
OleCreatePictureIndirect pic, IID_IDispatch, 1, IPic ' Crea la picture
Set CreateBitmapPicture = IPic ' Restituisce la nuova picture
End Function
Rispondi quotando
