VBA code needed for Inserting and resizing pics

[tschadle]

Hello,

1. I have a multisheet excel file where I would like VBA code to go out onto the server and pull in jpeg images based on style names listed in the spreadsheet.

2. Style names could be on any cell say from range a1:ab200. Generally about 60 styles per excel workbook tab. We use multiple tabs in the workbook for showing styles / pics.
a. styles names are very generic e.g. Kathleen, Jennifer, Sammi. Style names are not two words or 1 word with a number. E.g. style names are not Mary Lou or Jennifer 2.

3. The jpeg pics that I would like to input next (same row to the right) to any style name on any cell of the file are saved in the same folder.
"S:\COMMON-CHAPS\CHAPS-Wedge\RTW\Pre-Holiday'18\Kohl's\MISSY\backup\floorplan"
a. Ideally the image would be 1 in by 1in directly to the right of the cell with the style name. I will insert columns and rows to ensure that no inserted jpeg would overlap.
b. I would like the style name to be preserved as the jpeg name when placed inside the excel workbook.
c. If the style jpeg is not in the directory, I would like the vba code to skip that style name and go directly to the next style name / image until it has worked through all tabs in the workbook.

4. Workbook name is currently "test1.xlsm" but could be frequently renamed. I am hoping that I don't need to change the code as the file is renamed.

5. Ideally jpegs would be less than 1 in x 1 in and could be deleted and replaced with the same macro as the style name is changed within the workbook.
a. Ideally I would have a button that when pressed would delete all images and then insert new images as described above.

Can someone help me with this? I have been seeing lots of code where it is very specific that it only pulls back 1 pic for 1 specific cell. I need expanded functionality for any cells that have a style name on the tab that match any pics in the same folder.

Thank you,

Tiffanie
​

 

[pbornemeier]

1. Please provide a few style names/tab names/picture names Please show some examples that help to explain: "I need expanded functionality for any cells that have a style name on the tab that match any pics in the same folder"
2. The inserted file images are currently the size of the cell in which they are inserted. Area you going to resize the cells in your worksheets, or do you want the inserted images to be 1 inch x 1 inch with the upper left corner of the image and the upper left corner of the cell aligned?
3. If the cells are not going to be set to be at least 1x1 inch, are the names in the worksheets going to be spaced so the 1x1 images do not overlap?
4. Do you want to preserve the name of the inserted images or can they be changed?
5. So if text is in any of the 5600 cells, check the "S:\COMMON-CHAPS\CH..." directory to see if there is a filename in it that matches that text, and if so, insert the thumbnail image in the cell to the right of that text
6. Does the 'Style' in 'Style names could be on any cell say' refer to an Excel cell style (e.g. 'Accent 2' or 'Comma') or to a "design or make in a particular form" such as 'Art Deco', "Minimalist', 'Frank Lloyd Wright' ?

 

[tschadle]

Hello Phil,

Thank for answering the thread.

1. Here is an example of the file / tab where there are style numbers where I would like the resized pic to be pulled from the server and put onto each tab. This example, I would like it to pull the pics and input based on style names to column F and G. (Sorry--this site did not allow me to cut and paste in a picture of a shirt into e37.)

[B]Excel 2010[/B][TABLE]
<tbody>[TR="bgcolor: #DAE7F5"]
[TH][/TH]
[TH]D
[/TH]
[TH]E
[/TH]
[TH]F
[/TH]
[/TR]
[TR]
[TD="align: center"]37
[/TD]
[TD="align: center"]ANGELINA
[/TD]
[TD="align: center"][/TD]
[TD="align: center"]BRITNEY
[/TD]
[/TR]
[TR]
[TD="align: center"]38
[/TD]
[TD="bgcolor: #8DB4E2, align: center"]PAULINA
[/TD]
[TD="bgcolor: #8DB4E2, align: center"][/TD]
[TD="bgcolor: #8DB4E2, align: center"]LINDSAY
[/TD]
[/TR]
</tbody>[/TABLE]



2. I like your idea that the image aligns with the upper left corner of the cell that is directly to the right and not automatically sized to fit the cell it is going into.
3. I will try to space the amount of columns between style names so that they won’t overlap.
4. I would like to keep the name of the style.
5. Yes….a style name could be in any cell within that range.
6. If I understand your question correctly, the style names are like the names assigned to women as the example above.

Tiffanie

 

[pbornemeier]

