[[20191003153839]]　『画像一括保存　VBA』（ケイ）　ページの最後に飛ぶ

『画像一括保存　VBA』（ケイ）

画像をファイルに一括保存

下記のVBAのサンプルコードを希望します

・前提
画像添付はExcelのB列に（固定）セルごとに貼り付けられます。
枚数は数百枚で毎回変わります

・仕様
1.画像のあるExcelブックを開く（開いた時間が一番新しいExcelブックのみを対象）他にも開いてるExcelブックがあっても対象外とする。
2.画像はすべてB列にあるためB列（すべて）を指定
※ワークシートが２つあるため1と２選べる仕様
3.B列にある画像を上から順番に保存。
デスクトップにファイルを新規で追加して保存させる、ファイル名"画像サンプル”とする（画像の種類は.emf.png.jpg.jpegを対象とする)
4.画像のファイル名は固定imageで上から順番に通し番号をつける
例）"image1"　.=ファイルの種類とする
例）image1.jpeg image2.pmg image3.jpeg image4.emfなど
5,保存された画像は閉じずに開いた状態とする

お手数をおかけいたしますが
ご教授よろしくお願いいたします。

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

＞下記のVBAのサンプルコードを希望します
はじめから「作業発注であること」が書いてあって潔くていいですね。

ただ、私は受注する気が無いので思いついたことだけ。

■１
＞開いた時間が一番新しいExcelブックのみを対象
ワークブックコレクションの最後のブックと考えればよいです。

 ※イミディエイトに↓を入力すると確認できます。
 ? workbooks(workbooks.Count).Name

■２
＞※ワークシートが２つあるため1と２選べる仕様
inputboxで処理するか、フォームみたいなものを作ってトグルスイッチで選ばせるかでしょうか。

■３
＞2.画像はすべてB列にあるためB列（すべて）を指定
ワークブックオブジェクト．ワークシートオブジェクト.Range("B:B")　ですね

■４
＞B列にある画像を上から順番に保存。
普通に考えて問題ないとおもいます。下からとか、ランダムってするほうが難しい（めんどくさい）とおもいます。

■５
＞4.画像のファイル名は固定imageで上から順番に通し番号をつける
＞例）"image1"　.=ファイルの種類とする
＞例）image1.jpeg image2.pmg image3.jpeg image4.emfなど
通し番号はできるでしょうけど、エクセルに図として貼付した段階でjpg"だった"とかの情報って無くなるような・・・
（違ってたらごめんなさい）

■６
＞5,保存された画像は閉じずに開いた状態とする
意味が分かりません。

■７
たぶん作業の肝はこれですかね。
「Excelで表や挿入した図形を画像として保存する」
https://global-wing.com/activity/excel_save_pic.html

■８
まとめると、

 (1) 対象シートのB列を図ごと適当な（新規）ブックにコピペする。
 (2) コピペしたブックを保存して閉じる。
 (3) 保存したブック（ファイル）をリネームする。
 (4) 画像を取り出す。

みたいなコードを作成すれば出来る【かもしれません】
（試してないし、試す気も無いので、アイデアとして提供します。）

（もこな２） 2019/10/03(木) 18:05

もこなさん

ありがとうございます。
■８
まとめると、

 (1) 対象シートのB列を図ごと適当な（新規）ブックにコピペする。
 (2) コピペしたブックを保存して閉じる。
 (3) 保存したブック（ファイル）をリネームする。
 (4) 画像を取り出す。
上記のとおりです。画像を全て保存できればOKなのですが
なかなかむずかしいです。　個々のサンプルコードがわかる方いればご教授願いたいです。
（ケイ） 2019/10/03(木) 20:23

失礼　ちょっとミスってました。

 (1) 対象シートのB列を図ごと適当な（新規）ブックにコピペする。
 (2) 貼付したシート上のシェイプを巡回してリネームする
 (3) コピペしたブックを保存して閉じる。
 (4) 保存したブック（ファイル）をリネームする。
 (5) 画像を取り出す。

こうですね。

＞なかなかむずかしいです。
現状だと、何が難しい（どこがわからない）のか、回答者側で解らない状態なので、なかなか答えは付きづらいんじゃないですかね。何しろこちらは【質問】掲示板ですから・・・

私の思い付き案でトライするなら、並行してご自身でもわかる部分からコード化してみてはどうでしょうか？
（まぁそもそも論として、手作業でやってみて、本当にzipファイルから画像が取り出せるか確認するのが先でしょうけど・・）

