[[20210827145307]]　『エクセルのマクロを使用してエクセル内の画像の保』（JIN）　ページの最後に飛ぶ

『エクセルのマクロを使用してエクセル内の画像の保存について』（JIN）

下記はネットで検索して見つけたコードになります。
Sub 画像()
Range("A1:G23").CopyPicture
Range("F1").PasteSpecial
Range("A1:G23").Select
End Sub

上記は、選択範囲を図としてコピーして貼り付けるマクロになります。
下記は、選択範囲の上にある図を画像ファイルとして保存するマクロになります。
しかし、私の知識では解読が全くできないので質問です。
因みに紹介アドレスは下記になります。
https://www.shegolab.jp/entry/excel-macro-save-image

おしえて頂きたい事は、
保存場所を指定してダイアログを表示させないで自動保存したい事です
また保存するファイル名をエクセル内の指定セルを読む形にしたいと思ってます。

ここからアドレスに記載があるコードです
Sub 画像をファイルに保存する()

    Dim selectionType As Variant
    selectionType = TypeName(Selection)
    Select Case selectionType
    Case "Picture", "ChartArea", "Range", "DrawingObjects"
        saveAsImage Selection, "export" & selectionType
    Case Else
        saveAsImage Selection, "exportDefault"
    End Select
End Sub

