Retrieve Image from Sheet to userform??

sureshtrb · Feb 15, 2015

Attached a sample code
need help in retrieving the images from worksheet to Userform
https://www.dropbox.com/s/nvghhjp8o83jwt0/Retrieve iMAGE.xlsm?dl=0

Please help
Trying for more than a week time.

sureshtrb · Feb 16, 2015

Code:

With MultiPage1.Pages(1)       Dim pic1 As Image
        Set pic1 = .Controls.Add("Forms.image.1")
            pic1.Name = "image1"
            pic1.Width = s
            pic1.Height = s
            pic1.Top = t
            pic1.Left = l
Application.ScreenUpdating = True
End With
'Photo -1
'=====================================================================================
'???
'Here is the place I Need Code to copy the Picture (Shapes) from Worksheet to Userform
'=====================================================================================
        
             'NEED
                    'HELP
                            'HERE
                                    'PLEASE

Domenic · Feb 16, 2015

Try...

'Declare the variables Dim wsSource As Worksheet Dim oPic As Picture Dim oImage As Image Dim oChart As Chart Dim sTempFilename As String Dim t As Double Dim s As Double Application.ScreenUpdating = False 'Assign values to variables t and s 't = ??? 's = ??? 'Assign a variable a temporary filename for the exported image sTempFilename = Environ("temp") & "\temp_" & Format(Now, "yy-mm-dd_hh-mm-ss") & ".jpg" 'Assign to an object variable the sheet containing the picture (change the sheet name accordingly) Set wsSource = ActiveWorkbook.Worksheets("Sheet1") 'Assign to an object variable the picture (change the name of the picture accordingly) Set oPic = wsSource.Pictures("Picture 1") 'Add and set the properties for an image control on the second page of the MultiPage control Set oImage = Me.MultiPage1.Pages(1).Controls.Add("Forms.Image.1") With oImage .Name = "image1" .Left = l .Top = t .Width = s .Height = s End With 'Create an empty chart With wsSource.ChartObjects.Add(Left:=1, Top:=1, Width:=oPic.Width, Height:=oPic.Height) With .Chart 'Copy the picture oPic.Copy 'Paste the picture in the chart .Paste 'Export the chart .Export sTempFilename End With 'Load the exported file onto the image control oImage.Picture = LoadPicture(sTempFilename) 'Delete the chart .Delete 'Delete the temporary file Kill sTempFilename End With Application.ScreenUpdating = False

Hope this helps!

sureshtrb · Feb 16, 2015

Thanks but still could not able to...
anywhere i have done mistake???
https://www.dropbox.com/s/ovhdmcij40vf93h/Retrieve iMAGE-rev1.xlsm?dl=0

Domenic · Feb 16, 2015

Can you post the code that you tried?

sureshtrb · Feb 16, 2015

in the link provided in my earlier reply

Domenic · Feb 16, 2015

Sorry, but I don't download workbooks. I should have mentioned it in my original reply.

sureshtrb · Feb 17, 2015

Sorry for delay in responding.
Userform Code:

Code:

Private Sub CBSearchCatagory_AfterUpdate()


Me.CBSearchResult.Visible = True
If Me.CBSearchCatagory.Value = "Search by FNO" Then
Dim v, e
Me.CBSearchResult.Clear
With Sheets("Data").RANGE("A3:A200000")
    v = .Value
End With
With CreateObject("scripting.dictionary")
    .comparemode = 1
    For Each e In v
        If Not .exists(e) Then .Add e, Nothing
    Next
    If .Count Then Me.CBSearchResult.List = Application.Transpose(.keys)
