このプログラムは「図形がシート上にすでにある」という前提です。もし図形などが何もない状態で実行しても動作しますが、「media」フォルダ内には何もない状態になります。
従い、もしVBAで全自動処理(図形をコピーして画像として貼り付けから行う)ためには、このプログラムを実行する前に、コピーペーストの処理を組み込んでおきます。(マクロの記録ベースでいけるかと思います)
Sub シート上の図形を画像として保存したフォルダを開く()
    Dim strPath As String
    Dim FSO As Object
    Set FSO = CreateObject(“Scripting.FileSystemObject”)
    strPath = FSO.GetSpecialFolder(2)
    Set FSO = Nothing
    Dim Wb As Workbook
    Dim Wsh As Worksheet
    Dim strZipName As String
    strZipName = VBA.Format(Now, “yyyymmdd-hhmmss”) & “.zip”
    Set Wsh = ThisWorkbook.Worksheets(“sheet1”)
    Wsh.Copy
    Set Wb = ActiveWorkbook
    Wb.SaveAs strPath & “\” & strZipName
    Wb.Close
    Dim sh As Object
    Set sh = CreateObject(“WScript.Shell”)
    sh.Run “explorer.exe  /n,/e,/select,” & strPath & “\” & strZipName & “\xl\media\”
    Set sh = Nothing
    MsgBox “終了” & vbCrLf & “エクスプローラが開きます”, vbInformation
End Sub
大まかな処理の流れは
1.テンポラリフォルダのパスを取得
2.図形のあるブック(Thisworkbookに注意)をコピーして新規ブックを作り「1」に保存
3.「2」で作成したファイルをエクスプローラーで開く
以上で、エクスプローラー上で画像が保存されている「media」フォルダの階層が開きます。
「2」のシートコピーですが、これはもともと自分自身(Thisworkbook)のブックにVBAを書き込んでいて、自分自身をZIPにリネームすることができないので、図形のあるシートをコピーさせ、別ブックとして起動させ保存しています。
従い、「 Set Wsh = ThisWorkbook.Worksheets(“sheet1″)」の部分は利用状況によって手直しが必要かもしれません。