画像ファイルを保存する方法

質問

洗濯してる画像を保存するvbaコードが知りたいのですが

Sub Sample()
Dim PicFile As String
Dim myRess As Variant
PicFile = "C:\Users\test.jpg"

ActiveSheet.Pictures.Insert PicFile
ActiveSheet.Pictures.Insert(PicFile).Select

PicFile = Selection.Name

myRess = ActiveSheet.Shapes(PicFile).Picture.Export( _
ThisWorkbook.Path & "\test.jpg", "JPG", False)

End Sub

だと実行時エラー438になります。

Export メソッドは、グラフにしか使えないのでしょうか？
画像ファイルを保存する方法をご教授ください。

回答No.3

mitarashi · ベストアンサー

#2です。おそらくお望みのものではないと存じますが、コードのストックの使い回しをしたため冗長でしたので、アレンジしました。一応投稿させていただきます。
Sub ExtractImage2()
Dim objShell As Object
Dim objFolder As Object
Dim objDestination As Object
Dim vZipFile As String, vDestination As Variant
Dim getDesktopPath As String

Const ssfDESKTOP = 0

Set objShell = CreateObject("Shell.Application")
getDesktopPath = objShell.Namespace(ssfDESKTOP).Self.Path

'ThisWorkbookを別名で保存し、拡張子をZipにRenameして画像ファイルを取り出す
ThisWorkbook.SaveCopyAs getDesktopPath & "\temp.xlsm"
If Dir(getDesktopPath & "\temp.zip") <> "" Then Kill getDesktopPath & "\temp.zip"
Name getDesktopPath & "\temp.xlsm" As getDesktopPath & "\temp.zip"
vZipFile = getDesktopPath & "\temp.zip"
vDestination = getDesktopPath & "\tempDir"

If Dir(vDestination, vbDirectory) = "" Then
MkDir vDestination
End If

Set objFolder = objShell.Namespace(vZipFile & "\xl\media")
If objFolder Is Nothing Then
MsgBox "画像がありません"
Exit Sub
End If
'vDestinationのところは、ssfDESKTOPの様な定数を渡す場合もあるので文字列型だとエラーになるらしい
Set objDestination = objShell.Namespace(vDestination)

'丸ごと取り出す
objDestination.CopyHere objFolder.items
Set objShell = Nothing
End Sub

お礼

ありがとうございました。

回答No.2

mitarashi

下記リンク先のKenKenSPさんのコードは、クリップボードのデータのCF_BITMAPを使っているので、画像ファイルにも通用します。（サンプルコード中、C:\ドライブ直下のファイルアクセスは、WindowsVISTA以降はエラーになりますので、要注意）小生の回答は,CF_ENHMETAFILEを使っているので駄目かもしれませｎ。
http://okwave.jp/qa/q5124395.html

さて、xl2007以降では、エクセルのxlsxやxlsmのファイルは実はZip圧縮フォルダーであり、内部に保存されている画像ファイルを取り出す事ができます。全ての画像になってしまいますが、取り出すコードを書いて（切り貼りして）みました。
ご参考まで。Windows7Home-64bit, xl2010-32bitで試しています。
Sub ExtractImage()
Dim fso As Object
Dim objShell As Object
Dim objFile As Object
Dim objDestination As Object
Dim vZipFile, vDestination
Dim myFile As Object

'ThisWorkbookを別名で保存し、拡張子をZipにRenameして画像ファイルを取り出す
ThisWorkbook.SaveCopyAs GetDesktopPath & "\temp.xlsm"
If Dir(GetDesktopPath & "\temp.zip") <> "" Then Kill GetDesktopPath & "\temp.zip"
Name GetDesktopPath & "\temp.xlsm" As GetDesktopPath & "\temp.zip"
vZipFile = GetDesktopPath & "\temp.zip"
vDestination = GetDesktopPath & "\tempDir"

' ファイルシステムオブジェクトおよびシェルオブジェクト作成
Set fso = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")

' 展開先パスがなければ作成する
If Dir(vDestination, vbDirectory) = "" Then
MkDir vDestination
End If

' Zipファイルオブジェクト作成(画像ファイルは\xl\media\にある
Set objFile = objShell.Namespace(vZipFile & "\xl\media")
' 展開先オブジェクト作成
Set objDestination = objShell.Namespace(vDestination)

' 展開
'objDestination.CopyHere objFile.Items '丸ごと取り出す時
For Each myFile In objFile.Items
Select Case LCase(fso.GetExtensionName(myFile.Name))
'とりあえずJpegだけテストした
Case "jpg"
objDestination.copyhere myFile
End Select
Next myFile
End Sub

Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

なお、画像ファイルとワークシートの対照と、リンク等について調べた事があります。真面目にやれば特定シートからの取り出しも可能とは思います。
http://okwave.jp/qa/q7320070.html

お礼

ありがとうございました。

回答No.1

yomyom01

＞洗濯してる画像
笑った

お礼

ありがとうございました。