End With
End If
End Sub
Private Sub CBSearchCatagory_DropButt*******()
Me.CBSearchResult.Visible = True
End Sub
Private Sub CBSearchResult_Change()
Dim FoundCell As RANGE
  If Me.CBSearchResult.Value = "" Then
        Me.FNO.Enabled = True
        
            If Me.CBSearchCatagory.Value = "Search by FNO" Or _
                Me.CBSearchCatagory.Value = "Search by IDNO" Or _
                Me.CBSearchCatagory.Value = "Search by TAGNO" Or _
                Me.CBSearchCatagory.Value = "Search by CUSTOMER" Or _
                Me.CBSearchCatagory.Value = "Search by VMANUF" Or _
                Me.CBSearchCatagory.Value = "Search by VSDJOBNO" Or _
                Me.CBSearchCatagory.Value = "Search by SIZE" And _
                Me.CBSearchResult = "" Then Exit Sub
                  Me.CBSearchResult.Visible = True
            End If
               If Me.CBSearchResult.ListIndex = 0 Then
                        Beep
                            Exit Sub
                End If
                Me.FNO.Value = Me.CBSearchResult.Value
            If Me.CBSearchCatagory.Value = "Search by FNO" And Me.FNO.Value = Me.CBSearchResult Then
                With CBSearchResult
                Application.ScreenUpdating = False
                        Set FoundCell = Cells.Find(What:=Me.CBSearchResult.Value, _
                                                            After:=Cells(1), _
                                                            LookIn:=xlValues, _
                                                            lookat:=xlWhole, _
                                                            SearchOrder:=xlByRows, _
                                                            SearchDirection:=xlPrevious, _
                                                            MatchCase:=False)
            If Not FoundCell Is Nothing Then
            Beep
    
Me.IDNO.Value = FoundCell.Offset(0, 1).Value
Me.TAGNO.Value = FoundCell.Offset(0, 2).Value
Me.CUSTOMER.Value = FoundCell.Offset(0, 3).Value
Me.VTYPE.Value = FoundCell.Offset(0, 4).Value
Me.JOBNO.Value = FoundCell.Offset(0, 5).Value
Me.RECDDATE.Value = FoundCell.Offset(0, 6).Value
Me.SIZE.Value = FoundCell.Offset(0, 7).Value
Me.UNIT.Value = FoundCell.Offset(0, 8).Value
Me.CLASS.Value = FoundCell.Offset(0, 9).Value
Me.MODL.Value = FoundCell.Offset(0, 10).Value
Me.VMANUF.Value = FoundCell.Offset(0, 11).Value
Me.LCLASS.Value = FoundCell.Offset(0, 12).Value
Me.CV.Value = FoundCell.Offset(0, 13).Value
Me.ATYPE.Value = FoundCell.Offset(0, 14).Value
Me.AMANUF.Value = FoundCell.Offset(0, 15).Value
Me.SERIALNO.Value = FoundCell.Offset(0, 16).Value
Me.TRAVEL.Value = FoundCell.Offset(0, 17).Value
Me.SUP.Value = FoundCell.Offset(0, 18).Value
Me.SUNIT.Value = FoundCell.Offset(0, 19).Value
Me.RANGE.Value = FoundCell.Offset(0, 20).Value
Me.ACTION.Value = FoundCell.Offset(0, 21).Value
Me.LOC.Value = FoundCell.Offset(0, 22).Value


'Picture1-Label Copy to userform
Dim s, l, t, h As Long
s = 100
t = 50
l = 24
h = 24


If FoundCell.Offset(0, 24).Value > "" Then
MultiPage1.Pages.Add
Dim lblCaption1 As MSForms.Label
            On Error GoTo Err_Clr
            Set lblCaption1 = MultiPage1.Pages(1).Controls.Add("Forms.label.1", "myLabelCaption")
        With lblCaption1
        .Font.Name = "Arial Black"
        .Font.SIZE = 14
        .TextAlign = fmTextAlignCenter
        .Width = s
        .Height = h
        .Left = l
        .Top = t + s
        .ForeColor = vbWhite
        .BackColor = &H800000
        .WordWrap = False
        .AutoSize = False
        .Enabled = True
        .Caption = FoundCell.Offset(0, 24).Value
        Me.Repaint
        End With
        
'With MultiPage1.Pages(1)
 '      Dim pic1 As Image
  '      Set pic1 = .Controls.Add("Forms.image.1")
   '         pic1.Name = "image1"
    '        pic1.Width = s
     '       pic1.Height = s
      '      pic1.Top = t
       '     pic1.Left = l
'Application.ScreenUpdating = True
'End With


