[[20211130224619]]　『画像保存』（BUDS）　ページの最後に飛ぶ

『画像保存』（BUDS）

シート20にある画像すべてを、シート１の"P4"の文字のフォルダを作ってそのフォルダに保存したいです。
調べながらやりコードがでたらめだと重々承知なのですが、うまくいかないため質問させていただきます。コードも意味がわかっていない部分があります。
自分の中の解釈ですが、今のコードですとグラフに残したい範囲を貼り付けそれを保存すると解釈しているのですが、セル範囲を指定せずグラフに貼り付けなくてもできるのかお聞きしたいのとどう直せばいいのかお聞きしたいです。
' 範囲指定された部分を画像として保存

  Dim Pic As Shape
     For Each Pic In Sheet20.Shapes
      If Pic.Type = msoLinkedPicture Then
    Set Pic = ○○ 'セルで範囲を指定するにはこの文字→Selection
    Pic.CopyPicture appearance:=xlScreen, Format:=xlPicture

End If
Next
の部分をどうにかしようと悩んでましたがわからずとりあえずのコードです。

Private Sub CommandButton3_Click()

  ' エラー処理
    On Error GoTo ErrorProc
'フォルダの存在確認をしてなければ作成する
Dim objFso As Object
Set objFso = CreateObject("Scripting.FileSystemObject")

If objFso.FolderExists(ThisWorkbook.Path & Sheet1.Range("P4")) Then

    MsgBox Sheet1.Range("P4") & "は存在しています"
Else
    objFso.CreateFolder (ThisWorkbook.Path & Sheet1.Range("P4"))
    MsgBox Sheet1.Range("P4") & "は存在しなかったので作成しました"
 End If

Set objFso = Nothing

    Dim rg As Range
    Dim cht As Chart
    Dim Path As String
    Dim WSH As Variant
' 範囲指定された部分を画像として保存
Dim Pic As Shape
     For Each Pic In Sheet20.Shapes
      If Pic.Type = msoLinkedPicture Then
    Set Pic = ○○ 'セルで範囲を指定するにはこの文字→Selection
    Pic.CopyPicture appearance:=xlScreen, Format:=xlPicture

