Excel (一般機能)

Excelの一般機能に関するフォーラムです。
  • 解決済みのトピックにはコメントできません。
このトピックは解決済みです。
質問

 
(Windows 10 Pro : Excel 2010)
エクセル内にある画像の写真を、JPGファイルとしてある決まったフォルダに出力したいのですが
投稿日時: 17/03/16 13:00:54
投稿者: naomaru999

エクセル内にある画像の写真を、
JPGファイルとしてある決まったフォルダに出力したいのですが、
どなたか教えていただけますでしょうか。
 
また、写真は複数枚(20枚程度)が同一シートにあり、
 
まとめてオブジェクトを選択して、
適当なファイル名で、JPG形式で出力できますでしょうか。
 
教えていただけますでしょうか。
 
どうぞよろしくお願いいたします。
 
 
 
 

回答
投稿日時: 17/03/16 14:12:21
投稿者: みらー

こんにちは。
こちらの記事が参考になると思います。
http://dukicco.hatenadiary.jp/entry/2015/03/18/233751
 
出力先のパスだけ適当な場所に変えてあげれば大丈夫かと。

投稿日時: 17/03/16 15:04:17
投稿者: naomaru999

ミラーさんへ
 
早速ご回答いただきまして、ありがとうございました。
試してみたいと思います。
 
 
 
 

投稿日時: 17/03/17 21:29:25
投稿者: naomaru999

ご紹介いただきましたホームページにて
お借りしたマクロをそのまま実行しましたところ、
 
Tcht.Paste 'グラフに画像をペーストする。 
 
の行で
 
実行時エラー’1004’:
アプリケーション定義またはオブジェクト定義のエラーですが表示されます。
 
どうしてでしょうか?
私の PCは、Windows10 となります。
 
 
-----------------------------紹介VBA---------------------------------------------------
Sub 保存()
 
'ワークシートの全オブジェクトをループ
For Each tobj In ActiveSheet.Shapes
 
 
 If tobj.Type = 13 Then 'オブジェクトが画像ならType=13となる。
tobj.CopyPicture
 Fname = tobj.Name 'オブジェクトの名前を取得
ACWidth = tobj.Width 'オブジェクトのサイズを取得(高さ)
 
ACHeight = tobj.Height 'オブジェクトのサイズを取得(高さ)
 
  
 
'オブジェクトとほぼ同サイズの空のグラフを一時的に作る
 
Set Tcht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart
 
Tcht.Paste 'グラフに画像をペーストする。
 
'エクスポート先はデスクトップ。ファイル名はオブジェクト名。タイプはJPG(書き換えればpng等でもいける。)
 
Tcht.Export Filename:=myDeskTopPath & Fname & ".jpg", filtername:="JPG"
 Tcht.Parent.Delete 'グラフを削除する。
End If
 Next
 
End Sub
 
Function myDeskTopPath()
' デスクトップパスの取得
Dim MyWSH As Object
 Set MyWSH = CreateObject("WScript.Shell")
 myDeskTopPath = MyWSH.SpecialFolders("Desktop")
 Set MyWSH = Nothing
End Function

回答
投稿日時: 17/03/17 22:15:48
投稿者: みらー

naomaru999様
 
これでいかがでしょうか。
保存先をExcelファイルと同じ場所に固定しています。
 
Sub 保存()
 
    'ワークシートの全オブジェクトをループ
    For Each tobj In ActiveSheet.Shapes
     
        If tobj.Type = 13 Then 'オブジェクトが画像ならType=13となる
         
            tobj.CopyPicture
            Fname = tobj.Name 'オブジェクトの名前を取得
            ACWidth = tobj.Width 'オブジェクトのサイズを取得(高さ)
            ACHeight = tobj.Height 'オブジェクトのサイズを取得(高さ)
             
            'オブジェクトとほぼ同サイズの空のグラフを一時的に作る
            Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 0.8, ACHeight * 0.8).Chart
             
            'グラフに画像をペーストする。
            TCht.Paste
             
            'エクスポート先はデスクトップ。ファイル名はオブジェクト名。タイプはJPG(書き換えればpng等でもいける。)
            TCht.Export Filename:=ThisWorkbook.Path & "\" & Fname & ".jpg", filtername:="JPG"
     
            'グラフを削除する。
            TCht.Parent.Delete
         
        End If
    Next
 
End Sub

投稿日時: 17/03/18 09:08:25
投稿者: naomaru999

みらーさんへ
 
無事作業できました。
実は仕事で必要となりまして、
本当にありがとうございました。
 

投稿日時: 17/03/18 15:11:31
投稿者: naomaru999

追加で申し訳ございません。
  
もし可能でしたら教えていただきたいのですが、
  
   
画像はシート内に縦に2列(1列6枚)並んでおりまして、
  
左上から下へ、右上から下への順番で、画像ファイル名にしたいのですが。
 (現状のオブジェクト名が適当になってしまっております)
  
(シート内に並べられた順番に、左上〜右下へファイル名を付けたいのですが)
  
どうぞよろしくお願いいたします。

回答
投稿日時: 17/03/18 19:39:07
投稿者: UO3

参考になりますか?
 

Sub 参考()
    Dim sl As Object
    Dim d As Variant
    Dim p As Picture
    Dim i As Long
    
    Set sl = CreateObject("System.Collections.SortedList")
    
    For Each p In ActiveSheet.Pictures
        sl.Add p.TopLeftCell.Column * 10000000 + p.TopLeftCell.Row, p.Name
    Next
    
    For i = 0 To sl.Count - 1
        MsgBox sl.getbyindex(i)
    Next
        
End Sub

投稿日時: 17/03/19 02:04:34
投稿者: naomaru999

UO3 さんへ
 
ありがとう御座います。
 
大変参考になりました!!
 
ファイル保存できるようにしてみたいと思います。
 
ありがとうございます。
 
 

投稿日時: 17/03/19 05:22:09
投稿者: naomaru999

 
下記で左上から下への順の画像順にファイル名を設定して保存できました。
 改ページ指定してあると、そのページ毎の左上から読み込むようになりました。
  
みらーさん、UO3さん
本当に色々とありがとうございました。
  
   
----------------------------------------------------
Sub 参考()
   
Dim i As Long
 Dim sl As Object
 Dim p As Picture
   
 i = 1
      
 For Each p In ActiveSheet.Pictures
   
   Set sl = CreateObject("System.Collections.SortedList")
   
    sl.Add p.TopLeftCell.Column * 1000 + p.TopLeftCell.Row, p.Name
           
    ACWidth = p.Width 'オブジェクトのサイズを取得(高さ)
   ACHeight = p.Height 'オブジェクトのサイズを取得(高さ)
   p.Copy
                     
        'オブジェクトとほぼ同サイズの空のグラフを一時的に作る
   Set TCht = ActiveSheet.ChartObjects.Add(0, 0, ACWidth * 1, ACHeight * 1).Chart
                     
        'グラフに画像をペーストする。
   TCht.Paste
               
        'エクスポート先はデスクトップ。ファイル名はオブジェクト名
   TCht.Export Filename:=ThisWorkbook.Path & "\" & i & ".jpg", filtername:="JPG"
         
        'グラフを削除する。
   TCht.Parent.Delete
             
     i = i + 1
     MsgBox i
                     
 Next