Results 1 to 8 of 8
  1. #1
    Star Lounger
    Join Date
    Sep 2006
    Location
    New York, New York, USA
    Posts
    76
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Excel 2013/2016: How to Save Picture In Cell To Disk

    Hi,

    I searched the forums, but came up empty. In Excel, I have a worksheet with images appearing in one column and a numerical identifier in another column. I want to create a macro that will export the images to disk using the associated identifiers as the file name. Sounded simple, until I discovered that images are not part of the cell, but of the worksheet and are basically anchored to a cell, so querying each cell to get the picture does not work.

    I can successfully loop through the worksheet shapes, get each image, and copy it to the clipboard (using Cells(range).CopyPicture), but cannot see how to save it to disk. I would also have to use something like "Shape.TopLeftCell.Address" to determine which row it is anchored to in order to get the associated identifier.

    I tried using VB6 to do the same thing and got just as far -- can copy to the clipboard -- but when I try to use SavePicture I get an error about Invalid Property Value.

    Before I bang my head any further, is there some way that I have been overlooking to accomplish this seemingly simple task?

    Thanks!

  2. #2
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Hi generic,

    This can be done by adding a pic to a chart (background) then saving the chart as a .gif.

    The following code cycles through the images in col A, grabs the file name in adjacent column B, and then copies the image. The code then creates a chart sheet and pastes the image into the chart and finally saves it as a .gif using the path in cell B2 and the captured file name.

    Note: Change the name of the path in cell B2. If you use my method to capture the pic names and to copy the pics to the clipboard, make sure that the top of each image is within the row that the image name is located. The code assumes that the row height is consistently 15 and the only shapes on the sheet are the images. If you want to add buttons then while looping through the shapes on the sheet you will need to add code to test for the type of shape

    HTH,
    Maud

    Code:
    Public Sub SavePic()
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
    '---------------------------------------------'
    'DECLARE AND SET VARIABLES
        Dim Pic As Shape, PicTop As Double, Row As Long, Path As String, fname As String
    '---------------------------------------------'
    'LOOP THRU IMAGES ON WORKSHEET AND GET FILE NAME
        For Each Pic In ActiveSheet.Shapes
            PicTop = Pic.Top
            Row = WorksheetFunction.RoundUp(PicTop / 15, 0)
            Path = Cells(1, 2)
            fname = Cells(Row, 2)
    '---------------------------------------------'
    'ADD CHART SHEET, COPY AND PASTE PIC TO SHEET
            Sheets("Sheet1").Select
            Pic.Select
            Selection.Copy
            Charts.Add2
            'Sheets("Chart2").Select
            ActiveChart.Paste
            ActiveChart.Shapes.Range(Array("Picture 1")).Select
            Selection.ShapeRange.ScaleWidth 10, msoFalse, msoScaleFromTopLeft
            Selection.ShapeRange.ScaleHeight 10, msoFalse, msoScaleFromTopLeft
            ActiveChart.ChartArea.Select
            fname = Path & fname & ".gif"
            ActiveChart.Export Filename:=fname, FilterName:="GIF"
            Application.DisplayAlerts = False
            ActiveSheet.Delete
        Next Pic
    '---------------------------------------------'
    'CLEANUP
        Set Pic = Nothing
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        Range("A1").Select
    End Sub
    Main sheet with images:
    ChartToGIF3.png

    Windows Explorer showing saved files:
    ChartToGIF2.png

    Saved .gif opened in photo editor:
    ChartToGIF4.png
    Attached Files Attached Files
    Last edited by Maudibe; 2016-10-31 at 06:00.

  3. #3
    Star Lounger
    Join Date
    Sep 2006
    Location
    New York, New York, USA
    Posts
    76
    Thanks
    1
    Thanked 0 Times in 0 Posts
    Hi Maudibe,

    First, thank you so much for your response!

    I have spent the better part of my day trying to adapt your code to my project, with some success but still some problems. I have reduced the code to simply trying to save the first image in the active worksheet to a hard-coded file name (I can get it working for multiple images later).

    The main issue that I am having is that when I paste the picture into the chart, the chart area provides a small margin around the picture, so when it is exported to disk the resulting file also contains this margin. I want to basically save just the embedded picture, so I am guessing that I need to resize the chart area to be the same as the picture, making it an invisible container for the image, and with the necessary method to save file image to disk. The problem is that I can't seem to find the correct way to do this.

    I am attaching a vba procedure that I wrote -- with help from your code sample -- that illustrates this problem. I ran the same procedure in your sample spreadsheet and although the margin is not as pronounced it is still there. I also tested in your sheet after scaling the images to 100%, which all of the ones in my sheet already are scaled to.

    Do you see what is wrong with my procedure? I have to admit that the Excel object model -- and the Help documentation -- are very confusing to me. I can't seem to properly set a variable to the embedded chart object to manipulate the properties and need to keep referring to ActiveChart.

    Again, thanks so much for your help. I really appreciate it!


    Code:
    Sub test()
    
        Dim shp As Shape
        Dim ch As ChartObject
        Dim w As Long
        Dim h As Long
        
        
        Set shp = ActiveSheet.Shapes(1) 'get the first picture, wherever it is
        w = shp.Width 'store the picture width
        h = shp.Height 'store the picture height
        ActiveSheet.Shapes.AddChart2 'add the chart object
        Set ch = ActiveSheet.ChartObjects(1)
        'ch.Select
        ch.Activate
        ActiveChart.ChartArea.ClearContents 'clear all of the default chart contents
        ActiveChart.ChartArea.Width = w 'set the chart width to be the same as the picture
        ActiveChart.ChartArea.Height = h  'set the chart height to be the same as the picture
        shp.ScaleHeight 1, msoFalse 'ensure scale is 100% (does not seem to affect the picture size though)
        shp.Select
        shp.Copy 'copy the picture to the Clipboard
        ch.Activate
        ActiveChart.Paste 'paste the picture from the Clipboard to the chart object
        ActiveChart.ChartArea.Select
        ActiveChart.Export "c:\test.jpg", "JPG" 'save the chart to disk as a jpeg file
    
    End Sub
    Last edited by generic_e; 2016-10-31 at 15:29.

  4. #4
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    generic,

    You will notice in my code these lines:

    Code:
            Selection.ShapeRange.ScaleWidth 10, msoFalse, msoScaleFromTopLeft
            Selection.ShapeRange.ScaleHeight 10, msoFalse, msoScaleFromTopLeft
    This takes the image and expands it to the limits of the chart boundaries. Note the displayed image in my post from a photo editor. there is no issue with the chart borders. On a chart sheet, I found it difficult to shrink the chart size but very easy to expand the image.

    Give that a try and see if it resolves your issue.

    Maud

    P.S. If you could post your file, I might be able to help further if needed

  5. #5
    Star Lounger
    Join Date
    Sep 2006
    Location
    New York, New York, USA
    Posts
    76
    Thanks
    1
    Thanked 0 Times in 0 Posts
    Yes, I had seen that code, but when I executed them on my images -- most of which are thumbnails -- the resulting image is pixilated and, of course, a different size than the original. I need to preserve the size and fidelity of the image, which is why I tried to reduce the chart area to the exact measurements of the image, but have not succeeded.

    Unfortunately, the image files are proprietary and I am not permitted to distribute them, but I think the issue is with any image.

    I will see what I can do to get this working and will post a solution if I find one. Many thanks for your guidance, Maud!

  6. #6
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    Generic,

    Thumbnails do not have the resolution that images have therefore will be pixelated as you had indicated. The images I used however were copies of actual images.

    J too will attempt to find a way to shrink the chart instead. Perhaps instead.past in into a chart on the sheet instead of a chart sheet

  7. #7
    Gold Lounger Maudibe's Avatar
    Join Date
    Aug 2010
    Location
    Pa, USA
    Posts
    2,638
    Thanks
    115
    Thanked 650 Times in 592 Posts
    generic,

    Here is revised code that uses a temporary chart on the same sheet instead of creating a chart sheet. The chart is created and named "TempChart" with its borders resized to the size of the image that is pasted into it. The chart borders are removed and then the chart is saved with the image in its original size and named according to text from the adjacent column. The chart/image is then deleted from the sheet and the process repeats as it loops through the rest of the images.

    Note: This version checks the type of shape and runs the code only if the shape is an image. This will allow you to place buttons, textboxes, etc, on the sheet as well as the images. The code still assumes that the row height is consistently 15

    HTH,
    Maud

    Code:
    Public Sub SavePic()
        Application.ScreenUpdating = False
    '---------------------------------------------'
    'DECLARE AND SET VARIABLES
        Dim Pic As Shape, PicTop As Double, Row As Long, Path As String, fname As String
    '---------------------------------------------'
    'LOOP THRU IMAGES ON WORKSHEET AND GET FILE NAME
        For Each Pic In ActiveSheet.Shapes
            If Pic.Type = 13 Then
                PicTop = Pic.Top
                PicHt = Pic.Height
                PicWd = Pic.Width
                Range("J1").Select
                ActiveSheet.Shapes.AddChart.Name = "TempChart"
                ActiveSheet.Shapes("TempChart").Height = PicHt
                ActiveSheet.Shapes("TempChart").Width = PicWd
                ActiveSheet.Shapes("TempChart").Line.Visible = msoFalse
                Row = WorksheetFunction.RoundUp(PicTop / 15, 0)
                Path = Cells(1, 2)
                fname = Cells(Row, 2)
    '---------------------------------------------'
    'ADD CHART SHEET, COPY AND PASTE PIC TO SHEET
                Pic.Select
                Selection.Copy
                ActiveSheet.Shapes("TempChart").Select
                ActiveChart.Paste
                fname = Path & fname & ".gif"
                ActiveChart.Export Filename:=fname, FilterName:="GIF"
                ActiveSheet.Shapes("TempChart").Cut
            End If
        Next Pic
    '---------------------------------------------'
    'CLEANUP
        Set Pic = Nothing
        Application.ScreenUpdating = True
        Range("A1").Select
    End Sub
    Attached Files Attached Files

  8. The Following User Says Thank You to Maudibe For This Useful Post:

    generic_e (2016-11-21)

  9. #8
    Star Lounger
    Join Date
    Sep 2006
    Location
    New York, New York, USA
    Posts
    76
    Thanks
    1
    Thanked 0 Times in 0 Posts

    Thumbs up

    Hi Maud,

    Sorry for the delayed response as I was busy with other tasks. Your solution is perfect. I had been using a similar technique, but could not figure out the part to resize the chart object to the image's original dimensions. Your solution with creating/naming the temporary chart object, resizing it, and removing the chart borders provides exactly what was needed.

    Many thanks for your efforts and prompt responses. I really appreciate it!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •