Hello please help in this code,
i have store some images on a folder i can see all images in worksheet at duble click event now i want to change this as selection change event
please help for this code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim MyFolder As String
Dim MyFile As String
Dim ws As Worksheet
Dim MyCell As Range ' cell for picture
Dim MyGallery As ShapeRange ' ALL PICTURES IN THE SHEET
'----------------------------------------------------------------------------
'- Folder & File name
MyFolder = "C:\Documents and Settings\abc\Desktop\tation\images\"
MyFile = MyFolder & Target.Value & ".jpg" ' CELL VALUE"
'------------------------------------------------------
Application.ScreenUpdating = False
Set ws = ActiveSheet
'------------------------------------------------------
'- clear all existing pictures
On Error Resume Next ' might be no pictures yet
Set MyGallery = ws.Pictures.ShapeRange
MyGallery.Delete
On Error GoTo 0 ' reset error trap to normal
'------------------------------------------------------
'- CELL SIZE
Set MyCell = ws.Range("E1")
MyCell.ColumnWidth = 30
MyCell.RowHeight = 200
'------------------------------------------------------
'- INSERT PICTURE & RESIZE TO SAME AS CELL
ws.Pictures.Insert(MyFile).Select
With Selection
.Top = MyCell.Top
.Left = MyCell.Left
.Width = MyCell.Width
.Height = MyCell.Height
.Placement = xlMoveAndSize
.PrintObject = True
End With
'------------------------------------------------------
'- remove focus from picture
MyCell.Select
Application.ScreenUpdating = True
End Sub
i have store some images on a folder i can see all images in worksheet at duble click event now i want to change this as selection change event
please help for this code
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim MyFolder As String
Dim MyFile As String
Dim ws As Worksheet
Dim MyCell As Range ' cell for picture
Dim MyGallery As ShapeRange ' ALL PICTURES IN THE SHEET
'----------------------------------------------------------------------------
'- Folder & File name
MyFolder = "C:\Documents and Settings\abc\Desktop\tation\images\"
MyFile = MyFolder & Target.Value & ".jpg" ' CELL VALUE"
'------------------------------------------------------
Application.ScreenUpdating = False
Set ws = ActiveSheet
'------------------------------------------------------
'- clear all existing pictures
On Error Resume Next ' might be no pictures yet
Set MyGallery = ws.Pictures.ShapeRange
MyGallery.Delete
On Error GoTo 0 ' reset error trap to normal
'------------------------------------------------------
'- CELL SIZE
Set MyCell = ws.Range("E1")
MyCell.ColumnWidth = 30
MyCell.RowHeight = 200
'------------------------------------------------------
'- INSERT PICTURE & RESIZE TO SAME AS CELL
ws.Pictures.Insert(MyFile).Select
With Selection
.Top = MyCell.Top
.Left = MyCell.Left
.Width = MyCell.Width
.Height = MyCell.Height
.Placement = xlMoveAndSize
.PrintObject = True
End With
'------------------------------------------------------
'- remove focus from picture
MyCell.Select
Application.ScreenUpdating = True
End Sub