[[20230315152401]]　『シート内の画像を個別に保存　指定列のセルから名』（フリスク）　ページの最後に飛ぶ

『シート内の画像を個別に保存　指定列のセルから名前』（フリスク）

お力を貸して頂けないでしょうか？

Ａ列に商品名、B列に商品写真が貼り付けている状態です。
Ｂ列の商品写真を個別に保存をしたい。
保存名はＡ列を使用。

例えば
　Ａ１　　　Ｂ１
リンゴ　リンゴの写真
ミカン　ミカンの写真
・　　　　・
・　　　　・
・　　　　・
・　　　　・

リンゴの写真をリンゴ.PNG又はリンゴ.JPGとして
指定フォルダに保存していきたい。

マクロを使用して何とか今日中に間に合わせたいのです。
皆様からのご教授をお願い致します。

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

「vba 画像　取得」で検索してみて
範囲内に画像があるかどうかを取得することができます。

ある場合にその画像を任意のフォルダに保存する
という処理でできると思うのでぜひ。
（初心者です） 2023/03/15(水) 15:57:21

コメントありがとうございます。
「vba 画像　取得」で検索してみたのですが

沢山引っかかりどれが正解なのかわからなくなりました。
もう少しヒントを頂きたいです。
（フリスク） 2023/03/15(水) 16:18:45

＞何とか今日中に間に合わせたいのです。

これは、まさしくまるごとマクロ作成依頼ということ。
なので、＞「vba 画像　取得」で検索してみて
などのアドバイスは聞き入れられません。
そういうことです。

（図星） 2023/03/15(水) 16:22:19

（初心者です）様
（図星）様
お二方コメントありがとうございます。

そうなのです。なんとか間に合わせたいのです。。

マクロに無知な私です。
ワガママな依頼という事は十二分に痛感しております。
何卒、皆様の知恵をお貸しください。
（フリスク） 2023/03/15(水) 16:28:32

 ファイル名はどうにもならないけど、画像を取り出すだけなら・・・
https://teachme.jp/90980/manuals/9635165

 セル範囲を画像として保存する方法はCopyPictureでできそうですが、画像だけってなるとAPI使わないと難しそう。

http://vbatips.blog37.fc2.com/blog-entry-26.html
（稲葉） 2023/03/15(水) 16:33:58

ご安心ください。
私はチャチャを入れるだけなのですが、ここの賢者の皆さんが何とかしてくれます（今頑張ってコーディング中・・・のはずです）。

（図星） 2023/03/15(水) 16:35:44

（稲葉）様
拡張子をZIPに変更するやり方をしてみた所。。
image01.jpg～途方もない数の写真が抽出できました。
やはり地道にファイル名を変更するしかないでしょうか。

（稲葉）様の頂いたこの知恵で閃いたのですが

ZIP返還の方法はＢ列の上から順に画像を抽出しimage01と連番を振っていると仮定すれば

後はファイル名を変更するフリーソフトで何とか解決できるかと思いました。

ただ確実にＢ列の上から順番に抽出しているという根拠があればですが。。。。
（フリスク） 2023/03/15(水) 17:01:14

 >やはり地道にファイル名を変更するしかないでしょうか

 地道にやれば良いんじゃないですかね、
 自分の仕事だし。

（ほぼ同じ） 2023/03/15(水) 17:51:52

 PowerShell経由で行けました
 アクティブシートのB列にシェイプがあれば、
 A1のファイル名.pngでこのブックと同じフォルダ直下に保存していきます。
    Sub test()
        Dim sp As Shape
        Dim pt As String
        pt = ThisWorkbook.Path & "\"
        For Each sp In ActiveSheet.Shapes
            If Not Intersect(sp.TopLeftCell, Range("B:B")) Is Nothing Then
                Call 画像保存(sp, pt & sp.TopLeftCell.Offset(, -1).Value & ".png")
            End If
        Next
        MsgBox "完了しました"
    End Sub
    Private Function 画像保存(sp As Shape, filepath As String)
        Dim cmd As String
        sp.Copy
        cmd = cmd + "Add-Type -AssemblyName System.Windows.Forms;$ImagePath = '" & filepath & "';  [Windows.Forms.Clipboard]::GetImage().Save($ImagePath, [System.Drawing.Imaging.ImageFormat]::png)"
        'WScriptから、PowerShellにコマンドを渡す。260文字以内
        'Command:="powershell -NoLogo -ExecutionPolicy RemoteSigned -Command "
        '↑がPowershellの定型文
        'WindowStyle 1表示　0非表示
        'WaitOnReturn　True同期実行　False非同期実行　※但し、Runの場合のみ。exeでは必ず同期実行になる
        With CreateObject("WScript.Shell")
            .Run Command:="powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " _
                & cmd _
                , WindowStyle:=0 _
                , WaitOnReturn:=False
        End With
    End Function

（稲葉） 2023/03/15(水) 18:28:16

 難しく考えず標準機能でも行けた・・・
https://daitaideit.com/vba-shapes-export-picture/
    Sub test()
        Dim sp As Shape
        Dim pt As String
        pt = ThisWorkbook.Path & "\"
        For Each sp In ActiveSheet.Shapes
            If Not Intersect(sp.TopLeftCell, Range("B:B")) Is Nothing Then
                Call 画像保管チャート(sp, pt & sp.TopLeftCell.Offset(, -1).Value & ".png")
            End If
        Next
        MsgBox "完了しました"
    End Sub
    Sub 画像保管チャート(sp As Shape, filepath As String)
        With ActiveSheet.ChartObjects.Add(0, 0, sp.Width, sp.Height)
            sp.CopyPicture Format:=xlBitmap 'オートシェイプを画像としてコピー
            .Chart.Parent.Select 'チャートを選択
            .Chart.Paste 'チャートに貼り付け
            .Chart.Export filepath 'チャートを、画像として保存
            .Delete 'チャートを削除
        End With
    End Sub
（稲葉） 2023/03/15(水) 20:02:19

（稲葉）様
返事遅れまして申し訳ございません。
下記のsp.CopyPicture Format:=xlBitmapの部分で1枚だけ保存されて何故かエラーで止まってしまいます。
Sub 画像保管チャート(sp As Shape, filepath As String)

        With ActiveSheet.ChartObjects.Add(0, 0, sp.Width, sp.Height)
            sp.CopyPicture Format:=xlBitmap 'オートシェイプを画像としてコピー
            .Chart.Parent.Select 'チャートを選択
            .Chart.Paste 'チャートに貼り付け
            .Chart.Export filepath 'チャートを、画像として保存
            .Delete 'チャートを削除
        End With
    End Sub
頂いたプログラムを1単語づつ調べまして
xlBitmapをxlScreenに変更したら動きました。
原因はわかりませんが、うまく作業が終了しましたこと報告させていただきます。
返事とお礼が遅れましたこと、遅い時間まで考察して頂いたこと併せまして感謝を申し上げます。
助かりました、ありがとうございましす。
（フリスク） 2023/03/22(水) 11:16:44

コメント返信：

[ 一覧(最新更新順) ]

[[20230315152401]] 『シート内の画像を個別に保存 指定列のセルから名』（フリスク） ページの最後に飛ぶ

[[20230315152401]]　『シート内の画像を個別に保存　指定列のセルから名』（フリスク）　ページの最後に飛ぶ