'Photo -1
'=====================================================================================
'???
'Here is the place I Need Code to copy the Picture (Shapes) from Worksheet to Userform
'=====================================================================================
        
             'NEED
                    'HELP
                            'HERE
                                    'PLEASE
        
'Declare the variables
Dim wsSource As Worksheet
Dim oPic As Picture
Dim oImage As Image
Dim oChart As Chart
Dim sTempFilename As String
'Dim t As Double
'Dim s As Double


Application.ScreenUpdating = False


'Assign values to variables t and s
't = ???
's = ???


'Assign a variable a temporary filename for the exported image
sTempFilename = Environ("temp") & "\temp_" & Format(Now, "yy-mm-dd_hh-mm-ss") & ".jpg"


'Assign to an object variable the sheet containing the picture (change the sheet name accordingly)
Set wsSource = ActiveWorkbook.Worksheets("Data")


'Assign to an object variable the picture (change the name of the picture accordingly)
Set oPic = wsSource.Pictures("Picture 1")


'Add and set the properties for an image control on the second page of the MultiPage control
Set oImage = Me.MultiPage1.Pages(1).Controls.Add("Forms.Image.1")
With oImage
    .Name = "image1"
    .Left = l
    .Top = t
    .Width = s
    .Height = s
End With


'Create an empty chart
With wsSource.ChartObjects.Add(Left:=1, Top:=1, Width:=oPic.Width, Height:=oPic.Height)
    With .Chart
        'Copy the picture
        oPic.Copy
        'Paste the picture in the chart
        .Paste
        'Export the chart
        .Export sTempFilename
    End With
    'Load the exported file onto the image control
    oImage.Picture = LoadPicture(sTempFilename)
    'Delete the chart
    .Delete
    'Delete the temporary file
    Kill sTempFilename
End With


Application.ScreenUpdating = False


        
        
        
        
        
If FoundCell.Offset(0, 26).Value > "" Then
     MultiPage1.Pages().Value = 1
            Dim lblCaption2 As MSForms.Label
  On Error GoTo Err_Clr
            Set lblCaption2 = MultiPage1.Pages(1).Controls.Add("Forms.label.1", "myLabelCaption")
                With lblCaption2
                        .Font.Name = "Arial Black"
                        .Font.SIZE = 14
                        .TextAlign = fmTextAlignCenter
                        .Width = s
                        .Height = h
                        .Left = l + s + l
                        .Top = t + s
                        .ForeColor = vbWhite
                        .BackColor = &H800000
                        .WordWrap = False
                        .AutoSize = False
                        .Enabled = True
                        .Caption = FoundCell.Offset(0, 26).Value
                Me.Repaint
                End With
'With MultiPage1.Pages(1)
 '      Dim pic2 As Image
  '      Set pic2 = .Controls.Add("Forms.image.1")
   '         pic2.Name = "image2"
    '        pic2.Width = s
     '       pic2.Height = s
      '      pic2.Top = t
       '     pic2.Left = l + s + l
'Application.ScreenUpdating = True
'End With








'Photo -2
'=====================================================================================
'???
'Here is the place I Need Code to copy the Picture (Shapes) from Worksheet to Userform
'=====================================================================================
     'NEED
            'HELP
                    'HERE
                            'PLEASE
        
        
        
            End If
        End If
    End If


Err_Clr:
If Err <> 0 Then
    Err.Clear
                Resume Next
            End If
        End With
    End If
End Sub




Private Sub CommandButton1_Click()
Dim nextrow As Integer


Dim dDate As Date


nextrow = WorksheetFunction.CountA(Sheets("Data").RANGE("A:A")) + 1


