エクセルで写真台帳のように１シートに写真3枚をはりつけて作成しており、3000シートぐらいあります。

そのエクセルファイルを開きファイル→名前をつけて保存を選びます。

ファイル名を適当に、ファイルの種類をWEBページで保存します。

すると保存されたディレクトリ上にファイル名と同じフォルダが出来上がってるかと思います。

そのフォルダの中に各シートの写真が保存されています。

http://www.hatena.ne.jp/

そのエクセルファイルを開いて、「名前を付けて保存」をします。その時に「Webページ (*.htm;*html)」で保存すると「ファイル名.html」というファイルと「ファイル名.files」というフォルダが出来てjpgデータなどはそのフォルダの中に全て抽出されて保存されます。

http://q.hatena.ne.jp/1268663637

http://allabout.co.jp/computer/msexcel/closeup/CU20081005A/index...

HTML形式で保存すれば 画像ファイルが 出来ます。

こちらのサイトのAPIを使った方法を使えばできそうなので作ってみました。

http://vbatips.blog37.fc2.com/blog-entry-26.html

一つのブックに３０００シートとは考えづらいので複数ブックがあるとして、

画像はオートシェイプで挿入されている場合、複数のブックのオートシェイプをjpg画像で保存するマクロです。

以下のコードで「保存先フォルダ」「ブックのあるフォルダ」の２行を実際の環境に変更して

新規のブックか画像のあるブックの一つのどちらかの標準モジュールにコピペしてSaveJpgを実行してみてください。

ブック名-シート名-オートシェイプ名で名前をつけて一気に保存します。

命名規則の変更をしたい場合やブックごとにフォルダを分けるなどにしたい場合は修正しますのでお知らせ下さい。

※画像９０００だとハードディスクの空きを確認し、時間もかかると思われるので少ないファイルからテストしてみてください。

Private Type FLTIMAGE
    StructSize As Integer
    Type As Byte
    Reserved1(0 To 8) As Byte
    hImage As Long
    Reserved3(0 To 19) As Byte
End Type
Private Type FLTFILE
    Reserved1 As Integer
    Ext As String * 4
    Reserved2 As Integer
    Path As String * 260
    Reserved3 As Currency
End Type
Private Declare Function GetFilterInfo Lib _
  "C:\Program Files\Common Files\Microsoft Shared\Grphflt\JPEGIM32.FLT" _
       (ByVal Ver As Integer, ByVal Reserved As Long, _
        phMem As Long, ByVal flags As Long) As Long
Private Declare Function ExportGr Lib "JPEGIM32.FLT" _
   (ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
Private Declare Function OpenClipboard Lib "user32" _
        (ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
        (ByVal uFormat As Long) As Long
Const CF_ENHMETAFILE = 14
Private Declare Function CopyEnhMetaFile Lib "gdi32" _
       Alias "CopyEnhMetaFileA" _
        (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
       (ByVal hemf As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" _
       (ByVal hMem As Long) As Long

Function SaveClipToJpg(img As Shape, Path As String) As Boolean
    Dim tFltImg As FLTIMAGE
    Dim tFltFile As FLTFILE
    Dim hemf As Long
    Dim hMem As Long
  
    SaveClipToJpg = False
    
    'クリップボードにコピー
    img.CopyPicture
    'Selection.CopyPicture
    If OpenClipboard(0) Then
        hemf = CopyEnhMetaFile( _
                GetClipboardData(CF_ENHMETAFILE), _
                vbNullString)
        CloseClipboard
    End If
    If hemf = 0 Then Exit Function
    
    ' パラメータ設定
    tFltFile.Path = Path & vbNullChar
    With tFltImg
        .StructSize = LenB(tFltImg)
        .Type = 1
        .hImage = hemf
    End With
    ' フィルタ呼び出し
    If GetFilterInfo(3, 0, hMem, &H10000) And &H10 Then
        If ExportGr(tFltFile, tFltImg, hMem) = 0 Then
            SaveClipToJpg = True
        End If
    End If
    
    If hMem Then GlobalFree hMem
    DeleteEnhMetaFile hemf

End Function

Sub SaveJpg()
    Const SavePath As String = "C:\Documents and Settings\hogehoge\デスクトップ\test"  '保存先フォルダ
    Const BooksPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\test" 'ブックのあるフォルダ
    Dim f As Boolean
    Dim shp As Shape
    Dim ws As Worksheet
    Dim suc As Integer
    Dim fai As Integer
    Dim FSO
    Dim myFile
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    For Each myFile In FSO.GetFolder(BooksPath).Files
        If FSO.GetExtensionName(myFile) = "xls" Or FSO.GetExtensionName(myFile) = "xlsx" Then
            Workbooks.Open myFile.Path
            For Each ws In Workbooks(myFile.Name).Worksheets
                For Each shp In ws.Shapes
                    If shp.Type = msoPicture Then
                        f = SaveClipToJpg(shp, SavePath & "\" & FSO.GetBaseName(myFile) & "-" & ws.Name & "-" & shp.Name & ".jpg")
                        If f Then
                            suc = suc + 1
                        Else
                            fai = fai + 1
                        End If
                    End If
                Next
            Next
            Workbooks(myFile.Name).Close
        End If
    Next
    
    MsgBox "成功:" & suc & vbNewLine & "失敗:" & fai
    
    Set FSO = Nothing
End Sub