VBAの内容の修正をお願いさせて頂きます

質問

VBAの内容の修正をお願いしたく質問させて頂きます。

知人にExcel200７でシートのアルバムに写真をクリックで貼り付けられ、また別に張り付けてあるボタンでフォルダーを選択するとフォルダー内の写真を一括貼り付けるVBAを作成してもらいました。

ところがExcel2013で作成したものは他のPCで見られず、『リンク先が分からない・・・』と言った内容のメッセージが表示されます。

張り付けたボタンをクリックすると、フォルダーの選択はできますが、その後
『実行時”1004”　　PicturesクラスのInsertプロパティを取得できません』と言うメッセージが出ます。

残念ながら知人もよくわかりません。

表示内容がお分かりの方はぜひとも修正のご指導をお願いします。

写真のアルバムはA4サイズに横２×縦４の8枚を並べています。セルの結合が8枚あり、その場所をクリックすることで1枚1枚貼り付けることができます。

また、VBAでフォルダ内で番号順に並んでいる写真がばらばらに貼りついて今します。その部分も分かりましたら、よろしくお願いします。

VBA　左上表示：(General) 右上表示：画像貼り付け

Sub 画像貼り付け()

'===============フォルダ選択
Set myPath = CreateObject("Shell.Application") _
.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, 0)
If myPath Is Nothing Then Exit Sub
If myPath.Items Is Nothing Then Exit Sub
If myPath.Items.Item Is Nothing Then Exit Sub
フォルダ = myPath.Items.Item.Path
Set myPath = Nothing

'===============画像の掃除
' For Each mySP In ActiveSheet.Shapes
' myAD1 = mySP.TopLeftCell.MergeArea.Address
' myAD2 = Target.Address
' If myAD1 = myAD2 Then mySP.Delete
' Next

元シト = ActiveSheet.Name
セル = Array("C4", "AO4", "C21", "AO21", "C38", "AO38", "C55", "AO55")
i = 8
Set myFS = CreateObject("Scripting.FileSystemObject")
For Each myF In myFS.GetFolder(フォルダ).Files
myEXT = LCase(myFS.GetExtensionName(myF))
If myEXT = "jpeg" _
Or myEXT = "jpg" _
Or myEXT = "gif" _
Or myEXT = "tiff" _
Or myEXT = "bmp" _
Or myEXT = "png" _
Or myEXT = "tif" Then
If i > 7 Then
i = 0
Sheets(元シト).Copy after:=Sheets(Sheets.Count)
End If
'===============画像の貼り付け
Set mySP = ActiveSheet.Pictures.Insert(myF)
myMA = Range(セル(i)).MergeArea.Address
'===============タテヨコの縮尺を保持
myHH = Range(myMA).Height / mySP.Height
myWW = Range(myMA).Width / mySP.Width
If myHH > myWW Then
mySP.Height = Range(myMA).Height
mySP.Width = Range(myMA).Width
Else
mySP.Height = Range(myMA).Height
mySP.Width = Range(myMA).Width
End If

'===============中央へ調整
myHH2 = (Range(myMA).Height / 2) - (mySP.Height / 2)
myWW2 = (Range(myMA).Width / 2) - (mySP.Width / 2)
mySP.Top = Range(myMA).Top + myHH2
mySP.Left = Range(myMA).Left + myWW2

Set mySP = Nothing
i = i + 1
End If
Next
Set myFS = Nothing

End Sub

回答No.3

eden3616 · ベストアンサー

答えを回答するとすれば、こんな感じかな～。

以下の2ヶ所を変更しています。
「'▼修正箇所(1)▼　～　'▲▲▲▲▲▲▲」
「'▼修正箇所(2)▼　～　'▲▲▲▲▲▲▲」
（変更前のコードはコメントアウトしています）

(1)箇所目はNo1で記述したAddPictureを利用する方法に変更
(2)箇所目は質問コードの縦横比率の保持処理が変だったので修正

あと質問のエラーについてはmyFがVariantだからです。
ファイルパスをCstrで文字列へ変換すればエラー回避できるかと。
（修正(1)に含みます）

【追記】
エクセルのVBAは型宣言を省略しても動作しますが、
宣言しないで使用すると変数の型が混雑しますので
やはり宣言はしたほうがよいかと。（今回はしていませんが）

No2の方がおっしゃっていますが、先頭にTAB入れてても
OKWebに張り付けると先頭の空白行は無視されるんですよね（；_；
（よって今回コードも詰まっていますが、ご愛嬌。）

■以下修正後のコードです入替えてください

Sub 画像貼り付け()

'===============フォルダ選択
Set myPath = CreateObject("Shell.Application") _
.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, 0)
If myPath Is Nothing Then Exit Sub
If myPath.Items Is Nothing Then Exit Sub
If myPath.Items.Item Is Nothing Then Exit Sub
フォルダ = myPath.Items.Item.Path
Set myPath = Nothing