Sheets("Data").Cells(nextrow, 1) = Me.FNO.Value
Sheets("Data").Cells(nextrow, 2) = Me.IDNO.Value
Sheets("Data").Cells(nextrow, 3) = Me.TAGNO.Value
Sheets("Data").Cells(nextrow, 4) = Me.CUSTOMER.Value
Sheets("Data").Cells(nextrow, 5) = Me.VTYPE.Value
Sheets("Data").Cells(nextrow, 6) = Me.JOBNO.Value
Sheets("Data").Cells(nextrow, 7) = Me.RECDDATE.Value
Sheets("Data").Cells(nextrow, 8) = Me.SIZE.Value
Sheets("Data").Cells(nextrow, 9) = Me.UNIT.Value
Sheets("Data").Cells(nextrow, 10) = Me.CLASS.Value
Sheets("Data").Cells(nextrow, 11) = Me.MODL.Value
Sheets("Data").Cells(nextrow, 12) = Me.VMANUF.Value
Sheets("Data").Cells(nextrow, 13) = Me.LCLASS.Value
Sheets("Data").Cells(nextrow, 14) = Me.CV.Value
Sheets("Data").Cells(nextrow, 15) = Me.ATYPE.Value
Sheets("Data").Cells(nextrow, 16) = Me.AMANUF.Value
Sheets("Data").Cells(nextrow, 17) = Me.SERIALNO.Value
Sheets("Data").Cells(nextrow, 18) = Me.TRAVEL.Value
Sheets("Data").Cells(nextrow, 19) = Me.SUP.Value
Sheets("Data").Cells(nextrow, 20) = Me.SUNIT.Value
Sheets("Data").Cells(nextrow, 21) = Me.RANGE.Value
Sheets("Data").Cells(nextrow, 22) = Me.ACTION.Value
Sheets("Data").Cells(nextrow, 23) = Me.LOC.Value


'Picture 1 Copy to Worksheet
    Dim wsRpt1 As Worksheet
    Dim shpToCopy1 As Shape
    Dim shpPasted1 As Shape
    
        Set wsRpt1 = Worksheets("Data")
        On Error GoTo Err_Clr
    If MultiPage1.Pages(1).image1.Picture Is Nothing Then
       MsgBox "Load the picture to the Userform before copying to worksheet"
        Exit Sub
        End If
    Set shpToCopy1 = Worksheets("ImageCopies1").Shapes(MultiPage1.Pages(1).image1.Name)
    shpToCopy1.Copy
    wsRpt1.Paste
    With wsRpt1
        Set shpPasted1 = .Shapes(MultiPage1.Pages(1).image1.Name)
        With shpPasted1
            .Name = "New Picture1"
            .LockAspectRatio = msoFalse
            .Top = wsRpt1.Cells(nextrow, "X").Top
            .Left = wsRpt1.Cells(nextrow, "X").Left


            .Height = wsRpt1.Cells(nextrow, "X").Height
            .Width = wsRpt1.Cells(nextrow, "X").Width
        End With
    End With
    
'Picture 2 Copy to Worksheet
    Dim wsRpt2 As Worksheet
    Dim shpToCopy2 As Shape
    Dim shpPasted2 As Shape
        Set wsRpt2 = Worksheets("Data")
        On Error GoTo Err_Clr
    If MultiPage1.Pages(1).Image2.Picture Is Nothing Then
        MsgBox "Load the picture to the Userform before copying to worksheet."
        Exit Sub
    End If
    Set shpToCopy2 = Worksheets("ImageCopies2").Shapes(MultiPage1.Pages(1).Image2.Name)
    shpToCopy2.Copy
    wsRpt2.Paste
    With wsRpt2
            Set shpPasted2 = .Shapes(MultiPage1.Pages(1).Image2.Name)
        With shpPasted2
                .Name = "New Picture2"
                .LockAspectRatio = msoFalse
                .Top = wsRpt2.Cells(nextrow, "Z").Top
                .Left = wsRpt2.Cells(nextrow, "Z").Left
                .Height = wsRpt2.Cells(nextrow, "Z").Height
                .Width = wsRpt2.Cells(nextrow, "Z").Width
            With Selection
            End With
        End With
    End With
    Application.ScreenUpdating = True


Err_Clr:
If Err <> 0 Then
Err.Clear
Resume Next
End If


Me.CommandButton2.Visible = False
Me.CommandButton1.Visible = False


End Sub


Private Sub CommandButton2_Click()
Me.MultiPage1.Pages.Add
MultiPage1.Pages(1).Enabled = True
Me.MultiPage1.Value = 1
line323232:
Dim s, l, t, h As Long
s = 100
t = 50
l = 24
h = 24
'Photo -1
With MultiPage1.Pages(1)


