Export/Save selected charts(pictures) as image, if file exists add unique number

[WildBurrow]

Good afternoon,

Hitting a wall... I've created a photo log template that allows users to insert and describe pictures; the file is saved to .pdf and then closed. The purpose of which is to move a number of .jpg files into a single document, thus decreasing file storage requirements (original image files will be deleted afterwards). The template allows the user to add sheets as needed that will format images as portrait or landscape. The sheet options include one picture per sheet or multiple pictures per sheet. No problems with this portion of the project.

However, we would also like to keep unique photos in a training folder to be used as needed. I had this bright idea that it would be convenient to copy the pictures to the training folder before closing the template. If a photo is exported and saved for training purposes, I need;

• Define root directory that will allow the user to pick a subfolder
• Define a default name that utilized a cell value and a suffix like "Trng"
• Add unique number if the file exists

I've cobbled together some code (below) that will save a picture to a defined folder, and even assign a default file name. My problems start when;

1. There is more than one picture(chart) on the sheet - also seems like the current code only likes landscape orientation
2. The sheet name is not "Sheet1" - given that the user can add multiple sheets, I can't provide a sheet name
3. Passing the exported file to the Function to obtain a unique number

I'm not sure how to properly address these issues. Looking for advice.

Also, my current code looks to export a single picture at a time simply because I thought I could manage writing the code sneaky. However, I am now wondering if there is was a way for the user to select more than one picture and export them all at once. Any suggestions?

Any help will be greatly appreciated.

Sub ExportDesktop()

    Dim outFldr As String, SourceFldr As String
    Dim co As ChartObject

     SourceFldr = "C:\Users\10030798\Desktop\2016\"   
    If SourceFldr = "" Then
        Msgbox "Export Cancelled"
    Else
          
    Dim myChart As String, MyPicture As String, DefaultNm As String, fileExt As String, saveAsExportFilename As String
    Dim PicWidth As Long, PicHeight As Long
    
    DefaultNm = Worksheets("Cover").range("O12").Value & ".Trng"
    fileExt = ".jpg"
    saveAsExportFilename = GetSaveAsExportFilename(SourceFldr, DefaultNm, fileExt)     
    Application.ScreenUpdating = False
    On Error GoTo Finish    

    'Define picture as selection
    MyPicture = Selection.Name    
    'Sets picture parameters
    With Selection
        PicHeight = .ShapeRange.Height
        PicWidth = .ShapeRange.Width
    End With     
    'Initiates add chart and set parameters
    Charts.Add
    ActiveChart.Location Where:=xlLocationAsObject, Name:="Sheet1"
    Selection.Border.LineStyle = 0
    myChart = Selection.Name & " " & Split(ActiveChart.Name, " ")(2)     
    'Sets chart width/height same as picture width/height
    With ActiveSheet
        With .Shapes(myChart)
            .Width = PicWidth
            .Height = PicHeight
        End With           
           'Copies back to picture that was selected and defined
           .Shapes(MyPicture).Copy           
        'Pastes pic to new chart
        With ActiveChart
            .ChartArea.Select
            .Paste
        End With           
           'Exports chart then deletes it from the sheet
            .ChartObjects(1).Chart.Export SourceFldr & "\" & DefaultNm & fileExt
            .Shapes(myChart).Cut
     End With     
     Application.ScreenUpdating = True
     Exit Sub     
Finish:
     Msgbox "You must select a picture"                       
    End If
End Sub


Public Function GetSaveAsExportFilename(ByVal SourceFldr As String, ByVal DefaultNm As String, Optional ByVal fileExt As String = ".jpg") As String

    Dim tempFilename As String
    Dim fileCount As Long 
    tempFilename = tempFilename = SourceFldr & DefaultNm & fileExt
 
    If Len(Dir(tempFilename, vbNormal)) > 0 Then     
            fileCount = fileCount + 1
            tempFilename = SourceFldr & DefaultNm & " #" & fileCount & fileExt
            If Len(Dir(tempFilename, vbNormal)) = 0 Then                
            End If       
    End If 
    GetSaveAsExportFilename = tempFilename
End Function

'Code blended from:
'Source:https://www.mrexcel.com/board/threads/vba-to-export-all-charts-in-workbook-to-selected-folder.784004/ (BrianMH) &
'Source:https://www.tapatalk.com/groups/xlvbafr/export-pictures-from-excel-t207.html#.UguN7ZKyAqY

 

