'- GET PICTURES FROM A FOLDER INTO A WORKSHEET & FIT TO CELLS
'- With small amendments ADD_NEW_PICTURE subroutine could be made standalone
'- THERE IS A SEPARATE SUBROUTINE SORT THE DATA AND PICTURES
'- NB. Ignores picture properties eg.Move & size with cells etc. which can be set with code
'------------------------------------------------------------------
'- Brian Baulsom May 2010
'- ref some other messages containing similar code :
'- http://www.mrexcel.com/forum/showthread.php?t=311884
'- http://www.mrexcel.com/board2/viewtopic.php?t=145831
'=============================================================================
'- *** NB. Amend code below to
'- *** 1. Set PictureFolder variable
'- *** 2. Set picture file suffix (eg. *.bmp, *.wmf etc.)
'- Run macro from the target worksheet
'=============================================================================
Dim PictureSourceFolder As String
Dim ToBook As String
Dim ToSheet As Worksheet
Dim PictureFname As String
Dim PictureFullname As String
'- SUBROUTINE VARIABLES
Dim PictureCell As Range
Dim ToRow As Long
'==============================================================================
'- MAIN ROUTINE
'==============================================================================
Sub PICTURES_FROM_FOLDER()
'=====================================================
'-*** NB SET THIS TO THE CORRECT PICTURE FOLDER ***
'=====================================================
PictureSourceFolder = "C:\Users\Gary\Desktop\Website\Kondrotas Photots\New folder"
'=====================================================
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
ToBook = ActiveWorkbook.Name
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'-------------------------------------------------------------------------
'- WORKSHEET SETUP
Set ToSheet = ActiveSheet
ToRow = 2
With ToSheet
' .Cells.ClearContents ***** IF I LEAVE THIS LINE IN, IT CLEARS THE WHOLE WORKSHEET EXCEPT A1 AND B1
.Range("A1:B1").Value = Array("Picture", "Item Number")
.Columns("A").EntireColumn.ColumnWidth = 20
.Rows.EntireRow.RowHeight = 60
'---------------------------------------------------------------------
'- CLEAR EXISTING PICTURES
For Each s In .Shapes
s.Delete
Next
'---------------------------------------------------------------------
End With
'====================================================
' *** NB. AMEND LINE BELOW FOR CORRECT FILE SUFFIX
PictureFname = Dir(PictureSourceFolder & "*.jpg") 'ALL THE PICTURES ARE "*.jpg"
'===================================================
'- loop to get each picture file from the folder
While PictureFname <> ""
Application.StatusBar = PictureFname
'---------------
ADD_NEW_PICTURE ' CALL SUBROUTINE BELOW
'---------------
PictureFname = Dir
Wend
'------------------------------------------------------------------------
SORT_DATA_AND_PICTURES ' CALL SUBROUTINE BELOW
'------------------------------------------------------------------------
'-- close
Application.ScreenUpdating = True
Range("A1").Select ' remove Selection from the picture
MsgBox ("Done.")
Application.StatusBar = False
Application.Calculation = xlCalculationAutomatic
End Sub
'======= end of main routine==================================================
'=============================================================================
'- SUBROUTINE TO ADD A NEW PICTURE TO A WORKSHEET
'- Column A : Add picture & size to the cell
'- Name picture as file name(no suffix). Picture name to cell
'- Column B : File Name without suffix
'=============================================================================
Private Sub ADD_NEW_PICTURE()
Dim ItemName As String
ItemName = Left(PictureFname, Len(PictureFname) - 4)
'-------------------------------------------------------------------------
'- INSERT PICTURE
PictureFullname = PictureSourceFolder & PictureFname
ToSheet.Pictures.Insert(PictureFullname).Select
'-------------------------------------------------------------------------
'- POSITION PICTURE
With ToSheet.Cells(ToRow, 1)
.Value = ItemName
Selection.Name = ItemName
Selection.Top = .Top
Selection.Left = .Left
Selection.Height = .Height
Selection.Width = .Width
End With
'-------------------------------------------------------------------------
ToSheet.Cells(ToRow, 2).Value = ItemName
ToRow = ToRow + 1
End Sub
'=============================================================================
'=============================================================================
'- SORT DATA & PICTURES
'- CALLED FROM ABOVE - BUT THIS ROUTINE CAN BE USED ON ITS OWN
'- assumes that cells and pictures are the same size already
'- ....... and the cells contain the picture names
'=============================================================================
Sub SORT_DATA_AND_PICTURES()
Dim ws As Worksheet
Dim rw As Long
Dim LastRow As Long
Dim PictureName As String
'-------------------------------------------------------------------------
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws = ActiveSheet
LastRow = ws.Range("A65536").End(xlUp).Row
'-------------------------------------------------------------------------
'- SORT DATA
ws.Range("A1").Sort Key1:=Range("B2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
'-------------------------------------------------------------------------
'- PUT PICTURES INTO CORRECT CELLS
'- assumes that cells and pictures are the same size already
For rw = 2 To LastRow
With ws.Cells(rw, 1)
PictureName = .Value
ws.Shapes(PictureName).Select
Selection.Top = .Top
Selection.Left = .Left
End With
Next
'-------------------------------------------------------------------------
Application.Calculation = xlCalculationAutomatic
Range("A1").Select ' remove Selection from the picture
Beep
End Sub
'=========== END OF ROUTINE ==================================================