End If
Next

 ' Chartに画像を挿入して貼り付け
    Set cht = ActiveSheet.ChartObjects.Add(0, 0, rg.Width, rg.Height).Chart
    cht.Parent.Select  
    cht.Paste

    ' 名前を付けて保存
    Set WSH = CreateObject("WScript.Shell")
    '保存先
    outputPath = (ThisWorkbook.Path & "\" & Sheet1.Range("P4"))
    outputPath = outputPath & "/" & ".jpg"
    Set WSH = Nothing
    ' JPGとして保存
    cht.Export Filename:=outputPath, filtername:="JPG"
    cht.Parent.Delete

    MsgBox "画像作成完了しました"
    Exit Sub

ErrorProc:

    MsgBox "画像の作成に失敗しました"

End Sub

こんな感じです。よろしくお願いいたします。

＜使用 Excel：Office365、使用 OS：Windows10 ＞

何がしたいか読み解けません。
画像？グラフ？・・・

まず、手順を箇条書きにしましょう。
で、どこで詰まるか確認。
詰まる箇所を更に細分化して箇条書き。

そうすれば、分からない事が絞られて
ご自身で調べられると思いますよ。
（tkit） 2021/12/01(水) 09:25

ありがとうございます。
・フォルダ作成
・シート上の画像をそのフォルダに保存
・・・なのですが条件にあったもの探しています。
（BUDS） 2021/12/01(水) 10:14

＞セル範囲を指定せずグラフに貼り付けなくてもできるのかお聞きしたいのとどう直せばいいのかお聞きしたいです。

いまだに直に画像保存するコードを見たことがありません。
APIつかって、何とかするのだろうとは思いますけど、
画像コピークリップボードからロードして何とかするのかな？
グラフを使った方法は、当時の苦肉の策でよくこんな事を思いついたものだと思ってました。

拡張子をzipに変えて、それを回答したフォルダにJPGファイルが入ってないですかね？
ワードだったら、名前を変えてwebページ形式(htm,html)で保存するだけですみますけど。

（疑心） 2021/12/01(水) 11:42

 ↓は試してみましたか？
https://docs.microsoft.com/ja-jp/office/vba/api/publisher.shape.saveaspicture
（tkit） 2021/12/01(水) 11:51

おお、バージョンいくつからか見てないけど。
こんなものができましたか・・・。

Shape.SaveAsPicture メソッド (Publisher)

ThisDocument.Pages(1).Shapes(1).SaveAsPicture "filename.jpg"
（疑心） 2021/12/01(水) 12:11

横入りします。

■SaveAsPictureについては、
[[20211014212045]]
が参考になります。（特定の環境で使える機能のように見受けました。）

■ご指摘がありましたが、Bookの拡張子をzipに変更して解凍し、
中にある画像ファイルを使用する、という方法もあります。
これについては、
https://www.shegolab.jp/entry/excel-macro-save-image
でマクロ実行する方法も併せて紹介されています。
（これは、
[[20210827145307]]
でも議論されました。）
（γ） 2021/12/01(水) 12:12

ご提示のコードを少し修正したら動きました。
（シート上の画像がそれぞれ保存されます）

まずは、↓をコメントアウトしてみてはいかがでしょうか。

  ' エラー処理
    On Error GoTo ErrorProc

（わからん） 2021/12/01(水) 13:21

ありがとうございます。

ThisDocument.Pages(1).Shapes(1).SaveAsPicture "filename.jpg"
・この場合ですとPages(1)はシート名？Shapes(1)は複数あった場合どうなりますか？

・Zipで保存する方法見てみましたが試していなく見てみます。

・' エラー処理

    On Error GoTo ErrorProcをコメントアウトしてみましたが、指定のフォルダには真っ白い画像で".jpg"というものがありました。写真ではなかったです。。。でも保存することはできました。

（BUDS） 2021/12/01(水) 16:59

＞ On Error GoTo ErrorProcをコメントアウトしてみましたが、指定のフォルダには真っ白い画像で".jpg"というものがありました。写真ではなかったです。。。でも保存することはできました。

提示されたコードなら、エラーがでるはずですが、修正したのでしょうか。
修正後のコードを提示されてはいかがでしょうか。

（わからん） 2021/12/01(水) 18:38

 参考に
Excelのファイル形式を利用して図や画像をファイルに取り出す：Excelの基本操作
http://www4.synapse.ne.jp/yone/excel/excel_graph_file2.html

（ピンク） 2021/12/01(水) 21:57

皆様ありがとうございます。

わからんさん
修正したのは

Set cht = ActiveSheet.ChartObjects.Add(0, 0, rg.Width, rg.Height).Chart
を

Set cht = ActiveSheet.ChartObjects.Add(0, 0, Pic.Width, Pic.Height).Chart

  'On Error GoTo ErrorProc
'ErrorProc: 
   ' MsgBox "画像の作成に失敗しました"
をコメントアウトしたら、シート上には写真が2枚あるのに　.jpg という名前のもの1枚しかフォルダにはありませんでした。

また色々な方法があるのですね。疑心さんご提示のもの、ピンクさんのご提示のもの、γさんご提示のものまだ試して無いのですがどれを試そうか迷ってます。
（BUDS） 2021/12/02(木) 05:11

＞シート上には写真が2枚あるのに　.jpg という名前のもの1枚しかフォルダにはありませんでした。

画像を保存するコードが、ループの外にあるためかと思います。

それを修正してループの中にいれたとしても、ファイル名の設定が適切でないので、
２枚目以降上書されてしまい、１つのファイルしかできません。

その他にも、フォルダの設定時に「\」がなくて、想定と違うフォルダが作られるなども
修正する必要があります。

（わからん） 2021/12/02(木) 08:13

γさんのコメントがスルーされている？

引用されているサイトを参考にしました。
必要そうな部分だけのつまみ食いで、実際はよく理解できていません。

 Sub test()
    Dim dstFolder As String
    Dim srcZip As String

    dstFolder = ThisWorkbook.Path & "\" & Sheet1.Range("P4").Value
    srcZip = ThisWorkbook.FullName & ".zip"

    Sheet20.Copy
    With ActiveWorkbook
        .SaveAs srcZip
        .Close False
    End With

    With CreateObject("Shell.Application")
        .Namespace((dstFolder)).CopyHere .Namespace((srcZip & "\xl\media")).Items()
    End With

    Kill srcZip

 End Sub

（マナ） 2021/12/02(木) 08:20

　修正

 ＞.Namespace((srcZip & "\xl\media")).Items()
　  ↓
　.Namespace(srcZip & "\xl\media").Items()

（マナ） 2021/12/02(木) 09:01

選択範囲内の画像に限定して、というのは誤解だったか。
Sheet20にあるすべての画像ということなら、下記でしょうか。連番を付けて書き出します。
Sheet1のシートモジュールに以下をコピーして、CommandButton1をクリックです。

 Private Sub CommandButton1_Click()
     Dim folder As String
     Dim myRange As Range
     Dim pic As Shape
     Dim outputPath As String
     Dim k As Long

     'フォルダの存在確認をしてなければ作成する
     folder = getfolder(Me.Range("P4"))

     For Each Pic In Sheet20.Shapes
         If pic.Type = msoLinkedPicture Or pic.Type = msoPicture Then '他にもあるかも。
             k = k + 1
             '保存ファイルパス
             outputPath = folder & "\" & Format(k, "000") & ".jpg"
             Call savePicture(pic, outputPath)    ' 画像の保存
         End If
     Next
     MsgBox "画像作成完了しました"
 End Sub

 Function savePicture(pic As Shape, outputPath As String)
     Dim wd As Double, ht As Double
     Dim cht As Chart

     wd = pic.Width
     ht = pic.Height
     ' Chartに画像を挿入して貼り付け
     Set cht = Sheet1.ChartObjects.Add(0, 0, wd, ht).Chart
     pic.CopyPicture appearance:=xlScreen, Format:=xlPicture
     cht.Parent.Select   '★★
     cht.Paste
     '保存
     cht.Export Filename:=outputPath, filtername:="JPG"
     cht.Parent.Delete
 End Function

 Function getfolder(rng As Range) As String
     Dim folder As String
     Dim objFso As Object

     folder = ThisWorkbook.path & "\" & rng.Value
     Set objFso = CreateObject("Scripting.FileSystemObject")
     If objFso.FolderExists(folder) Then
         MsgBox getfolder & "は存在しています"
     Else
         objFso.CreateFolder folder
         MsgBox getfolder & "は存在しなかったので作成しました"
     End If
     Set objFso = Nothing
     getfolder = folder
 End Function

【補足】
(1)★★をつけた行は、本来は不要のはずと思って、無くしていたら、
いくらやっても空白の画像しか保存できない。ステップ実行だとうまくいく。
処理のタイミングの問題かと思い、DoEventsなどを入れまくってみたが、改善せず。
何の気なしに、最初のコードを見ると、★★の行がある。
入れてみたら、なんと成功。
いまだに理屈は分かっていないが、世の中そんなもので、結果が出ればこっちのものです。

(2)私の古い記憶だと、Chart経由だと、ヘリの部分が白く残ったりしたものだが、
今どきはそれは解消されたようです。

マナさんのZIPファイル解凍法はコンパクトでいいですね。
懸念点は、MicrosoftがCopyHereの動作は保証できない（将来に向けてということでしょうが）と
言っていることぐらいですか。
でも動作しているうちは使えばいいですよね。

質問者さんは、別に試してもらわなくても結構。
広く閲覧者に向けて書いていますので。
（γ） 2021/12/02(木) 09:21

 >範囲指定された部分を画像として保存
 >  Set Pic = ○○ 'セルで範囲を指定するにはこの文字→Selection
 セル範囲をjpgで保存するのなら
 保存先はデスクトップにしています
 Private Sub CommandButton1_Click()
    Dim myPath As String
    Dim myRang As Range

    myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    '図形でエクスポートする範囲
    Set myRang = Selection
    myRang.CopyPicture Appearance:=xlScreen, Format:=xlPicture
    With ActiveSheet.ChartObjects.Add(0, 0, myRang.Width, myRang.Height).Chart
        .Parent.Select
        .Paste
        .Export Filename:=myPath & "\テスト.jpg"
        .Parent.Delete
    End With
 End Sub

（ピンク） 2021/12/02(木) 17:20

 >シート20にある画像すべてを、
 これもデスクトップ上にエクスポートしました。
 Sub Test2()
    Dim pic As Picture
    Dim myPath As String
    Dim sW As Single
    Dim sH As Single

    myPath = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    For Each pic In Sheet20.Pictures
        With pic
            .CopyPicture Appearance:=xlScreen, Format:=xlPicture
            sW = .Width
            sH = .Height
        End With
        With ActiveSheet.ChartObjects.Add(0, 0, sW, sH).Chart
            .Parent.Select
            .Paste
            .Export Filename:=myPath & "\" & .Name & ".jpg"
            .Parent.Delete
        End With
    Next
    MsgBox "終わり"
 End Su

（ピンク） 2021/12/02(木) 17:26

コメント返信：

[ 一覧(最新更新順) ]

[[20211130224619]] 『画像保存』（BUDS） ページの最後に飛ぶ

[[20211130224619]]　『画像保存』（BUDS）　ページの最後に飛ぶ