Dim wsInit1  As Worksheet
Dim strInitDir1 As String
Dim strPicPathFile1 As String
Dim shpPicture1 As Shape
Dim wsImages1 As Worksheet
    
    Dim pic As Image
    Set pic = .Controls.Add("Forms.image.1")
    With pic
            .Name = "image1"
            .Width = s
            .Height = s
            .Top = t
            .Left = l
        End With
        
Application.ScreenUpdating = False
Set wsInit1 = ActiveSheet
strInitDir1 = CurDir


        With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = strInitDir1
.Filters.Clear
        .AllowMultiSelect = False
        .ButtonName = "Submit"
        .Title = "Select Photo-1"
        .Filters.Add "Image1", "*.gif; *.jpg; *.jpeg; *.gif;*.jpe,*.jfif;*.jpe. 1"
        If .Show = -1 Then
            MultiPage1.Pages(1).image1.PictureSizeMode = fmPictureSizeModeZoom
            MultiPage1.Pages(1).image1.Picture = LoadPicture(.SelectedItems(1))
End If
On Error Resume Next
strPicPathFile1 = .SelectedItems(1)
End With
    
On Error Resume Next
Set wsImages1 = Nothing
Set wsImages1 = Worksheets("ImageCopies1")
On Error GoTo line323232
If wsImages1 Is Nothing Then
Set wsImages1 = Sheets.Add(After:=Sheets(Sheets.Count))
wsImages1.Name = "ImageCopies1"
wsInit1.Activate
Else
On Error Resume Next
wsImages1.Shapes(MultiPage1.Pages(1).image1.Name).Delete
On Error GoTo line323232
End If
     
With wsImages1
Set shpPicture1 = .Shapes.AddPicture _
                        (Filename:=strPicPathFile1, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=1, Top:=1, _
                        Width:=-1, Height:=-1)
With shpPicture1
.Name = MultiPage1.Pages(1).image1.Name
.Width = MultiPage1.Pages(1).image1.Width
End With
End With
    
With MultiPage1.Pages(1).image1
.Picture = LoadPicture(strPicPathFile1)
.Width = wsImages1.Shapes(MultiPage1.Pages(1).image1.Name).Width
.Height = wsImages1.Shapes(MultiPage1.Pages(1).image1.Name).Height
End With
ChDir CurDir
Application.ScreenUpdating = True
    
            Dim lblCaption1 As MSForms.Label
            Set lblCaption1 = MultiPage1.Pages(1).Controls.Add("Forms.label.1", "myLabelCaption")
     
        With lblCaption1
        .Font.Name = "Arial Black"
        .Font.SIZE = 14
        .TextAlign = fmTextAlignCenter
        .Width = s
        .Height = h
        .Left = l
        .Top = t + s
        .ForeColor = vbWhite
        .BackColor = &H800000
        .WordWrap = False
        .AutoSize = False
        .Enabled = True
            Dim myValue As Variant
            myValue = InputBox("Give me some input")
            lblCaption1.Caption = myValue
Dim nextrow As Integer
nextrow = WorksheetFunction.CountA(Sheets("Data").RANGE("A:A")) + 1
Sheets("Data").Cells(nextrow, "Y") = lblCaption1.Caption


            
'Photo -2
line323233:
Dim wsInit2  As Worksheet
Dim strInitDir2 As String
Dim strPicPathFile2 As String
Dim shpPicture2 As Shape
Dim wsImages2 As Worksheet
                Dim msg As String
                Dim ireplly As Integer
                ireplly = MsgBox("Add Another Photo?", vbQuestion + vbOKCancel)
        Select Case ireplly
        Case vbCancel
                Dim iPage As Integer
                Dim i As Long
                iPage = MultiPage1.Pages.Count - 1
        For i = 0 To iPage
                MultiPage1.Pages(i).Enabled = True
        Next
                Me.MultiPage1.Pages(1).Enabled = True
                Me.MultiPage1.Value = 1
                                    CBAddImage1.Visible = False
    Exit Sub
        Case vbOK
                MultiPage1.Pages(1).Enabled = True
                MultiPage1.Pages(1).Enabled = True
                Me.MultiPage1.Value = 1
            With MultiPage1.Pages(1)
        Dim pic2 As Image
        Set pic2 = .Controls.Add("Forms.image.1")
            pic2.Name = "image2"
            pic2.Width = s
            pic2.Height = s
            pic2.Top = t
            pic2.Left = l + s + l
