Cortar una imagen

[rojobe]

Hola nuevamente, bueno, veo que no hay ninguna pista, entonces "ampliaré mi declaración"
Esto es lo que he hecho hasta ahora, por supuesto no me funciona.

Código:

Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, _
                ByVal hMem As Long) As Long
                         
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, _
                ByVal imageType As Long, ByVal newWidth As Long, _
                ByVal newHeight As Long, ByVal lFlags As Long) As Long
                
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long


Private Sub cmdCortar_Click()
On Error Resume Next
Dim hNew As Long
    
    'creo una copia exacta de la imagen
    hNew = CopyImage(Image1.Picture, IMAGE_BITMAP, 160, 125, LR_COPYRETURNORG)
    'abro clipboard
    OpenClipboard Me.hwnd
    'borro clipboard
    EmptyClipboard
    'el picture en el clipboard
    SetClipboardData CF_BITMAP, hNew

    'Tener en cuenta que no tengo que llamar a DeleteObject (hNew)
    'De ahora en adelante, el portapapeles se encarga del mapa de bits
    
    'cierro clipboard
    CloseClipboard

    'traigo el picture desde el clipboard   funciona bien
    Image2.Picture = Clipboard.GetData(vbCFBitmap)
    'directamente desde un copyimage no funciona

'este ok
  With Picture1
   'o a un pitruebox 
   .Picture = Clipboard.GetData(vbCFBitmap)
    .PaintPicture .Image, t, l, .Width, .Height, , , .Width - t, .Height + l
    
    Image2.Picture = .Picture
    
  End With

Exit Sub
'esto es lo que he querido hacer, modificando los valores de un paintpicture
'a un picturebox o también directamente al form, pero no me funciona
'los valores t y l se modifican al mover la foto bajo un cuadrado (shape)

'orig     Form1.PaintPicture Image1.Picture, 0, 0, 1980, 1890, Image1.Top + t, Image1.Left + l, 1890, 1890
 X2 = 15730
 Y2 = 15150
 h2 = Image1.Height
 w2 = Image1.Width
 Form1.PaintPicture Image1.Picture, 0, 0, 1980, 1890, X2, Y2, h2, w2
 
 
'orig P    icture1.PaintPicture Image1.Picture, 0, 0, 1980, 1890, Image1.Top + t, Image1.Left + l, 1890, 1890
 Picture1.PaintPicture Image1.Picture, 0, 0, 1980, 1890, X2, Y2, h2, w2
 
 
 Image2.Picture = Picture1.Image
 Image2.Refresh
 
 'Picture1.Picture = Form1.Picture
 
End Sub

Private Sub cmdFlecha_Click(Index As Integer)
Dim t As Integer, l As Integer
On Error Resume Next

'en realidad el cuadrado queda quieto y la foto se mueve debajo de él
   Select Case Index
     Case 0
       Image1.Top = Image1.Top + 100
       t = t + 100
     Case 1
       Image1.Top = Image1.Top - 100
       t = t - 100
     Case 2
       Image1.Left = Image1.Left + 100
       l = l + 100
     Case 3
       Image1.Left = Image1.Left - 100
       l = l - 100
   End Select
 

End Sub

Private Sub Form_Load()
On Error Resume Next
Dim foto As String
'D1 es un commondialog

            D1.CancelError = True
            D1.ShowOpen
            If Err.Number = 0 Then
              Err.Clear
              foto = D1.FileName
              'P1.Picture = LoadPicture(foto)
                            
              Image1.Picture = LoadPicture(foto)
              
            End If
              
End Sub

Bueno, mil disculpas, como ven, todo muy desprolijo, pero es que ya he hecho mil pruebas, tengo tres formularios mas, uno usando

Código:

Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, _
                ByVal imageType As Long, ByVal newWidth As Long, _
                ByVal newHeight As Long, ByVal lFlags As Long) As Long

tampoco lo logro, otro usando (tratando de usar)

Código:

Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SetRectEmpty Lib "user32" (lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function IsRectEmpty Lib "user32" (lpRect As RECT) As Long
Private Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
Private Declare Function GetRgnBox Lib "gdi32" (ByVal hRgn As Long, lpRect As RECT) As Long

para tratar de cortar un rectángulo a la foto, pero tampoco lo logro.

Un tercero, tratando de copiar unos bits menos usando:

Código:

Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long

pero tampoco doy en el clavo...

Bueno, hasta aquí, si es necesario que les muestre lo que he hecho en cada caso, a su disposición.

Saludos cordiales.