Private Sub saveAsImage(srcObject As Object, exportMethod As String)
On Error GoTo finalize:

    Const cTmpDir = 2
    Const cFileType = 2

    Dim fso As Object
    Dim shl As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set shl = CreateObject("Shell.Application")

    Dim tmpDir As Object
    Set tmpDir = fso.CreateFolder(fso.GetSpecialFolder(cTmpDir) & "\" & fso.GetTempName())

    Dim tmpBook As Workbook
    Dim imgObj As Shape
    Dim imgName As Variant

    Set tmpBook = Workbooks.Add
    'ActiveWindow.Visible = False

    Set imgObj = Application.Run(exportMethod, srcObject, tmpBook.ActiveSheet)
    If imgObj Is Nothing Then GoTo finalize

    imgName = imgObj.Name
    Set imgObj = Nothing

    tmpBook.Close SaveChanges:=True, Filename:=tmpDir.Path & "\image.xlsx"
    Set tmpBook = Nothing

    With shl.Namespace(tmpDir.Path)
        .ParseName("image.xlsx").Name = "image.zip"      '保存場所？
        .CopyHere tmpDir.Path & "\image.zip\xl\media"
    End With

    Dim imgFile As Object
    Dim imgType, imgExt As Variant

    With shl.Namespace(tmpDir.Path & "\media")
        Set imgFile = .Items.Item(0)
        imgType = .GetDetailsOf(imgFile, cFileType)
        imgExt = LCase(fso.GetExtensionName(imgFile.Name))
    End With

    imgExt = IIf(imgExt = "tmp", "png", imgExt) ' Screenshot

    Dim saveFileName, fileFilter As Variant
    saveFileName = imgName & "." & imgExt
    fileFilter = imgType & " (*." & imgExt & "),." & imgExt

    saveFileName = Application.GetSaveAsFilename(saveFileName, fileFilter)
    If saveFileName <> False Then
        imgFile.Name = fso.GetFileName(saveFileName)
        shl.Namespace(fso.GetParentFolderName(saveFileName)).MoveHere imgFile
    End If

finalize:

    If Err <> 0 Then MsgBox TypeName(srcObject) & "の画像ファイル作成に失敗しました。" & vbCr & Err.Description, vbOKOnly + vbCritical
    If Not tmpBook Is Nothing Then tmpBook.Close SaveChanges:=False

    If fso.FolderExists(tmpDir) Then
        fso.DeleteFolder tmpDir
    End If
End Sub

Private Function exportPicture(pct As Picture, sht As Worksheet) As Shape

    pct.Copy
    sht.Paste
    Set exportPicture = sht.Shapes(1)
    exportPicture.Name = pct.Name
End Function

Private Function exportChartArea(cht As ChartArea, sht As Worksheet) As Shape

    cht.Copy
    sht.PasteSpecial Format:="図 (拡張メタファイル)"
    Set exportChartArea = sht.Shapes(1)
    exportChartArea.Name = cht.Name
End Function

Private Function exportRange(ByVal rng As Range, sht As Worksheet) As Shape
On Error GoTo failure

    rng.CopyPicture xlScreen, xlBitmap  ' PNG
    sht.Paste
    Set exportRange = sht.Shapes(1)
    exportRange.Name = rng.Worksheet.Name
    Exit Function
failure:
    MsgBox "選択セル範囲が大きすぎます", vbOKOnly + vbExclamation
End Function

Private Function exportDrawingObjects(drw As DrawingObjects, sht As Worksheet) As Shape

    drw.CopyPicture  ' EMF
    sht.Paste
    Set exportDrawingObjects = sht.Shapes(1)
     exportDrawingObjects.Name = "図形たち"
End Function

Private Function exportDefault(obj As Object, sht As Worksheet) As Shape
On Error GoTo failure:

    obj.CopyPicture     ' EMF
    sht.Paste
    Set exportDefault = sht.Shapes(1)
    exportDefault.Name = obj.Name
    Exit Function
failure:
    MsgBox TypeName(obj) & "には対応していません。", vbOKOnly + vbExclamation
End Function

下記は私が以前に教わったデスクトップに保存するマクロです
これが使えるのかもっといいものがあるのか分かりませんが一応載せます

    Dim Path As String, kensaku As String, WSH
    Set WSH = CreateObject("WScript.Shell")
   ' Path = WSH.SpecialFolders("Desktop") & "\"
    kensaku = Sheets("Sheet2").Range("J5").Value
    ActiveWorkbook.SaveAs FileName:=Path & kensaku
    Set WSH = Nothing

下記は、保存した後に画像を削除する必要があるので
削除する為のマクロですが…「Picture 1」とありますが、画像保存は何度もあるのでその際にどうすれば「Picture 2」「Picture 3」と対応するのか教えてください。

Sub 画像削除()

    ActiveSheet.Shapes.Range(Array("Picture 1")).Select
    Selection.Delete
    Range("I12").Select
End Sub

以上何個も何個もありすみませんが、よろしくお願い致します。

＜使用 Excel：unknown、使用 OS：Windows8 ＞

 1.保存場所
　saveFileName = Application.GetSaveAsFilename(saveFileName, fileFilter)
 の部分です。

 saveFileName = "c:\[デスクトップパス]\[ファイル名].jpg"
 みたいにしてみてはどうでしょう。

 2.画像の削除
 例えばA1セル上にある画像なら消す・・
 Dim Shp         As Shape
 For Each Shp In Shapes
   If Shp.Type = msoPicture Then 
      If Not Intersect(Shp.TopLeftCell, Range("A1") Is Nothing Then
         Shp.Delete
      End If
   End If
 Next Shp
（通りすがり助六） 2021/08/27(金) 16:39

 >選択範囲の上にある図を画像ファイルとして保存

1）普通に名前を付けて保存。
2）拡張子を「zip」に変更
3）解凍ソフトで回答

とするとファイル内の図が画像ファイルとして取り出せます。

というようなことではだめなんですよね。。。。

（まっつわん） 2021/08/27(金) 17:15

通りすがり助六さん、ありがとうございます。
助かりました。

まっつわんさん、名前を付けて保存ができないんです…

でも、助かりました。
無事解決できました。
ありがとうございました。
（JIN） 2021/08/31(火) 11:58

解決されたようで何より。
2番目の質問については、
finalize:以下の部分で、Errが0のときにsrcObjectをdeleteすることでよいと思います。

（余談）
まっつわんさんのコメントにある方針をそのままマクロにしたものですね。
ただし、画像ひとつ（選択中のもの）に限定していますが。

Excelブックからの画像を取りだしたい、という質問は結構あります。
今回のコードは、画像が一つの場合に限定していますが、
複数の場合にも拡張できそうな気がします。
Shell.Applicationを使っていますが、これは、temporaryファイルの作成や
ファイルのコピーや移動のために使用しているようですが、これでないとできない
ということでもなさそうです。
ただし、画像ファイルの取り出しが拡張子との関係で面倒かもしれませんが。

（γ） 2021/09/05(日) 14:17

横から失礼

Shell.Applicationを使っていますが、

Shell.Application(エクスプローラ)は、Zipファイル内へ透過的にアクセスできるので使用しています。
.xlsx を　.zip に変更後、解凍することなしに画像をとりだしています。

With shl.Namespace(tmpDir.Path)

        .ParseName("image.xlsx").Name = "image.zip"      ' ZIP ファイルに変更
        .CopyHere tmpDir.Path & "\image.zip\xl\media"   '  ZIPファイル内のmediaフォルダをカレントにコピー
 End With

Microsoft 的には非推奨で使えなくなるリスクがあるので、業務開発では素直にZIP展開した方がいいでしょう。
https://support.microsoft.com/ja-jp/topic/copyhere-%E3%83%A1%E3%82%BD%E3%83%83%E3%83%89%E3%81%8B%E3%82%89-zip-%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E5%87%A6%E7%90%86%E3%81%99%E3%82%8B%E3%81%93%E3%81%A8%E3%81%AF%E3%81%A7%E3%81%8D%E3%81%BE%E3%81%9B%E3%82%93-a393a8b4-3330-5d88-c850-d634744fdb4a

（シーゴ） 2021/09/10(金) 15:27

コメント返信：

[ 一覧(最新更新順) ]

[[20210827145307]] 『エクセルのマクロを使用してエクセル内の画像の保』（JIN） ページの最後に飛ぶ

[[20210827145307]]　『エクセルのマクロを使用してエクセル内の画像の保』（JIN）　ページの最後に飛ぶ