モジュールです。

Sub SP8501_GazouGet(strBookPATH As String, strOutPath As String)

'*************************************************************************************************

'@ エクセルブックから画像ファイルを取り出す

'* 注意事項；これはサンプルであり、様々な機能や例外処理等は省略しています

'*           実際にお使いになる場合は例外処理や各種機能の追加変更を行って下さい

'* [INPUT]   strBookPATH AS STRING             '==対象のブックのパス 例)D:\TET\AA.XLSX

'*           strOutPath AS STRING              '==このフォルダに画像ファイルを格納  フォルダが作られていないとエラーになります

'*************************************************************************************************

Dim strZipPath As String

Dim strKXL As String

Dim strAstar As String

Dim strTmpPATH As String

Dim intIdx As Integer

Dim strFname(1 To 512) As String

Dim intFsu As Integer

Dim strFnam As String

'

'***対象のブックを拡張子をZIPにして複写

    strZipPath = Replace(strBookPATH, "xlsx", "zip", 1, -1)

    strZipPath = Replace(strZipPath, "XLSX", "zip", 1, -1)

    FileCopy strBookPATH, strZipPath

'

'***tempフォルダ準備

    strTmpPATH = ThisWorkbook.path & "\temp"

    On Error Resume Next

    mkdir strTmpPATH

    On Error GoTo 0

'

'***ZIP ファイルの解凍

    Call SP_解凍(strZipPath, strTmpPATH)                               '==2300_ZIP操作.BAS

'

'***解凍したフォルダ下のXLのファイルを複写

    strKXL = strTmpPATH & "\XL\media"                                  '==解凍先したフォルダの中のXL下の画像フォルダ

    strAstar = strKXL & "\*.*"

    Call SP_FileNameGet(strAstar, strFname(), intFsu)                  '==与えられたフォルダ・拡張子のファイル名を得る

    For intIdx = 1 To intFsu

        FileCopy strKXL & "\" & strFname(intIdx), strOutPath & strFname(intIdx)  '==strOutPathで指定するフォルダがないとエラーになります

    Next

'

'***作成した ZIP ファイルを削除

    KILL strZipPath

'

'***作成した tempフォルダ準備を削除

    Dim FileObj As New FileSystemObject

    Call FileObj.DeleteFolder(strTmpPATH, True) ' 指定したパスのフォルダを削除

    Set FileObj = Nothing

'

'***EXIT

   Exit Sub

End Sub

Sub SP_FileNameGet(strAstar As String, strFname() As String, intFsu As Integer)

'*************************************************************************************************

'@ 与えられたフォルダ・拡張子のファイル名を得る

'* [INPUT]   strAstar As String    '==条件  例) P:\DATA\*.ISC

'* [OUTPUT]  strFname() As String  '==条件に当てはまるファイル名(ファイル名にてSORT済み)    フォルダ名は含まない

'*           intFsu As Long        '==条件に当てはまるファイル名の数（上記配列の有効数) 0ならファイルなし

'*************************************************************************************************

Dim strNowData As String

Dim intIdx As Long

'

'***初期化

    intFsu = 0

'

'***ファイル名を得る

    strNowData = Dir$(strAstar)

    If Trim$(strNowData) <> "" Then

       intFsu = 1

       strFname(intFsu) = strNowData

       For intIdx = 2 To UBound(strFname)

           strNowData = Dir$

           If Trim$(strNowData) = "" Then

              Exit For

           End If

           intFsu = intFsu + 1

           strFname(intFsu) = strNowData

       Next

    End If

'

'***EXIT

    Exit Sub

End Sub

  

Sub SP_解凍(strZipPath As String, strOutPath As String)

'*****************************************************

'@ ZIP ファイルの解凍(win7 対応)

'* 参照設定で下記コントロールが必要

'* Microsoft Scripting Runtime

'* Microsoft Shell Controls And Automation

'* [INPUT] strZipPath As String    '==解凍する書庫ファイル名  例) Y:\test.zip

'*         strOutPath as string    '==解凍先フォルダ

'*****************************************************

Dim objZIP         As Shell32.Folder

Dim objZIPItem     As Shell32.FolderItem

Dim objOut         As Shell32.Folder

Dim objFso         As Object

Dim objShell       As Object

'

'***オブジェクト生成

    Set objFso = CreateObject("Scripting.FileSystemObject")

    Set objShell = CreateObject("Shell.Application")

  

'***書庫オブジェクトを取得する

    Set objZIP = objShell.Namespace(objFso.GetAbsolutePathName(strZipPath))

  

'***SP_解凍先を取得する

    Set objOut = objShell.Namespace(objFso.GetAbsolutePathName(strOutPath))

  

'***SP_解凍していく

    For Each objZIPItem In objZIP.Items

        Call objOut.CopyHere(objZIPItem, 1044)

    Next

'

'***後始末

    Set objZIP = Nothing

    Set objZIPItem = Nothing

    Set objOut = Nothing

    Set objFso = Nothing

    Set objShell = Nothing

'

'***exit sub

    Exit Sub

End Sub

  

テスト用メインです。

Sub TestMain()

'*****************************************************

'@ 8660_エクセルブックのシートをブックに分割のテスト用メイン

'*****************************************************

Dim strBookPATH As String       '==対象のブックのパス 例)D:\TET\AA.XLSX

Dim strOutPath As String        '==このフォルダに画像ファイルを格納

'

'***TEST用データブック

    strBookPATH = ThisWorkbook.sheets(1).Range("DataPath")

    If strBookPATH = "" Then

       MSGBOX "画像を含むテスト用ブックのフルパスを設定して下さい"

       Exit Sub

    End If

'

'***TEST用出力フォルダ

    strOutPath = ThisWorkbook.sheets(1).Range("DataPath2")

    If strOutPath = "" Then

       MSGBOX "テスト用に出力するフォルダを設定して下さい"

       Exit Sub

    End If

    If Right$(strOutPath, 1) <> "\" Then strOutPath = strOutPath & "\"

'

'***CALL

    Call SP8501_GazouGet(strBookPATH, strOutPath)

'

'***EXIT

    MSGBOX "処理は終了しました"

    Exit Sub

End Sub