VBAからGDI+を使う資料集
inet上の達人の方々から御教示いただいたコードを少しアレンジさせてもらっています（切り貼りとも言います）。
  1. ホーム
  2. Other
  3. extractimage


エクセルブックから画像を取り出す

xl2007以降のエクセルブックの実体はZIP圧縮フォルダーであり、拡張子をZIPに変更して解凍すると画像ファイルを取り出す事ができます。 画像ファイルの取り出しとか、リンク→埋め込みの変換とか、リンク先の変更とかのコードを書いてみました。
エクセルブックのフォルダー構成をワークシートに書き出すコードも載せてあります。改造すれば、普通のフォルダーを対象にしても、 再帰的な下位フォルダーまでのファイルリスト取得が可能と思います。

  1. エクセルブックの画像ファイルを抽出
  2. 選択画像の画像ファイルを抽出
  3. リンク画像を埋め込み画像に変換
  4. 画像のリンク先を変更する
  5. Shellに参照設定してワークブック構造をワークシートに書き出してみる




'************** エクセルブックから画像ファイルを取り出す　**************
'実行時バインディング版
Sub ExtractImage()
  Dim fso As Object '安直に拡張子を取得するために使用、丸ごと取り出しの場合不要
  Dim objShell As Object
  Dim objFile As Object
  Dim objDestination As Object
  Dim vZipFile, vDestination
  Dim myFile As Object
  Dim getDesktopPath As String
  
  Const ssfDESKTOP = 0

  ' ファイルシステムオブジェクトおよびシェルオブジェクト作成
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set objShell = CreateObject("Shell.Application")
  getDesktopPath = objShell.Namespace(ssfDESKTOP).Self.Path
  
  'ThisWorkbookを別名で保存し、拡張子をZipにRenameして画像ファイルを取り出す
  ThisWorkbook.SaveCopyAs getDesktopPath & "\temp.xlsm"
  If Dir(getDesktopPath & "\temp.zip") <> "" Then Kill getDesktopPath & "\temp.zip"
  Name getDesktopPath & "\temp.xlsm" As getDesktopPath & "\temp.zip"
  vZipFile = getDesktopPath & "\temp.zip"
  vDestination = getDesktopPath & "\tempDir"
  
  ' 展開先パスがなければ作成する
  If Dir(vDestination, vbDirectory) = "" Then
  MkDir vDestination
  End If
  
  ' Zipファイルオブジェクト作成(画像ファイルは\xl\media\にある
  Set objFile = objShell.Namespace(vZipFile & "\xl\media")
  ' 展開先オブジェクト作成
  Set objDestination = objShell.Namespace(vDestination)
  
  ' 展開
   '丸ごと取り出す時
  objDestination.CopyHere objFile.items
  
  '画像の形式別に取り出す時
'  For Each myFile In objFile.items
'    Select Case LCase(fso.GetExtensionName(myFile.Name))
'      'とりあえずJpegだけテストした
'      Case "jpg"
'        objDestination.copyhere myFile
'    End Select
'  Next myFile
End Sub
コンテンツリストに戻る 


'************** ワークシートの選択した画像をデスクトップに書き出す　*************

Dim objShell As Object
Dim desktopPath As String
Dim tempZipPath As String
Dim tempXmlPath As String

Const ssfDESKTOP = 0

'選択画像の名前を取得
'画像の存在するシートに対応したrelationファイルから、drawingNを特定し
'必要なファイルをテンポラリにコピーして、当コードで情報を取得する

'下記情報を順次つなぎ合わせる必要がある
'\xl\worksheets\_rels\sheetN.xml.rels
'\xl\drawings\drawingM.xml
'\xl\drawings\_rels\drawingM.xml.rels