[WildBurrow]

Revisions and Workarounds - Fixed the problems

My issues were:

1. There is more than one picture(chart) on the sheet - also seems like the current code only likes landscape orientation
2. The sheet name is not "Sheet1" - given that the user can add multiple sheets, I can't provide a sheet name
3. Passing the exported file to the Function to obtain a unique number

Using my three issues as the starting point, I outlined the need for three key pieces of code: Insert a blank chart (one or more per sheet), Embed a photo in the chart, and Export the chart as a picture.

Since it seemed that I ultimately needed to export a chart to get my desired result (a copy of the picture in a separate folder), I reversed the process: I embedded a chart then added a picture to fill the entire background. Because I was absolutely clueless about charts, I found a video by Wise Owl Tutorials that demonstrated how to work with single and multiple charts per sheet. It can be found here: Embedding Charts in Worksheets. I then found come nice code used to insert the picture into the chart here: Place Image Into Chart. This help me address the individual charts for each sheet and thus addressed issues 1 and 2.

Creating a unique number (issue number 3) for each exported picture was fixed by adding a modifier to the file naming to include

Format(Now, "ddhhmmss")

. While not as ideal as a smaller numbering structure, it does the trick. Additionally, I found a very succinct bit of code to export the chart as a picture from this site: Export Chart As Picture

My thanks to everyone who shares information!

Basic code to insert a chart:

'Insert Chart
    range("A1").Select
    ActiveSheet.ChartObjects.Add 0, 0, 486.72, 357.84 'left top, width height
    ActiveSheet.ChartObjects("Chart 1").Activate
    Selection.Placement = xlFreeFloating
    ActiveSheet.Shapes("Chart 1").LockAspectRatio = msoTrue
    ActiveWindow.View = xlPageBreakPreview
    ActiveWindow.View = xlNormalView

Macro to insert picture into selected chart:

Sub InsertPictureIntoChart()
Dim pictureFilename As Variant, chartsizerange As range, objChart As Chart, mypic As String

Set objChart = ActiveChart
Set chartsizerange = range("A1:AB26")

    On Error Resume Next
     
     '   Test if there is a single chart selected
    If ActiveChart Is Nothing Then
        Msgbox "Please select a chart ", 0
        Exit Sub
    End If

    pictureFilename = Application.GetOpenFilename( _
        FileFilter:="Image Files (*.gif;*.jpg;*.png), *.gif;*.jpg;*.png", _
        Title:="Insert Picture", _
        ButtonText:="Insert")
       
    'if user cancels, exit sub
    If pictureFilename = False Then Exit Sub

    With objChart.Pictures.Insert(pictureFilename)
        .Left = (objChart.ChartArea.Width - .Width) / 2
        .Top = (objChart.ChartArea.Height - .Height) / 2
    End With
   
    range("AD25").Select
 
End Sub

Macro to export picture to folder:

Sub ExportPicToTraining()
     'Export a selected chart as a picture
    Const sSlash$ = "/"
    Const sPicType$ = ".jpg"
    Dim sChartName$
    Dim sPath$
    Dim sBook$
    Dim objChart As ChartObject
    Dim DefaultNm As String
     
    DefaultNm = Worksheets("Cover").range("AL6").Value & ".Trng." & Format(Now, "ddhhmmss")
    
    On Error Resume Next
     '   Test if there are even any embedded charts on the activesheet
     '   If not, let the user know
    Set objChart = ActiveSheet.ChartObjects(1)
    If objChart Is Nothing Then
        Msgbox "No photos have been detected on this sheet", 0
        Exit Sub
    End If
     
     '   Test if there is a single chart selected
    If ActiveChart Is Nothing Then
        Msgbox "Please select a photo ", 0
        Exit Sub
    End If
     
Start:
    sChartName = DefaultNm
    
     '   User presses "OK" without entering a name
    If sChartName = Empty Then
        Msgbox "You have not entered a name for this chart", , "Invalid Entry"
        GoTo Start
    End If
     
     '   Test for Cancel button
    If sChartName = "False" Then
        Exit Sub
    End If
     
     '   If a name was given, chart is exported as a picture in the same
     '   folder location as their current file
    sBook = "M:\Emergency Operations and Response\Training\Training Images"
    sPath = sBook & sSlash & sChartName & sPicType
    ActiveChart.Export Filename:=sPath, FilterName:="JPG"
    
    Msgbox "Picture saved to the training folder"
     
End Sub