per Gugu

mi hai fatto lavorare troppo oggi

cmq hio fatto qualcosa
fatti un form con 2 picturebox
- pic1 e pic2 dove pic1 è la sorgente
- una matrice txtX (0 to 1)
- una matrice txtY (o to 1)
- un pulsante salva crea e reset

codice:
'in un form

Option Explicit
Dim X As Long
Dim Y As Long
Private Sub cmdCrea_Click()
   Me.Width = Me.Width + ((CLng(txtX(1).Text) - CLng(txtX(0).Text)) * Screen.TwipsPerPixelX) + 100
   Dimensiona_Picture pic2, (CLng(txtX(1).Text) - CLng(txtX(0).Text)), (CLng(txtY(1).Text) - CLng(txtY(0).Text))
   pic2.Refresh
   Set pic2.Picture = recuperaRGB(GetDC(pic1.hwnd), CLng(txtX(0)), _
      CLng(txtY(0)), CLng(txtX(1)), CLng(txtY(1)))
End Sub

Private Sub cmdReset_Click()
   txtX(0) = ""
   txtX(1) = ""
   txtY(0) = ""
   txtY(1) = ""
   pic2.Picture = Nothing
   pic2.Width = 10
   pic2.Height = 10
   pic2.Refresh
   Me.Width = X
   Me.Height = Y
End Sub

Private Sub cmdSalva_Click()
   cd1.ShowSave
   SavePicture pic2.Picture, cd1.FileName
End Sub

Private Sub Form_Load()
   X = Me.Width
   Y = Me.Height
   cd1.Filter = "file immagine |*.bmp|(*.bmp)"
   MaxX = Me.pic1.Width / Screen.TwipsPerPixelX
   MaxY = Me.pic1.Height / Screen.TwipsPerPixelY
End Sub

Private Sub txtX_LostFocus(Index As Integer)
   If Val(txtX(Index)) > MaxX Then
      txtX(Index).Text = ""
      txtX(Index).SetFocus
   End If
End Sub

Private Sub txtY_LostFocus(Index As Integer)
   If Val(txtY(Index)) > MaxY Then
      txtY(Index).Text = ""
      txtY(Index).SetFocus
   End If
End Sub

' in un modulo

Option Explicit
Public MaxX As Long
Public MaxY As Long

Const RC_PALETTE As Long = &H100
Const SIZEPALETTE As Long = 104
Const RASTERCAPS As Long = 38
Public Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
Public Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY ' per 256 colori
End Type
Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type
Public Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type
Public Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal iCapabilitiy As Long) As Long
Public Declare Function GetSystemPaletteEntries Lib "gdi32" (ByVal hdc As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, lpPaletteEntries As PALETTEENTRY) As Long
Public Declare Function CreatePalette Lib "gdi32" (lpLogPalette As LOGPALETTE) As Long
Public Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Public Declare Function RealizePalette Lib "gdi32" (ByVal hdc 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 DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Function CreaBmpPicture(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

    'crea la picture
    R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    'Return nuova picture
    Set CreaBmpPicture = IPic
End Function
Function recuperaRGB(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)
    'crea un'immagine compatibile bitmap
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)

    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE ' Palette
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)

    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

    'copia il riquadro selezionato
    R = BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, vbSrcCopy)

    'ripristina immagine
    hBmp = SelectObject(hDCMemory, hBmpPrev)

    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        'scegli la palette
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If

    'cancella la memoria
    R = DeleteDC(hDCMemory)
    Set recuperaRGB = CreaBmpPicture(hBmp, hPal)
End Function

Function Dimensiona_Picture(ByVal picDest As PictureBox, _
   ByVal dimX As Long, ByVal dimY As Long) As Boolean
   picDest.Width = dimX * Screen.TwipsPerPixelX
   picDest.Height = dimY * Screen.TwipsPerPixelY
   Dimensiona_Picture = True
End Function