（もこな２） 2019/10/03(木) 22:10

 方針だけ
  ・グラフを作る
  ・画像をグラフに貼り付ける
  ・グラフをExportする。

 以下、サンプルです。あまり真面目にやってないので、以下課題
　・グラフのShapeなので、ループどうなるかな？　グラフは別シートがいいかもしれない
　・画像サイズ（アスペクト比）の調整

 Dim ws As Worksheet, p As Shape, c As Shape

 Set ws = ActiveSheet

 For Each p In ws.Shapes
  If p.Type = msoPicture Then
     Set c = ws.Shapes.AddChart2
     p.Copy
     c.Chart.Paste
     c.Chart.Export "C:\test.jpg"
     c.Delete
  End If
 Next
（´・ω・`） 2019/10/04(金) 07:21

お二人方ご回答ありがとうございます。
ご質問なのですが
画像は手作業でいったんエクセルに貼り付けてます。この時は全画像があります。
一度エクセルに貼り付けた画像をファイルに展開して保存したときにどうも何枚か欠損してしまいます。

Excelに貼り付けたときはExcelのセルB1,B2,B3以下とりあえず500ぐらいまで同じB列のセルに
画像を貼り付けることはできます。

指定sheetのセル（B列）にある画像を対象に貼り付け先のシートに移すことはできるのでしょうか

ご教授ください
（ケイ） 2019/10/04(金) 09:21

 参考までですが

 一般機能で　画像の貼り付けられたExcel ファイルを普通に開き
 「名前を付けて保存」で　形式を「Webページ」で保存すると

 保存したフォルダに　htm ファイルと　***.files というフォルダが作成されます
 この***.files フォルダにはシートに貼り付けられた画像がpng 形式で保存されます
 （画像一つにつき表示用とサムネの2つが作成されます）

 画像のファイル名は　シートに貼り付けられた時のShape名です

 一度やってみてください

（渡辺ひかる） 2019/10/04(金) 12:22

 >「名前を付けて保存」で　形式を「Webページ」で保存
 なるほど～
 目からうろこです
（´・ω・`） 2019/10/04(金) 13:09

 ＞画像のファイル名は　シートに貼り付けられた時のShape名です

 これは嘘でした。すみません　勝手に　image001.png、image002.png
 と付けられるようですね。

（渡辺ひかる） 2019/10/04(金) 13:17

 解説はしません
 Sub test()

   SaveAllPicture ActiveSheet.Range("B:B")

 End Sub

 Sub SaveAllPicture(targetRange As Range, Optional Path As String, Optional fmt As String = """Image""00.jpg")

   Dim ws As Worksheet, tmpws As Worksheet
   Dim Pic As Shape, i As Integer
   Dim tmpchart As Shape

   Set ws = targetRange.Parent
   Set tmpws = ThisWorkbook.Worksheets.Add

   If Path = "" Then Path = ws.Parent.Path & "\"
   If Right(Path, 1) <> "\" Then Path = Path & "\"

   i = 0
   For Each Pic In ws.Shapes
       If Pic.Type = msoPicture Then
          If Not Intersect(Pic.TopLeftCell, targetRange) Is Nothing Then
             i = i + 1
             tmpws.Cells(i, 1) = Pic.Name
             tmpws.Cells(i, 2) = Pic.TopLeftCell.Row
          End If
       End If
   Next

   If i > 0 Then

      With tmpws.Sort
         .SortFields.Add Key:=tmpws.Cells(1, 2), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
         .SetRange tmpws.Cells(1, 1).CurrentRegion
         .Header = xlnow
         .Orientation = xlTopToBottom
         .SortMethod = xlPinYin
         .Apply
      End With

      i = 1
      For Each c In tmpws.Cells(1, 1).CurrentRegion.Columns(1).Cells
          Set Pic = ws.Shapes(c.Value)
          With tmpws.Shapes.AddChart2
             .Chart.FullSeriesCollection(1).Delete
             .Width = Pic.Width
             .Height = Pic.Height
             Pic.Copy
             .Chart.Paste
             .Chart.Export Path & Format(i, fmt)
             .Delete
          End With
          i = i + 1
      Next

   End If

   Application.DisplayAlerts = False
   tmpws.Delete
   Application.DisplayAlerts = True

 End Sub
（´・ω・`） 2019/10/04(金) 16:07

ありがとうございます。勉強させていただきます（^^)

（ケイ） 2019/10/04(金) 19:06

コメント返信：

[ 一覧(最新更新順) ]

[[20191003153839]] 『画像一括保存 VBA』（ケイ） ページの最後に飛ぶ

[[20191003153839]]　『画像一括保存　VBA』（ケイ）　ページの最後に飛ぶ