Application.ScreenUpdating = False
Set wsInit2 = ActiveSheet
strInitDir2 = CurDir


        With Application.FileDialog(msoFileDialogFilePicker)
.InitialFileName = strInitDir2
.Filters.Clear
                .AllowMultiSelect = False
                .ButtonName = "Submit"
                .Title = "Select Photo-2"
                .Filters.Add "Image2", "*.gif; *.jpg; *.jpeg; *.gif;*.jpe,*.jfif;*.jpe. 1"
        If .Show = -1 Then
                        MultiPage1.Pages(1).Image2.PictureSizeMode = fmPictureSizeModeZoom
                        MultiPage1.Pages(1).Image2.Picture = LoadPicture(.SelectedItems(1))
End If
        
strPicPathFile2 = .SelectedItems(1)
End With


On Error Resume Next
Set wsImages2 = Nothing
Set wsImages2 = Worksheets("ImageCopies2")
On Error GoTo line323233
If wsImages2 Is Nothing Then
Set wsImages2 = Sheets.Add(After:=Sheets(Sheets.Count))
wsImages2.Name = "ImageCopies2"
wsInit2.Activate
Else
On Error Resume Next
wsImages2.Shapes(MultiPage1.Pages(1).Image2.Name).Delete
On Error GoTo line323233
End If
     
With wsImages2
Set shpPicture2 = .Shapes.AddPicture _
                        (Filename:=strPicPathFile2, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=1, Top:=1, _
                        Width:=-1, Height:=-1)
With shpPicture2
.Name = MultiPage1.Pages(1).Image2.Name
.Width = MultiPage1.Pages(1).Image2.Width
End With
End With
    
With MultiPage1.Pages(1).Image2
.Picture = LoadPicture(strPicPathFile2)
.Width = wsImages2.Shapes(MultiPage1.Pages(1).Image2.Name).Width
.Height = wsImages2.Shapes(MultiPage1.Pages(1).Image2.Name).Height
End With
ChDir CurDir
Application.ScreenUpdating = True


            Dim lblCaption2 As MSForms.Label
            Set lblCaption2 = MultiPage1.Pages(1).Controls.Add("Forms.label.1", "myLabelCaption")
                        lblCaption2.Font.Name = "Arial Black"
                        lblCaption2.Font.SIZE = 14
                        lblCaption2.TextAlign = fmTextAlignCenter
                        lblCaption2.Width = s
                        lblCaption2.Height = h
                        lblCaption2.Left = l + s + l
                        lblCaption2.Top = t + s
                        lblCaption2.ForeColor = vbWhite
                        lblCaption2.BackColor = &H800000
                        lblCaption2.WordWrap = False
                        lblCaption2.AutoSize = False
                        lblCaption2.Enabled = True
                myValue = InputBox("Give me some input")
                lblCaption2.Caption = myValue
Sheets("Data").Cells(nextrow, "AA") = lblCaption2.Caption
                End With
            End Select
        End With
    End With


End Sub




Private Sub UserForm_Initialize()
Me.CBSearchResult.Visible = False
Me.CBSearchCatagory.AddItem "Search by FNO"
'Me.CBSearchCatagory.AddItem "Search by IDNO"
'Me.CBSearchCatagory.AddItem "Search by TAGNO"
'Me.CBSearchCatagory.AddItem "Search by CUSTOMER"
'Me.CBSearchCatagory.AddItem "Search by VMANUF"
'Me.CBSearchCatagory.AddItem "Search by VSDJOBNO"
'Me.CBSearchCatagory.AddItem "Search by SIZE"


Me.UNIT.AddItem "INCH"
Me.UNIT.AddItem "MM"


Me.LOC.AddItem "A"
Me.LOC.AddItem "B"