Sub extractSelectedPictrue()
  Dim oXMLDom As Object, nodelist As Object
  Dim i As Long, shIndex As Long
  Dim loadFile
  Dim objFolder As Object, objFile As Object
  Dim myPicture As Picture
  Dim picName As String
  Dim drawingPath As String, drawingName As String
  Dim imageDic As Object, fso As Object
  Dim imageFileName As String, myExtention As String
  Dim wbk As Workbook
  Dim objDestination As Object
  
  If TypeName(Selection) <> "Picture" Then
    MsgBox "画像を選択してから実行して下さい。"
    Exit Sub
  End If
  Set myPicture = Selection
  shIndex = ActiveSheet.Index
  'このへんはxl2010特有の可能性あり。VBAコードではPicture 1しか取得出来ないのだが、
  'ワークシート左上の名前BOXや、ブックのXML情報では図 1として収納されている。
  'xl2007ではそうではないらしい。xl2013は所有していないので不明。
  If myPicture.Name Like "Picture *" Then
    picName = "図 " & CLng(Replace(myPicture.Name, "Picture ", ""))
  Else
    picName = myPicture.Name
  End If

  Set objShell = CreateObject("Shell.Application")
  Set fso = CreateObject("Scripting.FileSystemObject") '中味のあるフォルダを削除しようとした名残
  Set oXMLDom = CreateObject("MSXML2.DOMDocument")
  Set imageDic = CreateObject("Scripting.Dictionary")
  
  oXMLDom.async = False
  oXMLDom.validateOnParse = False
  oXMLDom.resolveExternals = False
  
  'Thisworkbookを別名で保存し、拡張子をZIPに変更し解凍せずにデータを取り出す
  Set wbk = ThisWorkbook
  desktopPath = objShell.Namespace(ssfDESKTOP).Self.Path
  tempZipPath = desktopPath & "\temp.zip"
  tempXmlPath = desktopPath & "\temp.xml"
  myExtention = Right(wbk.Name, Len(wbk.Name) - InStrRev(wbk.Name, ".") + 1)
  wbk.SaveCopyAs desktopPath & "\temp" & myExtention
  If Dir(tempZipPath) <> "" Then Kill tempZipPath
  Name desktopPath & "\temp" & myExtention As tempZipPath
  
  ThisWorkbook.SaveCopyAs desktopPath & "\" & "temp.xlsm"
  If fso.FileExists(desktopPath & "\" & "temp.zip") Then fso.DeleteFile desktopPath & "\" & "temp.zip"
  Name desktopPath & "\" & "temp.xlsm" As desktopPath & "\" & "temp.zip"
  
  'sheetNに対応するdrawingM.xmlをsheetN.xml.relsから取得する
  'ここでのNはシートの並び順に対応したSheet.Indexに合致
  'Mは、シートのIndexに関係なく、1から順次生成される
  ExtractFile "\xl\worksheets\_rels\sheet" & CStr(shIndex) & ".xml.rels"
  loadFile = oXMLDom.Load(tempXmlPath)
  Set nodelist = oXMLDom.DocumentElement.SelectNodes("//Relationship")
  drawingPath = nodelist.Item(0).getAttribute("Target")
  drawingName = Right(drawingPath, Len(drawingPath) - InStrRev(drawingPath, "/"))
  
  'get relationship with imageName(at Worksheet) and rId
  ExtractFile "\xl\drawings\" & drawingName
  loadFile = oXMLDom.Load(tempXmlPath)
  
  Set nodelist = oXMLDom.DocumentElement.SelectNodes("/xdr:wsDr/xdr:twoCellAnchor/xdr:pic/xdr:nvPicPr/xdr:cNvPr")
  For i = 0 To nodelist.Length - 1
    If nodelist.Item(i).getAttribute("name") = picName Then
      '方針変更前の名残で連想配列を使っていますが、一個しか要素は入りません...
      imageDic.Add nodelist.Item(i).ParentNode.NextSibling.FirstChild.getAttribute("r:embed"), nodelist.Item(i).getAttribute("name")
    End If
  Next i

  'get relationship with rId and ImageFile
  ExtractFile "\xl\drawings\_rels\" & drawingName & ".rels"
  loadFile = oXMLDom.Load(tempXmlPath)
  
  '画像ファイルの取り出し
  Set nodelist = oXMLDom.DocumentElement.SelectNodes("/Relationships/Relationship")
  Set objFolder = objShell.Namespace(tempZipPath & "\xl\media\")
  Set objDestination = objShell.Namespace(ssfDESKTOP)

  For i = 0 To nodelist.Length - 1
    If imageDic(nodelist.Item(i).getAttribute("Id")) = picName Then
      imageFileName = nodelist.Item(i).getAttribute("Target")
      imageFileName = Right(imageFileName, Len(imageFileName) - InStrRev(imageFileName, "/"))
      For Each objFile In objFolder.items
        If objFile.Name = imageFileName Then
          objDestination.CopyHere objFile
          Exit For
        End If
      Next objFile
      MsgBox "デスクトップに " & imageFileName & "　を保存しました"
    End If
  Next i
  fso.DeleteFile tempZipPath
  fso.DeleteFile tempXmlPath
  Set imageDic = Nothing
  Set fso = Nothing
  Set objShell = Nothing
  Set oXMLDom = Nothing
End Sub

'圧縮フォルダ中の指定したパスのファイルをデスクトップに取り出してtemp.xmlという名前に改名する
Private Sub ExtractFile(targetFilePath As String)
  Dim objFolder As Object, myFile As Object
  Dim objDestination As Object
  Dim targetFolderPath As String
  Dim targetFileName As String
   
  targetFolderPath = Left(targetFilePath, InStrRev(targetFilePath, "\"))
  targetFileName = Right(targetFilePath, Len(targetFilePath) - InStrRev(targetFilePath, "\"))
  
  Set objFolder = objShell.Namespace(tempZipPath & targetFolderPath)
  Set objDestination = objShell.Namespace(ssfDESKTOP)
  
  'ファイル名直指定ではうまくいかないのでParentを指定して、ファイル名で選び出す
  For Each myFile In objFolder.items
    If myFile.Name = targetFileName Then
      objDestination.CopyHere myFile
      Exit For
    End If
  Next myFile
  If Dir(tempXmlPath) <> "" Then Kill tempXmlPath
  Name desktopPath & "\" & targetFileName As tempXmlPath
End Sub
コンテンツリストに戻る 



'************** リンク画像を埋め込み画像に変換　*************

Dim objShell As Object
Dim desktopPath As String
Dim tempZipPath As String
Dim tempXmlPath As String

Const ssfDESKTOP = 0

'選択画像の名前を取得
'画像の存在するシートに対応したrelationファイルから、drawingNを特定し
'必要なファイルをテンポラリにコピーして、当コードで情報を取得する

'下記情報を順次つなぎ合わせる必要がある
'\xl\worksheets\_rels\sheetN.xml.rels
'\xl\drawings\drawingM.xml
'\xl\drawings\_rels\drawingM.xml.rels

Sub changeLink2EmbededPictrue()
  Dim oXMLDom As Object, nodelist As Object
  Dim i As Long, shIndex As Long
  Dim loadFile
  Dim objFolder As Object, objFile As Object
  Dim myPicture As Picture, newPicture As Shape
  Dim drawingPath As String, drawingName As String
  Dim imageDic As Object, fso As Object
  Dim imageFileName As String, myExtention As String
  Dim wbk As Workbook, mySheet As Worksheet
  Dim mykeys As Variant
  Dim imageId As String, imageName As String
  Dim myWidth As Long, myHeight As Long
  Dim myLeft As Long, myTop As Long

  Set objShell = CreateObject("Shell.Application")
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set oXMLDom = CreateObject("MSXML2.DOMDocument")
  Set imageDic = CreateObject("Scripting.Dictionary")
  
  oXMLDom.async = False
  oXMLDom.validateOnParse = False
  oXMLDom.resolveExternals = False
  
  '目的workbookを別名で保存し、拡張子をZIPに変更し解凍せずにデータを取り出す
  desktopPath = objShell.Namespace(ssfDESKTOP).Self.Path
  Set wbk = Workbooks.Open(desktopPath & "\samplePicBook.xlsx")
  
  tempZipPath = desktopPath & "\temp.zip"
  tempXmlPath = desktopPath & "\temp.xml"
  myExtention = Right(wbk.Name, Len(wbk.Name) - InStrRev(wbk.Name, ".") + 1)
  wbk.SaveCopyAs desktopPath & "\temp" & myExtention
  If Dir(tempZipPath) <> "" Then Kill tempZipPath
  Name desktopPath & "\temp" & myExtention As tempZipPath
  
  For Each mySheet In wbk.Worksheets
  
    'sheetNに対応するdrawingM.xmlをsheetN.xml.relsから取得する
    'ここでのNはシートの並び順に対応したSheet.Indexに合致
    'Mは、シートのIndexに関係なく、1から順次生成される
  
    shIndex = mySheet.Index
    ExtractFile "\xl\worksheets\_rels\sheet" & CStr(shIndex) & ".xml.rels"
    loadFile = oXMLDom.Load(tempXmlPath)
    Set nodelist = oXMLDom.DocumentElement.SelectNodes("//Relationship")
    drawingPath = nodelist.Item(0).getattribute("Target")
    drawingName = Right(drawingPath, Len(drawingPath) - InStrRev(drawingPath, "/"))
    
    'get relationship with imageName(at Worksheet) and rId
    ExtractFile "\xl\drawings\" & drawingName
    loadFile = oXMLDom.Load(tempXmlPath)
    
    Set nodelist = oXMLDom.DocumentElement.SelectNodes("/xdr:wsDr/xdr:twoCellAnchor/xdr:pic/xdr:nvPicPr/xdr:cNvPr")
    For i = 0 To nodelist.Length - 1
      If Not IsNull(nodelist.Item(i).ParentNode.NextSibling.FirstChild.getattribute("r:link")) Then
        imageDic.Add nodelist.Item(i).ParentNode.NextSibling.FirstChild.getattribute("r:link"), nodelist.Item(i).getattribute("name")
      End If
    Next i
    'Link画像があるとき
    If imageDic.Count > 0 Then
      'get relationship with rId and ImageFile
      ExtractFile "\xl\drawings\_rels\" & drawingName & ".rels"
      loadFile = oXMLDom.Load(tempXmlPath)
      
      '画像リンク情報の取り出し
      Set nodelist = oXMLDom.DocumentElement.SelectNodes("/Relationships/Relationship")
      For i = 0 To nodelist.Length - 1
        imageId = nodelist.Item(i).getattribute("Id")
        imageFileName = nodelist.Item(i).getattribute("Target")
        imageFileName = Right(imageFileName, Len(imageFileName) - InStrRev(imageFileName, "/"))
        imageName = Replace(imageDic(imageId), "図", "Picture")
        imageFileName = Replace(imageFileName, "%20", " ")
        '既存画像の位置、サイズ情報を保存
        Set myPicture = wbk.Sheets(shIndex).Pictures(imageName)
        myTop = myPicture.Top
        myLeft = myPicture.Left
        myWidth = myPicture.Width
        myHeight = myPicture.Height
        '既存リンク画像を削除して埋め込む。ここでnewPictureはPicture型では型違いとなる。
        myPicture.Delete
        Set newPicture = mySheet.Shapes.AddPicture(Filename:=imageFileName, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=myLeft, Top:=myTop, Width:=myWidth, Height:=myHeight)
      Next i
    End If
    '連想配列初期化
    imageDic.RemoveAll
  Next mySheet
  fso.DeleteFile tempZipPath
  fso.DeleteFile tempXmlPath
  
  Set imageDic = Nothing
  Set fso = Nothing
  Set objShell = Nothing
  Set oXMLDom = Nothing
End Sub

'圧縮フォルダ中の指定したパスのファイルをデスクトップに取り出してtemp.xmlという名前に改名する
Private Sub ExtractFile(targetFilePath As String)
  Dim objFolder As Object, myFile As Object
  Dim objDestination As Object
  Dim targetFolderPath As String
  Dim targetFileName As String
   
  targetFolderPath = Left(targetFilePath, InStrRev(targetFilePath, "\"))
  targetFileName = Right(targetFilePath, Len(targetFilePath) - InStrRev(targetFilePath, "\"))
  
  Set objFolder = objShell.Namespace(tempZipPath & targetFolderPath)
  Set objDestination = objShell.Namespace(ssfDESKTOP)
  
  'ファイル名直指定ではうまくいかないのでParentを指定して、ファイル名で選び出す
  For Each myFile In objFolder.items
    If myFile.Name = targetFileName Then
      objDestination.CopyHere myFile
      Exit For
    End If
  Next myFile
  If Dir(tempXmlPath) <> "" Then Kill tempXmlPath
  Name desktopPath & "\" & targetFileName As tempXmlPath
End Sub
コンテンツリストに戻る 


'再圧縮して拡張子を変更してエクセルファイルに戻す際、解凍時生成されたフォルダでなく、
'その中のファイル群を圧縮しないと、エクセルで開く際にエラーになってしまうので要注意

Sub changeLink()
  Dim oXMLDom As Object, nodelist As Object, reader As Object, writer As Object
  Dim i As Long, j As Long
  Dim myNodeName As String
  Dim loadFile
  Dim externalFlag As Boolean
  Dim linkFilePath As String, originalLink As String, targetFilePath As String
  Dim filename As String, newPath As String, newURL As String
  
  Const tempFilePath As String = "c:\temp.xml"
  
  Set oXMLDom = CreateObject("MSXML2.DOMDocument")
  Set reader = CreateObject("MSXML2.SAXXMLReader")
  Set writer = CreateObject("MSXML2.MXXMLWriter")
  oXMLDom.async = False
  oXMLDom.validateOnParse = False
  oXMLDom.resolveExternals = False
  'Worksheets(1)のみ対応
  targetFilePath = "C:\Documents and Settings\hoge\デスクトップ\myUnzipFolder\xl\drawings\_rels\drawing1.xml.rels"
  loadFile = oXMLDom.Load(targetFilePath)
  newPath = "file:///C:\Documents and Settings\hoge\デスクトップ\Sample Pictures"
  Set nodelist = oXMLDom.DocumentElement.SelectNodes("//Relationship")
  
  If nodelist.Length > 0 Then
  For i = 0 To nodelist.Length - 1
    For j = 0 To nodelist.Item(i).Attributes.Length - 1
      myNodeName = nodelist.Item(i).Attributes(j).nodename
      Select Case myNodeName
        Case "Target"
          linkFilePath = nodelist.Item(i).Attributes.getNamedItem(myNodeName).NodeValue
        Case "TargetMode"
          If nodelist.Item(i).Attributes.getNamedItem(myNodeName).NodeValue = "External" Then externalFlag = True
      End Select
    Next j
    If externalFlag Then
      'ここにリンクの書き換え
      'スペースを%20に変更している
      filename = Right(linkFilePath, Len(linkFilePath) - InStrRev(linkFilePath, "\"))
      filename = Replace(filename, "%20", Chr(&H20))
      newURL = newPath & "\" & filename
      newURL = Replace(newURL, Chr(&H20), "%20")
      'Target属性の変更
      Call nodelist.Item(i).setAttribute("Target", newURL)
    End If
    externalFlag = False
  Next i
  End If
  
  writer.indent = False
  'writer.Encoding = "utf-8" '昔は指定しても機能しなかった。最近の状況は不明です。
  writer.standalone = True
  Set reader.contentHandler = writer
  'お約束
  Call reader.putProperty("http://xml.org/sax/properties/lexical-handler", writer)
  oXMLDom.preserveWhiteSpace = False
  reader.Parse oXMLDom.XML
  Set oXMLDom = Nothing
  'UTF-8に変換して保存
  Call adoSaveText(tempFilePath, writer.output, "UTF-8")
  FileCopy tempFilePath, targetFilePath
  Set writer = Nothing
  Set reader = Nothing
End Sub

'========================================================
'ADO.streamを使ってXMLDocumentをUTF-8で書き出す
Private Function adoSaveText(filename, text, charset)
  Dim Stream
  Dim bin() As Byte
  Dim destBuf As String
  
  Set Stream = CreateObject("ADODB.Stream")
  destBuf = Replace(text, "UTF-16", charset)
  Stream.Type = adTypeText
  Stream.charset = charset
  Stream.Open
  Stream.WriteText (destBuf)
  'BOM削除
  Stream.Position = 0
  Stream.Type = adTypeBinary
  Stream.Position = 3
  bin = Stream.Read
  Stream.Close
  Stream.Open
  Stream.Write bin
  Stream.SaveToFile filename, adSaveCreateOverWrite
  Stream.Close
End Function




'Microsoft Shell Controls And Automation　に参照設定
'Microsoft Scripting Runtime　に参照設定（こちらはついでにしただけ）

'************** エクセルブックの圧縮フォルダーの構成を取得する　**************
Dim objShell As Shell
Dim myRow As Long, myColumn As Long

Sub extractImageEx()
  'Objectの型はTypeNameで取得して把握
  Dim fso As Scripting.FileSystemObject
  Dim objFiles As Shell32.Folder3
  Dim objFile As Shell32.FolderItem
  Dim vZipFile As String, vDestination As String
  Dim getDesktopPath As String

  Set objShell = New Shell
  Set fso = New Scripting.FileSystemObject
  myRow = 1
  myColumn = 1
  ActiveSheet.Cells.ClearContents
  'この.Selfがインテリセンスで表示されないで、見つけるのに苦労した
  'ssfDESKTOPはオブジェクトブラウザで調査
  getDesktopPath = objShell.Namespace(ssfDESKTOP).Self.Path
  
  'ThisWorkbookを別名で保存し、拡張子をZipにRename
  ThisWorkbook.SaveCopyAs getDesktopPath & "\temp.xlsm"
  If Dir(getDesktopPath & "\temp.zip") <> "" Then Kill getDesktopPath & "\temp.zip"
  Name getDesktopPath & "\temp.xlsm" As getDesktopPath & "\temp.zip"
  vZipFile = getDesktopPath & "\temp.zip"

  ' ファイルシステムオブジェクトおよびシェルオブジェクト作成
  Set fso = New Scripting.FileSystemObject
  Set objShell = New Shell

  Set objFiles = objShell.Namespace(vZipFile)
  analyseFolder objFiles
End Sub

Sub analyseFolder(myFolder As Shell32.Folder3)
  Dim mySubFolder As Shell32.Folder3
  Dim myFile As Shell32.FolderItem2
  Dim myFullPath As String
  
  For Each myFile In myFolder.items
    ActiveSheet.Cells(myRow, myColumn).Value = myFile.Name
    myRow = myRow + 1
    If myFile.IsFolder Then
      myFullPath = myFile.Path
      '都度NamespaceでFolder Objectを取得してやらないと、適当なメンバ無し。またキャストもできないので。
      Set mySubFolder = objShell.Namespace(myFullPath)
      If Not mySubFolder Is Nothing Then
        myColumn = myColumn + 1
        analyseFolder mySubFolder
        myColumn = myColumn - 1
      End If
    End If
  Next myFile
End Sub

'ワークシートが3枚あり、それぞれに画像を埋め込んであるファイルの構造
'[Content_Types].XML
'_rels
'  .rels
'xl
'  _rels
'    Workbook.XML.rels
'  Workbook.XML
'  Worksheets
'    Sheet4.XML
'    Sheet3.XML
'    Sheet2.XML
'    _rels
'      Sheet1.XML.rels
'      Sheet2.XML.rels
'      Sheet3.XML.rels 'こちらにSheet3と、Drawing3.XMLとのrelationを記述
'    Sheet1.XML
'  Drawings
'    _rels
'      drawing1.XML.rels
'      drawing2.XML.rels
'      drawing3.XML.rels 'こちらに"../media/" 内の画像ファイルとrIdの対応を記述
'    drawing1.XML
'    drawing2.XML
'    drawing3.XML 'こちらに「図1」といった名前と、埋め込み・リンクの別、rIdを記述
'  VBAProject.bin
'  media
'    image3.JPG
'    image1.GIF
'    image2.JPG
'    image4.GIF
'  sharedStrings.XML
'  Styles.XML
'  Theme
'    theme1.XML
'docProps
'  app.XML
'  core.XML