Cortar una imagen

[rojobe]

Hola a todos y gracias de antemano por su ayuda.

Sucede que necesito cortar una imagen.
Específicamente una parte de un picturebox o un image.
He logrado copiarlas de un objeto a otro usando el clipboard, pero no la puedo cortar.
Si es necesaria alguna información mas, o las pruebas que he hecho, pero que no logran lo que necesito, las subo inmediatamente.
Desde ya muchas gracias.
Saludos.

[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.

[pkj]

He encontrado este código que te muestra como cortar o copiar parte de una imagen de un picturebox. Quizá te ayude.

http://www.recursosvisualbasic.com.a...tar-imagen.htm

Yo he separado esta parte y he creado una sub como ejemplo.
Esta sub, en teoria (no la he probado por separado), copia un trozo de un picture a otro:

Código vb:

Sub CopiarPicToPic(PicOrigen As PictureBox, PicDestino As PictureBox, ByVal x1 As Single, ByVal x2 As Single, ByVal y1 As Single, ByVal y2 As Single)
        
        PicDestino.Cls
        DoEvents
        
        PicDestino.Width = Abs(x1 - x2)
        PicDestino.Height = Abs(y1 - y2)
    
        If x1 < x2 And y1 < y2 Then
            DoEvents
            
            PicDestino.PaintPicture PicOrigen.Picture, 0, 0, _
                                                 Abs(x2 - x1), Abs(y2 - y1), _
                                                 x1, y1, _
                                                 Abs(x2 - x1), Abs(y2 - y1)
                                                   
        ElseIf x1 > x2 And y1 > y2 Then
            DoEvents
            PicDestino.PaintPicture PicOrigen.Picture, 0, 0, _
                                                 Abs(x1 - x2), Abs(y1 - y2), _
                                                 x2, y2, _
                                                 Abs(x1 - x2), Abs(y1 - y2)
 
        
        ElseIf x1 > x2 And y1 < y2 Then
 
            DoEvents
            
            PicDestino.PaintPicture PicOrigen.Picture, 0, 0, _
                                                x1 + x2, y1 + y2, _
                                                x2, y1, _
                                                x1 + x2, y1 + y2
            
        ElseIf x1 < x2 And y1 > y2 Then
            DoEvents
            PicDestino.PaintPicture PicOrigen.Picture, 0, 0, _
                                                x1 + x2, y1 + y2, _
                                                x1, y2, _
                                                x1 + x2, y1 + y2
        End If
        DoEvents
            
End Sub
 

Yo me la voy a guardar por ahí por si acaso...

Saludos

[rojobe]

EXCELENTE pkj, muchas gracias por tu tiempo y por tu precisa respuesta.
Si no lo resuelvo con ese ejemplo al cual haces referencia, ya puedo colgar los botines y dedicarme a la agricultura.
Es precisamente lo que necesitaba.

Saludos cordiales y muchísimas gracias nuevamente.