Me.SUNIT.AddItem "psi"
Me.SUNIT.AddItem "bar"
End Sub
Private Sub cmdClose_Click()
 If MsgBox("Do you Want to Close?", vbOKCancel) = vbCancel Then Exit Sub
Unload Me
Dim ws As Worksheet
Application.DisplayAlerts = False
For Each ws In Worksheets
If ws.Name <> "Data" Then ws.Delete
Next
Application.DisplayAlerts = True


ActiveWorkbook.Save
'Application.Quit
End Sub

Module:

Code:

Sub SHOWFORM_Click()UserForm1.Show
End Sub

Hope its clear

Domenic · Feb 17, 2015

Untested, try...

Private Sub CBSearchResult_Change() Dim FoundCell As Range Application.ScreenUpdating = False If Me.CBSearchResult.Value = "" Then Me.FNO.Enabled = True If Me.CBSearchCatagory.Value = "Search by FNO" Or _ Me.CBSearchCatagory.Value = "Search by IDNO" Or _ Me.CBSearchCatagory.Value = "Search by TAGNO" Or _ Me.CBSearchCatagory.Value = "Search by CUSTOMER" Or _ Me.CBSearchCatagory.Value = "Search by VMANUF" Or _ Me.CBSearchCatagory.Value = "Search by VSDJOBNO" Or _ Me.CBSearchCatagory.Value = "Search by SIZE" And _ Me.CBSearchResult = "" Then Exit Sub Me.CBSearchResult.Visible = True End If If Me.CBSearchResult.ListIndex = 0 Then Beep Exit Sub End If Me.FNO.Value = Me.CBSearchResult.Value If Me.CBSearchCatagory.Value = "Search by FNO" And Me.FNO.Value = Me.CBSearchResult Then With CBSearchResult Application.ScreenUpdating = False Set FoundCell = Cells.Find(What:=Me.CBSearchResult.Value, _ After:=Cells(1), _ LookIn:=xlValues, _ lookat:=xlWhole, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False) If Not FoundCell Is Nothing Then Beep Me.IDNO.Value = FoundCell.Offset(0, 1).Value Me.TAGNO.Value = FoundCell.Offset(0, 2).Value Me.CUSTOMER.Value = FoundCell.Offset(0, 3).Value Me.VTYPE.Value = FoundCell.Offset(0, 4).Value Me.JOBNO.Value = FoundCell.Offset(0, 5).Value Me.RECDDATE.Value = FoundCell.Offset(0, 6).Value Me.Size.Value = FoundCell.Offset(0, 7).Value Me.UNIT.Value = FoundCell.Offset(0, 8).Value Me.CLASS.Value = FoundCell.Offset(0, 9).Value Me.MODL.Value = FoundCell.Offset(0, 10).Value Me.VMANUF.Value = FoundCell.Offset(0, 11).Value Me.LCLASS.Value = FoundCell.Offset(0, 12).Value Me.CV.Value = FoundCell.Offset(0, 13).Value Me.ATYPE.Value = FoundCell.Offset(0, 14).Value Me.AMANUF.Value = FoundCell.Offset(0, 15).Value Me.SERIALNO.Value = FoundCell.Offset(0, 16).Value Me.TRAVEL.Value = FoundCell.Offset(0, 17).Value Me.SUP.Value = FoundCell.Offset(0, 18).Value Me.SUNIT.Value = FoundCell.Offset(0, 19).Value Me.Range.Value = FoundCell.Offset(0, 20).Value Me.Action.Value = FoundCell.Offset(0, 21).Value Me.Loc.Value = FoundCell.Offset(0, 22).Value 'Picture1-Label Copy to userform Dim wsImageCopies1 As Worksheet Dim oImage As Image Dim oShape As Shape Dim oChart As Chart Dim sTempFilename As String Dim s As Double Dim l As Double Dim t As Double Dim h As Double 'Assign a filename for the temporary image sTempFilename = Environ("temp") & "\temp_" & Format(Now, "yy-mm-dd_hh-mm-ss") & ".jpg" 'Assign the "ImageCopies1" sheet to an object variable Set wsImageCopies1 = ActiveWorkbook.Worksheets("ImageCopies1") s = 100 t = 50 l = 24 h = 24 If FoundCell.Offset(0, 24).Value > "" Then MultiPage1.Pages.Add Dim lblCaption1 As MSForms.Label On Error GoTo Err_Clr Set lblCaption1 = MultiPage1.Pages(1).Controls.Add("Forms.label.1", "myLabelCaption") With lblCaption1 .Font.Name = "Arial Black" .Font.Size = 14 .TextAlign = fmTextAlignCenter .Width = s .Height = h .Left = l .Top = t + s .ForeColor = vbWhite .BackColor = &H800000 .WordWrap = False .AutoSize = False .Enabled = True .Caption = FoundCell.Offset(0, 24).Value Me.Repaint End With 'Add and set the properties for an image control on the second page of the multipage control Set oImage = Me.MultiPage1.Pages(1).Controls.Add("Forms.Image.1") With oImage .Name = "image1" .Left = l .Top = t .Width = s .Height = s End With 'Assign image1 to an object variable Set oShape = wsImageCopies1.Shapes(MultiPage1.Pages(1).image1.Name) 'Add an empty chart With wsImageCopies1.ChartObjects.Add(Left:=1, Top:=1, Width:=oShape.Width, Height:=oShape.Height) With .Chart 'Copy the picture oShape.Copy 'Paste the picture in the chart .Paste 'Export the chart .Export sTempFilename End With 'Load the exported file onto the image control oImage.Picture = LoadPicture(sTempFilename) 'Delete the chart .Delete 'Delete the temporary file Kill sTempFilename End With If FoundCell.Offset(0, 26).Value > "" Then MultiPage1.Pages().Value = 1 Dim lblCaption2 As MSForms.Label On Error GoTo Err_Clr Set lblCaption2 = MultiPage1.Pages(1).Controls.Add("Forms.label.1", "myLabelCaption") With lblCaption2 .Font.Name = "Arial Black" .Font.Size = 14 .TextAlign = fmTextAlignCenter .Width = s .Height = h .Left = l + s + l .Top = t + s .ForeColor = vbWhite .BackColor = &H800000 .WordWrap = False .AutoSize = False .Enabled = True .Caption = FoundCell.Offset(0, 26).Value Me.Repaint End With 'Add and set the properties for another image control on the second page of the multipage control Set oImage = Me.MultiPage1.Pages(1).Controls.Add("Forms.Image.1") With oImage .Name = "image2" .Left = l + s + l .Top = t .Width = s .Height = s End With 'Assign image2 to an object variable Set oShape = wsImageCopies1.Shapes(MultiPage1.Pages(1).image2.Name) 'Add an empty chart With wsImageCopies1.ChartObjects.Add(Left:=1, Top:=1, Width:=oShape.Width, Height:=oShape.Height) With .Chart 'Copy the picture oShape.Copy 'Paste the picture in the chart .Paste 'Export the chart .Export sTempFilename End With 'Load the exported file onto the image control oImage.Picture = LoadPicture(sTempFilename) 'Delete the chart .Delete 'Delete the temporary file Kill sTempFilename End With End If End If End If Application.ScreenUpdating = True Err_Clr: If Err <> 0 Then Err.Clear Resume Next End If End With End If End Sub

Does this help?

sureshtrb · Feb 17, 2015

Appreciated.
It starts working with following issues.
1.The temporary sheet "ImageCopies1" should not be deleted in the close function.

Code:

If ws.Name <> "Data" And ws.Name <> "ImageCopies1" Then ws.Delete

2.Same image is showing in both image controls in userform
3.The temporary additional sheet to be deleted

Retrieve Image from Sheet to userform??

sureshtrb

Board Regular

Excel Facts

sureshtrb

Board Regular

Domenic

MrExcel MVP

sureshtrb

Board Regular

Domenic

MrExcel MVP

sureshtrb

Board Regular

Domenic

MrExcel MVP

sureshtrb

Board Regular

Domenic

MrExcel MVP

sureshtrb

Board Regular

Similar threads

Forum statistics

Share this page

Retrieve Image from Sheet to userform??

Board Regular

Excel Facts

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

MrExcel MVP

Board Regular

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock