エクセルの写真表示Sheetに写真のサムネイル表示をさせています。

質問

エクセルの写真表示Sheetに写真のサムネイル表示をさせています。
ところが、エクセル2003まではうまく表示出来ているのに、同じマクロでも
2007では、うまく行きません。
　対処法を教えていただけたら幸いです。

　下のSubでは、セル(2,2)から右へセルひとつ置きに5枚表示させ、
一行飛ばしてセル(4,2)からまたセルひとつ置きに5枚の写真を表示させ・・・ています。

Sub 写真の表示(sheetmei As String, sei_c As Integer)
Dim i, ii, j, k, counter, maisu As Intege
Dim myPic, myPicb As Picture
Dim sFile As String
Dim koumoku As String

Worksheets("写真表示").Activate
'シート保護の解除
ActiveSheet.Unprotect Password:="123"

（初期化部分）

i = 0
For ii = 0 To counter - 4　（注）counter計算部分は省略しています
If Worksheets(sheetmei).Cells(ii + 4, sei_c) <> "" Then
sFile = motopath & "写真\" & sheetmei & "\" & Worksheets(sheetmei).Cells(ii + 4, 1).Text & ".jpg"
On Error GoTo ErrorHandler
j = ((2 * i) \ 10) * 2 + 2
k = (2 * i) Mod 10 + 2

Cells(j + 1, k) = Worksheets(sheetmei).Cells(ii + 4, 1).Text
Set myPic = ActiveSheet.Pictures.Insert(sFile)

With myPic.ShapeRange
.Left = Cells(j, k).Left
.Top = Cells(j, k).Top
.LockAspectRatio = msoFalse
' ↓サイズを指定
.Height = Cells(j, k).Height
.Width = Cells(j, k).Width
End With

myPic.Locked = True

　With myPic
'貼り付けた写真をコピー
.Copy '←ここでエラー？が起こりエラーハンドラに飛んでしまう

'コピーを貼り付け、それをmyPicbとする
Set myPicb = ActiveSheet.Pictures.Paste

'元の写真を削除
.Delete
End With

myPicb.Left = Cells(j, k).Left
myPicb.Top = Cells(j, k).Top

Cancel = True
i = i + 1
maisu = i

End If
Next ii

'シート保護再設定
ActiveSheet.Protect Password:="123", DrawingObjects:=True, contents:=True, UserInterfaceOnly:=True

Exit Sub '←エラー処理ルーチンが実行されないように Sub を終了します。
ErrorHandler: ' エラー処理ルーチン。
MsgBox ("指定された写真は有りませんよ！")

End Sub

　2007で実行させると、上記コードのWith myPic.Copy
のところで何故かErrorHandler:に飛んでしまいます。

　セルに貼り付けた写真が動かないようにSheetの保護をかけたり、
コピーしたりの小細工をしています。
　我流のコードで非常に読みにくいと思いますが、どうかよろしくお願いします。

回答No.4

end-u · ベストアンサー

確認です。
1)OSのバージョン　ex)XPproSP3
2)Excelのバージョン　ex)2007sp2(12.0.6535.5002)
※前スレッドで最新パッチがあたってるとは思いますが念のため。
以下はお願い事項。
3)セーフティな環境で試してみる。
・端末に別ユーザーでログイン。（もしくは新規ユーザー）
・写真をローカルハードディスクに保存。
・2007セーフモードで起動。([Ctrl]キー押しながら起動）
・新規Book作成し、標準モジュールにコードのみコピーして一旦名前をつけて保存。
・再度Bookを開き試してみる。

※試してほしいのは下記test1-test3の３コード。
Sub test1()
　Dim x As Variant
　x = Application.GetOpenFilename("jpgFiles,*.jpg")
　If VarType(x) = vbBoolean Then Exit Sub
　ActiveSheet.Pictures.Insert(CStr(x)).Select
　DoEvents: DoEvents
　Selection.Width = 162
　Selection.Height = 100
　Selection.Copy
　'Selection.CopyPicture xlScreen, xlPicture '.Copy
　ActiveSheet.Paste
End Sub
'-----------------------------------------------------------------
Sub test2()
　Dim x As Variant
　Dim s As Shape
　x = Application.GetOpenFilename("jpgFiles,*.jpg")
　If VarType(x) = vbBoolean Then Exit Sub
　Set s = ActiveSheet.Shapes.AddPicture(Filename:=CStr(x), _
　　　　　　　　　　　　　　　　　　　　LinkToFile:=msoFalse, _
　　　　　　　　　　　　　　　　　　　　SaveWithDocument:=msoTrue, _
　　　　　　　　　　　　　　　　　　　　Left:=0, _
　　　　　　　　　　　　　　　　　　　　Top:=0, _
　　　　　　　　　　　　　　　　　　　　Width:=162, _
　　　　　　　　　　　　　　　　　　　　Height:=100)
　DoEvents: DoEvents
　s.CopyPicture xlScreen, xlPicture
　ActiveSheet.Paste
　Set s = Nothing
End Sub
'-----------------------------------------------------------------
Sub test3()
　Dim x As Variant
　x = Application.GetOpenFilename("jpgFiles,*.jpg")
　If VarType(x) = vbBoolean Then Exit Sub
　ActiveSheet.Pictures.Insert CStr(x)
　Application.OnTime Now, "test3sub"
End Sub
Sub test3sub(Optional n As Long)
　With ActiveSheet
　　.Pictures(.Pictures.Count).Copy
　　'.Pictures(.Pictures.Count).CopyPicture xlScreen, xlPicture
　　.Paste
　End With
End Sub

また、.Copyメソッドがダメだったら、下にコメントアウトしている
CopyPictureメソッドも試してみてください。

補足

end-u さん、度々ありがとうございます。

早速ですが
1)OSのバージョン　XP　SP3　（proはついていません）
2)Excelのバージョン　2007sp2　ですが
　　　　(12.0.6535.5002)ではなく(12.0.6425.1000)です。

それで
3)セーフティな環境で試してみる。
・端末に別ユーザーでログイン。（もしくは新規ユーザー）
・写真をローカルハードディスクに保存。
・2007セーフモードで起動。([Ctrl]キー押しながら起動）
・新規Book作成し、標準モジュールにコードのみコピーして一旦名前をつけて保存。
・再度Bookを開き試してみる
とのことですが、
設定の関係もありとりあえず、いつも通りパソコン、エクセルを起ち上げて

・新規Book作成し、標準モジュールにコードのみコピーして一旦名前をつけて保存。
　（2003モード.xlsで保存）
・再度Bookを開き試してみる
でSub test1()を試してみました。

　結果、見事ペーストまで上手く行きました！
test1()で行けましたので、test2()、test3()は試していません。
取り急ぎ、報告させていただきます。
　test2()、test3()でも試す必要がありましたら、
また試してみます。
　それと
Selection.CopyPicture xlScreen, xlPicture
でも試しましたが、こちらも上手く行きました。

　また、推察できることがありましたら、よろしくお願いします。

回答No.5

end-u

失敗。
いくつかの対策をまとめて入れたため、どれが原因か特定できず...orz

まあ、動く事はわかったので、後はコードを変更しつつ確かめてください。
エラーが出た直前の変更が肝かと思います。

1)ローカルな写真ではなく、元のmドライブの写真をやってみる。
　（ところでmドライブは何者でしょう？ネットワークドライブ？）
2)DoEvents: DoEventsを消す。
3)Selection.Width = 162　Selection.Height = 100　の2行を消す。
4)Selectしないコードに変更してみる。

...くらいですね。

あと気になるのは
>(12.0.6535.5002)ではなく(12.0.6425.1000)です。
これ。
エラー対策が特定できた後に
Microsoft Updateをやって、最新パッチをあててください。
その後エラーが出るコードを実行してみてどうなるか、ちょっと興味あります。

お礼

end-u さん、ここまでお付き合いいただきまして
本当にありがとうございました。

1)ローカルな写真ではなく、元のmドライブの写真をやってみる。
　（ところでmドライブは何者でしょう？ネットワークドライブ？）
　元のMドライブでOKでした。
（Mドライブは外付けポータブルHDDです。）

2)DoEvents: DoEventsを消す。
　消してもOKでした。

3)Selection.Width = 162　Selection.Height = 100　の2行を消す。
　消してもOKでした。

4)Selectしないコードに変更してみる。
　test1()ではこの部分は試すことができません。

◎以下は最初の質問時のマクロでの結果

With myPic
'貼り付けた写真をコピー
.Copy
'コピーを貼り付け、それをmyPicbとする
Set myPicb = ActiveSheet.Pictures.Paste
'元の写真を削除
.Delete
End With

のままではやはり駄目で
.Copy を
.CopyPicture
に書き換えるとエラーは出ず、行けました。

因みに、今回新たにUPdateしましたが
(12.0.6535.5002)ではなく(12.0.6425.1000)のままです。
何故かはよくわかりません。（XPのeditionが異なるからかも？）

いまだ、
.Copy が駄目で
.CopyPicture　なら行ける
のが何故なのか不明です。
（test1()では、どちらも行けるのですが。）