The name of the worksheet did not seem to factor in to anything described in your last post, so this code does not account for it.
When the ScanWorksheetUpdatePictures sub is run, all images on the active worksheet will be deleted and the entire worksheet will
be searched for cells containing text. When text is found in a cell the sPath directory will be searched for a file that has that name
(extension is not checked) That file is placed on the worksheet to the right of the cell containing text and resized to fit in a 1 inch square
or in the cell (whichever is smaller), with the aspect ratio being preserved. The name of the picture is changed slightly. For example if a
cell C5 contains Lorna the code will search for a file named lorna. If that folder contains multiple files with a name of lorna and different
extensions (lorna.txt, lorna.jpg, lorna.xlsx, lorna.gif, & lorna.png) you could get any of those files. Once the picture is inserted it will be
named lorna.D5 where D5 is the cell that contains the file.

Test this on a copy of your worksheet and let me know how it works for you.

Option Explicit
'https://www.mrexcel.com/forum/excel-questions/1043513-vba-code-needed-inserting-resizing-pics.html

Sub ScanWorksheetUpdatePictures()
    'This code assumes:
    '   1) Files in the target directory all have unique names (none with same
    '      name and different extension.
    '   2) The names in the worksheet correspond to image filenames in the target
    '      directory
    
    Dim sPath As String
    '=============================== UPDATE THIS PATH ====================================
    sPath = "[B]S:\COMMON-CHAPS\CHAPS-Wedge\RTW\Pre-Holiday'18\Kohl's\MISSY\backup\floorplan\[/B]"
    
    Dim shp As Shape
    Dim rngCell As Range
    Dim sFilePathNameExt As String
    Dim sFileNameExt As String
    Dim sFileName As String
    Dim sCellAddr As String
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngRatioToFit As Single
    Dim sngOneInch As Single
    
    sngOneInch = Application.InchesToPoints(1)
    
    If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
    
    With ActiveSheet
        'Delete all images from activeworksheet
        For Each shp In .Shapes: shp.Delete: Next
        For Each rngCell In .UsedRange.SpecialCells(xlCellTypeConstants, 2)
            'Check each cell containing text
            sFileName = rngCell.Text
            sFileNameExt = Dir(sPath & sFileName & ".*")
            If sFileNameExt <> vbNullString Then
                sFilePathNameExt = sPath & sFileNameExt
                rngCell.Offset(0, 1).Select
                
                'Get dimensions & and address of the cell to the right of rngCell
                sngCellHeight = Selection.Height
                If sngCellHeight > sngOneInch Then sngCellHeight = sngOneInch
                sngCellWidth = Selection.Width
                If sngCellWidth > sngOneInch Then sngCellWidth = sngOneInch
                sCellAddr = Selection.Address(False, False)
                
                ActiveSheet.Pictures.Insert(sFilePathNameExt).Select
                'Ensure inserted picture is at full size (Insert shrinks large pictures)
                Selection.Name = sFileName & "." & sCellAddr 'Adds the cell address to the filename
                                                             'that was selected when the sub was run
                Selection.ShapeRange.LockAspectRatio = msoFalse
                ActiveSheet.Shapes(Selection.Name).ScaleHeight 1, msoTrue
                ActiveSheet.Shapes(Selection.Name).ScaleWidth 1, msoTrue
                Selection.ShapeRange.LockAspectRatio = msoTrue
                
                'Compare the picture aspect ratio to the right-clicked cell suze & aspect ratio
                'Shrink picture as necessary to fit cell
                If Selection.Height / sngCellHeight > Selection.Width / sngCellWidth Then
                    sngRatioToFit = sngCellHeight / Selection.Height
                Else
                    sngRatioToFit = sngCellWidth / Selection.Width
                End If
                Selection.ShapeRange.LockAspectRatio = msoTrue
                Selection.ShapeRange.ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
                
                Selection.OnAction = "TogglePict"   'Sets the TogglePict macro to run when the image is clicked
                                            'that was selected when the sub was run
                
            End If
        Next
        
    End With

End Sub
Sub TogglePict()
    
    Dim sName As String
    Dim sCellAddr As String
    
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngCellRatio As Single
    
    Dim sngPixHeight As Single
    Dim sngPixWidth As Single
    Dim sngPixRatio As Single
    
    Dim sngOrigPixHeight As Single
    Dim sngOrigPixWidth As Single
    Dim sngOrigPixRatio As Single
    
    Dim sngRatioToFit As Single
    
    Dim sngViewHeightMax As Single
    Dim sngViewWidthMax As Single
    
    Dim sngOneInch As Single
    
    sngOneInch = Application.InchesToPoints(1)
    
    'Reduce the size of the max view so no part of the enlarged picture is below the
    '    Sheet Name Tabs or Statusbar
    sngViewHeightMax = 0.9 * ActiveWindow.UsableHeight
    sngViewWidthMax = 0.9 * ActiveWindow.UsableWidth
    
    sName = Application.Caller  'Determines the name of the image that started the code
    sCellAddr = Mid(sName, InStr(sName, ".") + 1)
    
    sngOrigPixHeight = ActiveSheet.Shapes(sName).Height
    sngOrigPixWidth = ActiveSheet.Shapes(sName).Width
    sngOrigPixRatio = sngOrigPixHeight / sngOrigPixWidth
    
    sngCellHeight = Range(sCellAddr).Height
    If sngCellHeight > sngOneInch Then sngCellHeight = sngOneInch
    sngCellWidth = Range(sCellAddr).Width
    If sngCellWidth > sngOneInch Then sngCellWidth = sngOneInch
    sngCellRatio = sngCellHeight / sngCellWidth
    
    'Is the UL corner of picture in its storage cell (or displayed at its full size)
    If sCellAddr = ActiveSheet.Shapes(sName).TopLeftCell.Address(False, False) Then
        'Picture is located in its storage cell, so restore its size and center it
        'Allow aspect ratio to revert back to original value in case someone changed it
        ActiveSheet.Shapes(sName).LockAspectRatio = msoFalse
        'Set height and width back to original size
        sngPixHeight = ActiveSheet.Shapes(sName).ScaleHeight(1, msoTrue)
        sngPixWidth = ActiveSheet.Shapes(sName).ScaleWidth(1, msoTrue)
        'Lock in original aspect ratio
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        
        'If picture is larger than the screen, shrink so it is smaller.  Keep aspect ratio
        If ActiveSheet.Shapes(sName).Height > sngViewHeightMax Or ActiveSheet.Shapes(sName).Width > sngViewWidthMax Then
            If ActiveSheet.Shapes(sName).Height / sngViewHeightMax > ActiveSheet.Shapes(sName).Width / sngViewWidthMax Then
                sngRatioToFit = sngViewHeightMax / ActiveSheet.Shapes(sName).Height
            Else
                sngRatioToFit = sngViewWidthMax / ActiveSheet.Shapes(sName).Width
            End If
            ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoTrue, msoScaleFromTopLeft
        End If
        
        'Center Picture in Excel Window
        ActiveSheet.Shapes(sName).Left = ActiveWindow.VisibleRange.Left + _
            (0.05 * sngViewWidthMax + ((sngViewWidthMax - ActiveSheet.Shapes(sName).Width) / 2))
        ActiveSheet.Shapes(sName).Top = ActiveWindow.VisibleRange.Top + _
            (0.05 * sngViewHeightMax + ((sngViewHeightMax - ActiveSheet.Shapes(sName).Height) / 2))
        ActiveSheet.Shapes(sName).ZOrder msoBringToFront
        
    Else
        'Picture is out of the cell and needs to be put into it
        If ActiveSheet.Shapes(sName).Height / sngCellHeight > ActiveSheet.Shapes(sName).Width / sngCellWidth Then
            sngRatioToFit = sngCellHeight / ActiveSheet.Shapes(sName).Height
        Else
            sngRatioToFit = sngCellWidth / ActiveSheet.Shapes(sName).Width
        End If
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        'Resize picture to fit in storage cell
        ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
        'Move UL corner of picture to UL corner of storage cell
        ActiveSheet.Shapes(sName).Left = Range(sCellAddr).Left
        ActiveSheet.Shapes(sName).Top = Range(sCellAddr).Top
        ActiveSheet.Shapes(sName).ZOrder msoSendToBack
        
    End If
    
    Application.ScreenUpdating = True
    
End Sub
Sub DisplayFullScreen_True()
    'Hides toolbars, formula bar and various other items
    Application.DisplayFullScreen = True
End Sub
Sub DisplayFullScreen_False()
    'Unhides hidden toolbars, formula bar and various other items
    Application.DisplayFullScreen = False
End Sub

 

[tschadle]

Hello Phil,

thank you for the code. The code execution gets stuck on this line :

sFileNameExt = Dir(sPath & sFileName & ".*")

Do I need to add in the file name or the entire path to the file and file name? E.g.
S:\COMMON-CHAPS\CHAPS-Wedge\RTW\Pre-Holiday'18\Kohl's\MISSY\backup\floorplan\test 1.xlsm

