'Save all charts on the current worksheet in PNG and EPS format. 'The names are derived by concatenating first 4 (or all for shorter 'titles) words of each chart title, optionally followed by a seq 'no to ensure unique file names. 'NOTEs: ' 1. Since this routine does not overwrite files, please delete ' existing files before re-running, else seq nos. will be ' appended to generated files to avoid overwriting existing ones. ' 2. seq no is a global variable, not specific to each file-name. ' 3. This routine will bomb if some chart doesn't have a title. ' 4. This routine is completely independent of spreadsheet specifics, ' and can be safely used with any spreadsheet. ' 5. See below and set the variable "generate_eps" to generate ' .png/.eps or .png/.bb files. The latter allows inclusion of ' .png in latex via \DeclareGraphicsRule{} command. ' 6. Excel seems to arbitrarily increase font sizes and hence sizes of ' legend boxes and such during conversion to PNG. Keep font sizes ' small to be prepared for this. For the usual IEEE format, using ' Arial, size 8 or smaller for everything seems to work well. ' 7. The replaces below are really embarassing; I really wanted to do the ' regular expression replace listed below, but VB is clueless. Another ' stupidity: more than one space in a row are treated as words by ' split! Hence the 2 tries on replacing " " by " ". How ugly!! ' Const max_limit As Integer = 3 '1 less than #words used for file name Const generate_eps As Boolean = True Sub ChartPict_save() Dim sFName, inpname, outname, fname, arg As String Dim tokens As Variant Dim Pict As Object Dim ch, fs Dim i, j, limit, count As Integer count = 0 i = 1 Set fs = CreateObject("Scripting.FileSystemObject") For Each Pict In ActiveSheet.ChartObjects Set ch = Pict.Chart 'sFName = ThisWorkbook.Path & Application.PathSeparator & Pict.Chart.ChartTitle.Text sFName = Pict.Chart.ChartTitle.Text 'sFName = Replace(sFName, "[!A-Za-z0-9_.]", "") 'DOESN'T WORK!!!! sFName = Replace(sFName, "!", "") sFName = Replace(sFName, "%", "") sFName = Replace(sFName, "^", "") sFName = Replace(sFName, "&", "") sFName = Replace(sFName, "*", "") sFName = Replace(sFName, "(", "") sFName = Replace(sFName, ")", "") sFName = Replace(sFName, ":", "") sFName = Replace(sFName, ",", "") sFName = Replace(sFName, "/", "") sFName = Replace(sFName, "\", "") sFName = Replace(sFName, "[", "") sFName = Replace(sFName, "]", "") sFName = Replace(sFName, " ", " ") sFName = Replace(sFName, " ", " ") tokens = Split(sFName, , , vbTextCompare) fname = "" limit = UBound(tokens) If (limit > max_limit) Then limit = max_limit For j = 0 To limit fname = fname & tokens(j) 'Join first max_limit words Next ' fname = Join(tokens, "_") inpname = fname & ".png" Do While (fs.FileExists(inpname)) 'Avoid file overwrite count = count + 1 inpname = fname & count & ".png" Loop ch.Export Filename:=inpname, FilterName:="PNG" If (generate_eps) Then If (count = 0) Then outname = fname & ".eps" Else outname = fname & count & ".eps" arg = "bmeps -p3 -c -e8rf " & inpname & " " & outname Else If (count = 0) Then outname = fname & ".bb" Else outname = fname & count & ".bb" arg = "bmeps -b " & inpname & " " & outname End If Shell (arg) i = i + 1 Next Set ch = Nothing End Sub