　とりあえず、今回は
.CopyPicture　で行けてますので
この質問スレは閉じたいと思います。

　end-u さん、最後までお付き合いいただきまして
感謝しております。
本当どうもありがとうございました。

回答No.3

end-u

ダメ元で、あえてSelectしてみるとか。
myPic.Select
Selection.Copy
：

手作業でやってもエラーが出るのでしょうか？
jpgファイルのサイズはどれくらいなんでしょう？

jpgファイルやBookの破損を疑ってもいいかもしれませんね。
・別のjpgファイルで試す。
・新規Bookで試す。
あとアドバイスできるのはこれくらいです。

または環境を疑って、別の端末もしくは別ユーザーでログインして試してみるとか。

新規Bookで問題ないようなら、作成し直したほうが近道かもしれません。

補足

end-u さん、度々ありがとうございます。

>手作業でやってもエラーが出るのでしょうか？

　このマクロは新たにこれだけのために
新規Bookで作成したのもです。

　それで、手作業でマクロの記録を取りながら
試してみましたところ、

手作業ではコピー、ペースト出来ました。
が、記録を取ったマクロで実行させると
『Pictureクラスのcopyメソッドが失敗しました』
といつもと同じエラーが出ます。

　ちなみにエラーはいつも
実行時エラー'1004'
です。

　また、今日勤務先で２台のPCのエクセル2007で、
最初に質問したややこしいマクロ入りファイルを
試したところ（VistaとXP）、
どちらも同じ
実行時エラー'1004'
で
『Pictureクラスのcopyメソッドが失敗しました』
となりました。

　これから何か推察できることがありますでしょうか？

回答No.2

end-u

コードは標準モジュールに書いてあるのですよね？
イベント実行ではないパターンを試してみてはどうですか。

また、写真を変えて試してみるとか、
シート保護せずに試してみるとか。

>（今回はエラーがどこで起こっているのかが不明なので、
>明らかに不要と思われるコード以外は、念のために載せておきました。）
エラーが再現できる最低限のコードに絞り込んでいく事で、
原因も特定できるのではないかと思います。

相変わらず再現しないので、整理だけしてみただけのコードです。
Sub 写真の表示2(sheetmei As String, sei_c As Long)
　　Dim i　　　 As Long
　　Dim ii　　　As Long
　　Dim j　　　 As Long
　　Dim k　　　 As Long
　　Dim counter As Long
　　Dim maisu　 As Long
　　Dim myPicb　As Picture
　　Dim sFile　 As String
　　Dim koumoku As String
　　Dim ws1　　 As Worksheet
　　Dim ws2　　 As Worksheet

　　On Error GoTo ErrorHandler
　　Set ws1 = Worksheets(sheetmei)
　　Set ws2 = Worksheets("写真表示")

　　'ws2.Unprotect Password:="123"
　　i = 0
　　counter = 10
　　For ii = 4 To counter
　　　　If ws1.Cells(ii, sei_c).Value <> "" Then
　　　　　　sFile = motopath & "写真\" & sheetmei _
　　　　　　　　　　& "\" & ws1.Cells(ii, 1).Text & ".jpg"
　　　　　　j = ((2 * i) \ 10) * 2 + 2
　　　　　　k = (2 * i) Mod 10 + 2
　　　　　　ws2.Cells(j + 1, k).Value = ws1.Cells(ii, 1).Text
　　　　　　With ws1.Pictures.Insert(sFile)
　　　　　　　　With .ShapeRange
　　　　　　　　　　.LockAspectRatio = msoFalse
　　　　　　　　　　.Height = ws2.Cells(j, k).Height
　　　　　　　　　　.Width = ws2.Cells(j, k).Width
　　　　　　　　End With
　　　　　　　　.Copy
　　　　　　　　Set myPicb = ws2.Pictures.Paste
　　　　　　　　.Delete
　　　　　　End With
　　　　　　With myPicb
　　　　　　　　.Left = ws2.Cells(j, k).Left
　　　　　　　　.Top = ws2.Cells(j, k).Top
　　　　　　　　.Locked = True
　　　　　　End With
　　　　　　'Cancel = True '？
　　　　　　i = i + 1
　　　　　　maisu = i
　　　　　　Set myPicb = Nothing
　　　　End If
　　Next ii
　　'ws2.Protect Password:="123", _
　　　　　　　　DrawingObjects:=True, _
　　　　　　　　contents:=True, _
　　　　　　　　UserInterfaceOnly:=True

ErrorHandler:
　　If Err().Number <> 0 Then
　　　　MsgBox Err().Number, Err().Description
　　End If
　　Set ws1 = Nothing
　　Set ws2 = Nothing
End Sub