Thank you again!

Tiffanie

 

[pbornemeier]

What error message is displayed when the code stops?
What are some actual names of the image files?

 

[tschadle]

Hello Phil,
Thank you for getting back to me.
I tried executing your new code and it needed debugging on this line so I could use your advice on how to proceed:
ActiveSheet.Pictures.Insert(sFilePathNameExt).Select

So I thought perhaps I needed to update your code to further define the filename:
sFileNameExt = "S:\COMMON-CHAPS\CHAPS-Wedge\RTW\Pre-Holiday'18\Kohl's\MISSY\backup\floorplan\.xlsm"

But I am not sure I am on the right track but this is what I pasted into VBA:
Sub ScanWorksheetUpdatePictures()
'This code assumes:
' 1) Files in the target directory all have unique names (none with same
' name and different extension.
' 2) The names in the worksheet correspond to image filenames in the target
' directory

Dim sPath As String
    '=============================== UPDATE THIS PATH ====================================
    sPath = "S:\COMMON-CHAPS\CHAPS-Wedge\RTW\Pre-Holiday'18\Kohl's\MISSY\backup\floorplan"
    
    Dim shp As Shape
    Dim rngCell As Range
    Dim sFilePathNameExt As String
    Dim sFileNameExt As String
    Dim sFileName As String
    Dim sCellAddr As String
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngRatioToFit As Single
    Dim sngOneInch As Single
    
    sngOneInch = Application.InchesToPoints(1)
    
    If Right(sPath, 1) <> "" Then sPath = sPath & ""
    
    With ActiveSheet
        'Delete all images from activeworksheet
        For Each shp In .Shapes: shp.Delete: Next
        For Each rngCell In .UsedRange.SpecialCells(xlCellTypeConstants, 2)
            'Check each cell containing text
            sFileName = rngCell.Text
         [SIZE=3]   sFileNameExt = "S:\COMMON-CHAPS\CHAPS-Wedge\RTW\Pre-Holiday'18\Kohl's\MISSY\backup\floorplan\test 1.xlsm"[/SIZE]
            If sFileNameExt <> vbNullString Then
                sFilePathNameExt = sPath & sFileNameExt
                rngCell.Offset(0, 1).Select
                
                'Get dimensions & and address of the cell to the right of rngCell
                sngCellHeight = Selection.Height
                If sngCellHeight > sngOneInch Then sngCellHeight = sngOneInch
                sngCellWidth = Selection.Width
                If sngCellWidth > sngOneInch Then sngCellWidth = sngOneInch
                sCellAddr = Selection.Address(False, False)
                
                [SIZE=3]ActiveSheet.Pictures.Insert(sFilePathNameExt).Select[/SIZE]
                'Ensure inserted picture is at full size (Insert shrinks large pictures)
                Selection.Name = sFileName & "." & sCellAddr 'Adds the cell address to the filename
                                                             'that was selected when the sub was run
                Selection.ShapeRange.LockAspectRatio = msoFalse
                ActiveSheet.Shapes(Selection.Name).ScaleHeight 1, msoTrue
                ActiveSheet.Shapes(Selection.Name).ScaleWidth 1, msoTrue
                Selection.ShapeRange.LockAspectRatio = msoTrue
                
                'Compare the picture aspect ratio to the right-clicked cell suze & aspect ratio
                'Shrink picture as necessary to fit cell
                If Selection.Height / sngCellHeight > Selection.Width / sngCellWidth Then
                    sngRatioToFit = sngCellHeight / Selection.Height
                Else
                    sngRatioToFit = sngCellWidth / Selection.Width
                End If
                Selection.ShapeRange.LockAspectRatio = msoTrue
                Selection.ShapeRange.ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
                
                Selection.OnAction = "TogglePict"   'Sets the TogglePict macro to run when the image is clicked
                                            'that was selected when the sub was run
                
            End If
        Next
        
    End With
End Sub

