How to export all graphics from a notebook?

Question

The problem

I have a notebook consisting of around 50 expressions like following:

data = Table[i, {i, 10}];
ListPlot[data (*, some Plot options *)]

I want to export all those plots into separate image files in the target directory.

Some approaches that I thought of

Monkey work

One can right click -> "Save Graphic As..." all those plots. This does work but tiresome, boring and inconvenient.

Export last output

Another idea that I had was to Copy-Paste simple command, that would export last output, after all ~50 plots:

data = Table[i, {i, 10}];
ListPlot[data]
Export[NotebookDirectory[] <> "\\pics\\" <> ToString[++globalPicCounter] <> ".png" 
 , %, "PNG"] (* this line is manually pasted after every Plot in the notebook *)

Don't forget to set globalPicCounter to 0 before you start exporting everything.

This one also works and also left me unsatisfied. It's not way too different from mokey work, it breaks if Plot was not the last output, and if you want to clear notebook to initial state after work's done you have to do some more monkey work.

This idea can be improved: I can Find and Replace all Plots with pure function that does the same:

Export[NotebookDirectory[] <> "\\pics\\" <> 
    ToString[++globalPicCounter] <> ".png", #, "PNG"] &@ListPlot...

Plot[] wrapper

Next idea that I came up with was to implement Villegas-Gayley wrapper for Plot:

globalGraphicsCounter = 0;
Module[{$inMsg},
 Unprotect[ListPlot];

 ListPlot[args___] /; Not@TrueQ[$inMsg] :=  
   Block[{$inMsg = True, result},
    result = ListPlot[args];
    Export[
     NotebookDirectory[] <> "\\pics\\" <> 
       ToString[++globalGraphicsCounter] <> ".png", result];
    result];

 Protect[ListPlot];
]

To my surprise that didn't work. ListPlot evaluates as usual, without exporting plot. Putting some Print[...]'s into the wrapper of ListPlot indicates that new definition of ListPlot does not actually get used. I tried to do the same with Message[...] to replicate Villegas-Gayley wrapper in the initial setting and it works as expected.

So while this would be a really nice solution I didnt manage to make it work.

AuthorTools package

While searching for a different ways to export plots I stumbled upon AuthorTools package. There is an Export Cells palette that "enables the extraction of content of a specified type from a given notebook or project and saves the content in a desired format". It does have an option to export all Graphics Cells but when I try to do it I get following error message:

I had no success trying to figure out what's it about.

I also tried to export plots using AuthorTools`ExportNotebook[]:

In[90]:= ExportNotebook[EvaluationNotebook[], "Graphics", "PNG"]

Out[90]= {}

and didn't have much success. As it turns out trying to get all Graphics objects from notebook returned empty list. Where are all the plots then? I found them when I tried to export all Input Cell Groups using _AuthorTools_`ExportCells palette. All plots are in the Output Cells which are in the Input Cell Groups.

Low-Level Notebook Programming

I guess there is also an option to work with Notebooks and Cell Expressions in them on low-level, and make some simple parser to do this task. But I have very vague understanding how to do it.

This method might have an additional advantage: you won't have to reevaluate your notebook.

Notes

On some more thought I understand that this problem have two somewhat different variations depending on imposed restrictions:

• if evaluations in the notebook aren't time consuming you may use methods that reevaluate notebook or some cells in it;

• if evaluations in the notebook are long, one might want to use method that doesn't need to reevaluate notebook.

And while in this very case my notebook is "lightweight", I think it would be interesting and usefull to make a distinction if suggested methods meet additional restrictions (there might be other ones but evaluation time that I didn't thought of).

Answer 1

It is as easy as follows using low-level Notebook programming:

outputCells = Cells[CellStyle -> "Output"];
cellsWithGraphics = Select[outputCells, ! FreeQ[NotebookRead[#], GraphicsBox] &];
MapIndexed[Export[ToString[#2[[1]]] <> ".png", #1] &, cellsWithGraphics]

This solution assumes that all your graphical objects are in "Output" cells.