それと
Debug.Print ...はVBEで[ctrl]+[g]、[イミディエイトウィンドウ]に書き出すものです。

補足

end-u さん、丁寧なご回答本当にありがとうございます。

　どうしても上記の
.copy　のところでエラーがでます。
　そこで
>エラーが再現できる最低限のコードに絞り込んでいく事で、
>原因も特定できるのではないかと思います。
に従って新たに、極端なマクロを作成しました。

　今回は単純に.copy　が出来るかどうかに絞りました。

●マクロの内容

写真表示のSheetに写真を表示させ(pictures.insert)
それをコピー出来るかどうかだけ試しました。
結果はやはりここで
『PictureクラスのCopyメソッドが失敗しました。』
とのエラーメッセージが出ます。

これはどこに問題有りなんでしょうか？？？

Private Sub CommandButton1_Click()
Dim myPic As Picture
Dim sFile As String
Dim myPicb As Picture

sFile = "M:\データ\コンサート\DSCF0329.jpg"

Set myPic = Worksheets("写真表示").Pictures.Insert(sFile)
With myPic
'貼り付けた写真をコピー
.Copy '''''''←ここでエラーが起こります
'コピーを貼り付け、それをmyPicbとする
Set myPicb = Worksheets("写真表示").Pictures.Paste
End With
End Sub

回答No.1

end-u

再現しません。
効率の問題はおいといて、とりあえずコードの中には
2003で動いていて、2007ではエラーが出るような箇所は
無いように思います。

●エラー箇所に間違いないか
>.Copy '←ここでエラー？が起こりエラーハンドラに飛んでしまう
エラー発生箇所は確実なのですか？
[F8]ステップ実行で確認しましたか？
また、
：
ErrorHandler:
　　Debug.Print Err().Number, Err().Description
：
こんな感じでエラーNumberとDescriptionを確認してください。

●処理内容の問題はないか
最大何枚くらいの写真を処理しようとしていますか？
エラーは必ず１枚目で発生するのですか？
それとも何枚目かで発生するのでしょうか。

コード内容ではなくPicturesの内容や量によるものだとすると
情報が不足していますし、Pictureの内容はそちらでないと確認できないです。
少なくともエラー発生時のシート状態とPictureの内容は確認してください。

また、エラー箇所まわりのコードを抜き出し、
余計な事をせずにできるだけシンプルな形でコード化してみてください。
誰でも検証できるようなコードにしてアップすれば
他の方からもレスがあると思いますよ。

補足

end-uさん、今回もお付き合いいただき
どうもありがとうございます。

　早速ですが、
>●エラー箇所に間違いないか
>.Copy '←ここでエラー？が起こりエラーハンドラに飛んでしまう
>エラー発生箇所は確実なのですか？
　はい、必ずここで起こります。
　（F8で確かめています）

>●処理内容の問題はないか
>最大何枚くらいの写真を処理しようとしていますか？
　表示させたい項目により処理枚数は違いますが、
ここでは3枚と、少ないのを選んで試しています。
（2003では、100枚ぐらい表示させる項目もありますが、
不具合は出ていません。）

>エラーは必ず１枚目で発生するのですか？
>それとも何枚目かで発生するのでしょうか。
　エラーは必ず1枚目から、同じところで起こります。
ステップ実行中、コピー前の段階の1枚目の写真は
コード通りセル(2,2)に表示されています。

>ErrorHandler:
>　　Debug.Print Err().Number, Err().Description
>：
>こんな感じでエラーNumberとDescriptionを確認してください。
　こういう方法で、エラーを特定していくというのは全く知りませんでした。
（いい勉強になりました。）
ただ今回、上のようにしてみたところ
何も表示されませんでした。
・・・う～ん、よく分かりません。コピぺしましたので
入力ミスはないと思うのですが・・・。

>また、エラー箇所まわりのコードを抜き出し、
>余計な事をせずにできるだけシンプルな形でコード化してみてください。
>誰でも検証できるようなコードにしてアップすれば・・・
　確かにそうですね、読みづらくて回答しようとしてくれている人には
申し訳なく思っています。
（今回はエラーがどこで起こっているのかが不明なので、
明らかに不要と思われるコード以外は、念のために載せておきました。）

　また上記エラーの補足ですが、
上記エラーの出るSubルーチンは、表示させたい項目Sheet（別Sheet）から
Private Sub Worksheet_BeforeRightClick(ByVal T・・・
の中の処理から飛んできています。
　関係ないと思って書きませんでしたが、
ひょっとして、こういうイベント処理は不具合が
起こりやすい可能性はあるかもしれません。（汗、汗…）