Sub TogglePict()
    
    Dim sName As String
    Dim sCellAddr As String
    
    Dim sngCellHeight As Single
    Dim sngCellWidth As Single
    Dim sngCellRatio As Single
    
    Dim sngPixHeight As Single
    Dim sngPixWidth As Single
    Dim sngPixRatio As Single
    
    Dim sngOrigPixHeight As Single
    Dim sngOrigPixWidth As Single
    Dim sngOrigPixRatio As Single
    
    Dim sngRatioToFit As Single
    
    Dim sngViewHeightMax As Single
    Dim sngViewWidthMax As Single
    
    Dim sngOneInch As Single
    
    sngOneInch = Application.InchesToPoints(1)
    
    'Reduce the size of the max view so no part of the enlarged picture is below the
    '    Sheet Name Tabs or Statusbar
    sngViewHeightMax = 0.9 * ActiveWindow.UsableHeight
    sngViewWidthMax = 0.9 * ActiveWindow.UsableWidth
    
    sName = Application.Caller  'Determines the name of the image that started the code
    sCellAddr = Mid(sName, InStr(sName, ".") + 1)
    
    sngOrigPixHeight = ActiveSheet.Shapes(sName).Height
    sngOrigPixWidth = ActiveSheet.Shapes(sName).Width
    sngOrigPixRatio = sngOrigPixHeight / sngOrigPixWidth
    
    sngCellHeight = Range(sCellAddr).Height
    If sngCellHeight > sngOneInch Then sngCellHeight = sngOneInch
    sngCellWidth = Range(sCellAddr).Width
    If sngCellWidth > sngOneInch Then sngCellWidth = sngOneInch
    sngCellRatio = sngCellHeight / sngCellWidth
    
    'Is the UL corner of picture in its storage cell (or displayed at its full size)
    If sCellAddr = ActiveSheet.Shapes(sName).TopLeftCell.Address(False, False) Then
        'Picture is located in its storage cell, so restore its size and center it
        'Allow aspect ratio to revert back to original value in case someone changed it
        ActiveSheet.Shapes(sName).LockAspectRatio = msoFalse
        'Set height and width back to original size
        sngPixHeight = ActiveSheet.Shapes(sName).ScaleHeight(1, msoTrue)
        sngPixWidth = ActiveSheet.Shapes(sName).ScaleWidth(1, msoTrue)
        'Lock in original aspect ratio
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        
        'If picture is larger than the screen, shrink so it is smaller.  Keep aspect ratio
        If ActiveSheet.Shapes(sName).Height > sngViewHeightMax Or ActiveSheet.Shapes(sName).Width > sngViewWidthMax Then
            If ActiveSheet.Shapes(sName).Height / sngViewHeightMax > ActiveSheet.Shapes(sName).Width / sngViewWidthMax Then
                sngRatioToFit = sngViewHeightMax / ActiveSheet.Shapes(sName).Height
            Else
                sngRatioToFit = sngViewWidthMax / ActiveSheet.Shapes(sName).Width
            End If
            ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoTrue, msoScaleFromTopLeft
        End If
        
        'Center Picture in Excel Window
        ActiveSheet.Shapes(sName).Left = ActiveWindow.VisibleRange.Left + _
            (0.05 * sngViewWidthMax + ((sngViewWidthMax - ActiveSheet.Shapes(sName).Width) / 2))
        ActiveSheet.Shapes(sName).Top = ActiveWindow.VisibleRange.Top + _
            (0.05 * sngViewHeightMax + ((sngViewHeightMax - ActiveSheet.Shapes(sName).Height) / 2))
        ActiveSheet.Shapes(sName).ZOrder msoBringToFront
        
    Else
        'Picture is out of the cell and needs to be put into it
        If ActiveSheet.Shapes(sName).Height / sngCellHeight > ActiveSheet.Shapes(sName).Width / sngCellWidth Then
            sngRatioToFit = sngCellHeight / ActiveSheet.Shapes(sName).Height
        Else
            sngRatioToFit = sngCellWidth / ActiveSheet.Shapes(sName).Width
        End If
        ActiveSheet.Shapes(sName).LockAspectRatio = msoTrue
        'Resize picture to fit in storage cell
        ActiveSheet.Shapes(sName).ScaleHeight sngRatioToFit, msoFalse, msoScaleFromTopLeft
        'Move UL corner of picture to UL corner of storage cell
        ActiveSheet.Shapes(sName).Left = Range(sCellAddr).Left
        ActiveSheet.Shapes(sName).Top = Range(sCellAddr).Top
        ActiveSheet.Shapes(sName).ZOrder msoSendToBack
        
    End If
    
    Application.ScreenUpdating = True
    
End Sub
Sub DisplayFullScreen_True()
    'Hides toolbars, formula bar and various other items
    Application.DisplayFullScreen = True
End Sub
Sub DisplayFullScreen_False()
    'Unhides hidden toolbars, formula bar and various other items
    Application.DisplayFullScreen = False

==========
Thank you,
Tiffanie