エクセルVBA/シートの背景の変更

質問

エクセル2000です。
VBAでワークシートに背景を設定する場合、PC内に保存してあるファイルを使うなら以下でできます。

Sub haikei()
With ActiveSheet
.SetBackgroundPicture Filename:="C:\TEST\shape.jpg"
End With
End Sub

これを、PC内ではなくワークシート上にオブジェクトとして貼り付けたJpegファイルを使って背景を設定するにはどのようなコードになるのでしょうか？
ワークシート上のオブジェクトの名前は 「オブジェクト 1」 となっており、クリックすると数式バーには
=EMBED("Photo Editor Photo","")
と表示されます。

こんなことをしたい理由は、状況により配布した（自分のPC上でない）BOOKのワークシートの背景を一定の条件で変更したいためです。そのため、複数のJpegファイルを非表示にしたワークシート上にはりつけておき、背景の差し替えを行いたいと考えています。

回答No.3

xls88

＞で一応出来ましたが、出来ればPC内に保存させたくないのです。
元ファイルは、Killステートメントで削除すればどうでしょうか。

お礼

何度もありがとうございます。
一番最初の質問で書いたとおり、このBOOKはわたし以外の人たちが使うものなのです。そのため環境もよくわからない（Officeは2000～2007、OSは2000～Vistaまであります）他人のPC内に勝手にファイルを保存し、それを削除するというようなことをして良いものか、非常に迷うのです。
またそれがOKだとしても、保存するフォルダーをどうするか、ファイル名が重複してたらどうしよう、とか懸念されることがいろいろあります。

きっと一番いいのはフォルダー名を検索して、存在しないフォルダーを作り、そこに保存して、終了時にフォルダーごと削除してしまうようにすれば名前の重複も心配することはないのでしょうが、2000～Vistaまで対応したそのようなコードは残念ながらわたしには書けそうもありません。

回答No.2

xls88

回答番号：No.1 この回答への補足 で提示されたコードをコピペしましたが、コンパイルエラーは発生しません。
当方Excel2007です。

ただ、test01の方では
LoadPictureFromCBの返り値をSavePictureで一旦保存しなければなりません。
保存後に、そのファイルをSetBackgroundPictureするようにします。

お礼

> LoadPictureFromCBの返り値をSavePictureで一旦保存しなければなりません

ありがとうございました。
ということは一旦、PC内のどこかのフォルダーに名前を付けて保存しなければならないということでしょうか？

Sub test02()
Selection.Copy
SavePicture LoadPictureFromCB(), "C:\TEST\myPic.bmp"
With ActiveSheet
.SetBackgroundPicture Filename:="C:\TEST\myPic.bmp"
End With
End Sub

で一応出来ましたが、出来ればPC内に保存させたくないのです。

回答No.1

xls88

「Webページとして保存」すると画像ファイルが生成されます。
その画像ファイルを取り込むようにすればどうでしょうか。

ExcelファイルをWebページとして保存する
http://allabout.co.jp/computer/msexcel/closeup/CU20081005A/index2.htm

あるいは、Windows APIを使って、コピーした画像データをファイル保存して使うこともできます。
下記shiraさんのページが参考になります。

EXCEL VBA TIPs. [ クリップボードにコピーした画像を、ペーストするために取りだす方法。]
http://oshare2iketeru.blog80.fc2.com/blog-entry-1413.html

お礼

さっそくありがとうございます。
Webページとして保存させたくないので、ぜんぜん内容を理解できぬままに補足欄に記載のコードで、やってみました。
test01を実行すると、
Data4(0 To 7) As Byte のところでコンパイルエラー「型が一致しません」が出てしまいました。
どこがおかしいのでしょうか？

補足

エラーになったコード

Option Explicit

Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte 'ここでコンパイルエラー「型が一致しません」が出る！！！
End Type
Private Type PICTDESC
cbSizeofstruct As Long
picType As Long
hemf As Long
Padding(0 To 1) As Long
End Type
Const PICTYPE_ENHMETAFILE = 4

Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" _
(lpPictDesc As PICTDESC, riid As GUID, _
ByVal fOwn As Long, lplpvObj As Object) As Long
Private Declare Function OpenClipboard Lib "user32" _
(ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" _
(ByVal uFormat As Long) As Long

Const CF_ENHMETAFILE = 14
Private Declare Function CopyEnhMetaFile Lib "gdi32" _
Alias "CopyEnhMetaFileA" _
(ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" _
(ByVal hemf As Long) As Long

'クリップボードから Picture オブジェクトを取り出す関数
'※画像がない場合は nothing を返す

Public Function LoadPictureFromCB() As Object

Dim IID_IDispatch As GUID
Dim pd As PICTDESC
Dim objResult As Object
Dim hemf As Long

If OpenClipboard(0) Then
hemf = GetClipboardData(CF_ENHMETAFILE)
' ハンドルを複製してから使用する
hemf = CopyEnhMetaFile(hemf, vbNullString)
CloseClipboard
End If
If hemf = 0 Then
Set LoadPictureFromCB = Nothing
Exit Function ' 失敗
End If
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With pd
.cbSizeofstruct = Len(pd)
.picType = PICTYPE_ENHMETAFILE
.hemf = hemf
End With

If OleCreatePictureIndirect(pd, IID_IDispatch, _
1, objResult) >= 0 Then
' 成功時
Set LoadPictureFromCB = objResult
Else
' 失敗時
DeleteEnhMetaFile hemf
Set LoadPictureFromCB = Nothing
End If

End Function

Sub test01()
Selection.Copy
With ActiveSheet
.SetBackgroundPicture Filename:=LoadPictureFromCB()
End With
End Sub