'===============画像の掃除
' For Each mySP In ActiveSheet.Shapes
' myAD1 = mySP.TopLeftCell.MergeArea.Address
' myAD2 = Target.Address
' If myAD1 = myAD2 Then mySP.Delete
' Next

元シト = ActiveSheet.Name
セル = Array("C4", "AO4", "C21", "AO21", "C38", "AO38", "C55", "AO55")
i = 8
Set myFS = CreateObject("Scripting.FileSystemObject")
For Each myF In myFS.GetFolder(フォルダ).Files
myEXT = LCase(myFS.GetExtensionName(myF))
If myEXT = "jpeg" _
Or myEXT = "jpg" _
Or myEXT = "gif" _
Or myEXT = "tiff" _
Or myEXT = "bmp" _
Or myEXT = "png" _
Or myEXT = "tif" Then
If i > 7 Then
i = 0
Sheets(元シト).Copy after:=Sheets(Sheets.Count)
End If
'===============画像の貼り付け
'▼修正箇所(1)▼
Set mySP = ActiveSheet.Shapes.AddPicture(CStr(myF), False, True, 0, 0, 0, 0)
mySP.ScaleHeight 1, msoTrue
mySP.ScaleWidth 1, msoTrue
'Set mySP = ActiveSheet.Pictures.Insert(myF)
'▲▲▲▲▲▲▲
myMA = Range(セル(i)).MergeArea.Address
'===============タテヨコの縮尺を保持
'▼修正箇所(2)▼
myHSP = mySP.Height / mySP.Width
myHMA = Range(myMA).Height / Range(myMA).Width
If myHMA >= 1 Then
mySP.Width = Range(myMA).Width
If myHSP < myHMA Then
mySP.Height = mySP.Width * myHSP
Else
mySP.Height = mySP.Width * myHMA
End If
Else
myHSP = mySP.Width / mySP.Height
myHMA = Range(myMA).Width / Range(myMA).Height
mySP.Height = Range(myMA).Height
If myHSP < myHMA Then
mySP.Width = mySP.Height * myHSP
Else
mySP.Width = mySP.Height * myHMA
End If
End If
'myHH = Range(myMA).Height / mySP.Height
'myWW = Range(myMA).Width / mySP.Width
'If myHH > myWW Then
' mySP.Height = Range(myMA).Height
' mySP.Width = Range(myMA).Width
'Else
' mySP.Height = Range(myMA).Height
' mySP.Width = Range(myMA).Width
'End If
'▲▲▲▲▲▲▲
'===============中央へ調整
myHH2 = (Range(myMA).Height / 2) - (mySP.Height / 2)
myWW2 = (Range(myMA).Width / 2) - (mySP.Width / 2)
mySP.Top = Range(myMA).Top + myHH2
mySP.Left = Range(myMA).Left + myWW2

Set mySP = Nothing
i = i + 1
End If
Next
Set myFS = Nothing

End Sub

お礼

本当に！本当に！感謝！感謝！ありがとうございます！m(_　_)m

本来であれば自分で勉強をして、理解して作業をしなければいけないこと思いますが・・・できません。＾＾；

知人も過去にどこかのサイトから引っ張ってきて作った様で理解もしていません。－－；

そうは言っても仕事で非常に重宝しており困っていました。

本当に『教えて！』の目的そのもののご回答をいただきました。

他力本願で非常によくないことは感じていますが・・・・＾＾；

兎にも角にも本当にありがとうございました！m(_　_)m

失礼承知で、また質問させて頂く事もあるかと思います。よろしくお願いいたします。＾＾/

回答No.2

satoron666

http://www.excel.studio-kazu.jp/kw/20100520162047.html
同じ質問？

当方、Excel2003のため
とりあえず、1行1行ステップイン[F8」で確認。
データが全てちゃんと入っているか、下のウィンドウで確認して下さい。

myFにしっかりした値が入っていないということが考えられそうです。

Tabで分けてもらわないと、プログラムが見難いです。

１.　しっかり変数定義がされていない。
全部全部そうですが、どこに定義されてるんです？
Dim　●●　As　String　とか。
2013は変数定義は必要ないということで？

２．　If　のあと、　End IF　で閉じられてない。
If myPath Is Nothing Then Exit Sub　の後とかもそうですが
どこにEnd if　があるんですか？
これで、エラーが出ないというのもおかしな話。

回答No.1

eden3616

エクセルのバージョンで2010から「Pictures.Insert」を用いて画像を挿入した場合
リンク貼り付けになるように仕様がかわりました。
http://support.microsoft.com/kb/2396509/ja
http://detail.chiebukuro.yahoo.co.jp/qa/question_detail/q14110403934

AddPicture（LinkToFileをFalseにする必要事）を用いて画像を挿入してください。
詳しくは参考URLをご覧ください。

参考URL：

http://www.moug.net/tech/exvba/0120020.html