userform image copy to worksheet cell.

[asyamonique]

Sheets("prnt").Range("D8") = Me.TextBox20.Value

Good Day,

is it possible to alter the code given above like the code below.

Sheets("prnt").Range("D8") = Me.image1.picture

Thanks.

 

[BrianB]

METHOD 1
Don't know about a direct method, but you could access the original picture file and insert that into the sheet.

METHOD 2
Resize a screenshot of the form containing the picture. Not an exact science. You will see some calculations are as a result of trial & error. The problem is converting the various dimension units used in the properties.

'=====================================================================
'- USERFORM CODE: "PRINT SCREEN" FORM TO CLIPBOARD.PASTE TO WORKSHEET
'- RESIZE TO THE SAME SIZE AS THE FORM IMAGE CONTROL
'- Forms use worksheet co-ordinates.Their controls use form co-ordinates.
'- Brian Baulsom October 2008
'=====================================================================
'- API used to to print screen (mimics keystrokes). Cannot use SendKeys.
Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal _
    bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Const VK_KEYUP = &H2
Const VK_SNAPSHOT = &H2C
Const VK_MENU = &H12
 
'=====================================================================
'- FORM BUTTON CLICK
'=====================================================================
Private Sub CommandButton1_Click()
    Dim Pnumber As Integer  ' count of next picture in series
    Dim MyPicture As Object
    Dim FormCaptionHeight As Double
    Dim MyCell As Range     ' final picture position on sheet
    '-----------------------------------------------------------------
    '- next worksheet picture in series
    Pnumber = ActiveSheet.Pictures.Count + 1
    '-----------------------------------------------------------------
    '- COPY FORM PICTURE TO THE CLIPBOARD & PASTE
    Print_Screen    ' SUBROUTINE BELOW
    '=================================================================
    '- FORMAT THE PICTURE
    '=================================================================
    ' HEIGHT OF THE FORM CAPTION - not included in Image1.Top
    FormCaptionHeight = 16      ' OBTAINED BY TRIAL & ERROR
    '------------------------------------------------------------------
    '- CROP SURROUNDING FORM IMAGE
    Set MyPicture = ActiveSheet.Pictures(Pnumber)
    With MyPicture
        .ShapeRange.PictureFormat.CropTop = Me.Image1.Top + FormCaptionHeight
        .ShapeRange.PictureFormat.CropLeft = Me.Image1.Left
        '-
        .ShapeRange.PictureFormat.CropRight _
            = Me.Width - Me.Image1.Left - Me.Image1.Width
        .ShapeRange.PictureFormat.CropBottom _
            = Me.Height - Me.Image1.Top - Me.Image1.Height - FormCaptionHeight
    End With
    '-----------------------------------------------------------------
    '- NAME & POSITION THE PICTURE ON THE SHEET
    Set MyCell = ActiveSheet.Range("A1")
    '-
    With MyPicture
        .Top = MyCell.Top
        .Left = MyCell.Left
        .Name = "MyPicture " & CStr(Pnumber)
    End With
    '----------------------------------------------------------------
    '- RESIZE THE CELL
    With MyCell
        .RowHeight = MyPicture.Height
        .ColumnWidth = MyPicture.Width * 20 / 95 ' TRIAL & ERROR
    End With
    '----------------------------------------------------------------
    Beep
End Sub
'======== END OF MAIN ROUTINE ========================================
 
'=====================================================================
'- SUBROUTINE : PRINT SCREEN & PASTE INTO THE WORKSHEET
'- events and SendKeys work slowly, so need lots of delays in the code
'=====================================================================
Private Sub Print_Screen()
    '- API print screen
    keybd_event VK_MENU, 0, 0, 0        ' Alt key down
    DoEvents
    keybd_event VK_SNAPSHOT, 0, 0, 0    ' PrintScreen key down
    DoEvents
    keybd_event VK_SNAPSHOT, 0, VK_KEYUP, 0
    DoEvents
    keybd_event VK_MENU, 0, VK_KEYUP, 0
    DoEvents
    '---------------------------------------------------------------
    '- paste picture to worksheet
    ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
    DoEvents
    Application.Wait Now + TimeValue("00:00:01")    ' WAIT 1 SECOND
End Sub
'=====================================================================

 

[asyamonique]

thanks for your help