[[20100520162047]]　『エクセル2007：マクロの写真挿入がうまくいかない』（ぴい）　ページの最後に飛ぶ

『エクセル2007：マクロの写真挿入がうまくいかない』（ぴい）

写真を並べて指定セル内に一括表示させようとしています
2000のバージョンで作られたものと思われるマクロを2007で使用したら
「実行時エラー'1004':PicturesクラスのInsertプロパティを取得できません。」
とエラーがでます。
どこを修正すればよろしいのでしょうか？
お教え下さい。
宜しくお願い致します。

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("C2", "AO2", "C17", "AO17", "C32", "AO32", "C47", "AO47")
    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 = mySP.Height * myWW
                mySP.Width = Range(myMA).Width
            Else
                mySP.Height = Range(myMA).Height
                mySP.Width = mySP.Width * myHH
            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

 2007の環境が無いので確証はありませんが・・・

 >Set mySP = ActiveSheet.Pictures.Insert(myF)

 の１行を

  With Range(セル(i)).MergeArea
      Set mySP = ActiveSheet.Shapes.AddPicture(Filename:=myF, _
                   LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                   Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  End With
  With mySP
      .ScaleHeight 1, msoTrue
      .ScaleWidth 1, msoTrue
      .LockAspectRatio = msoFalse
  End With

 のように変えてみるとどうなりますか？

 （ｍｏｍｏ）

 >Set mySP = ActiveSheet.Pictures.Insert(myF)
 私もExcel2007は、持っていませんが、

 Set mySP = ActiveSheet.Pictures.Insert(myF.Path)

 では？

 これが原因であろうがなかろうが、きちんとプロパティは付けるべきですよ！！

 ichinose

 あ・・・myFがFSOのFilesのItemって見逃してました・・・
 StringのPathだと思い込んでました。
 いつもフォローありがとう御座います。
 （ｍｏｍｏ）

With Range(セル(i)).MergeArea

      Set mySP = ActiveSheet.Shapes.AddPicture(Filename:=myF, _
                   LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                   Left:=.Left, Top:=.Top, Width:=.Width, Height:=.Height)
  End With
  With mySP
      .ScaleHeight 1, msoTrue
      .ScaleWidth 1, msoTrue
      .LockAspectRatio = msoFalse
  End With

に変更したら一括貼り付けは綺麗に貼りつきました。
ありがとうございました！
しかし、、、写真を1枚づつ貼り付けようとしたら、うまくいきません・・・
どうしてでしょうか？

 どのようなコードで１枚づつ貼り付けにしてるのでしょうか？
 たぶん、ichinoseさんの御指摘を見逃してるのではないかな？と思いますが
 myFの変数の中身はどうなっていますか？
 フルパスになっていますか？

 それ以外でしたら、うまくいかない状況を説明してください。
 エラーが出るならコードのどの位置か、またエラーメッセージは何と出るのかとか。

 前述しましたが、私は2007の環境を持っていないので良い回答は出来ないかもしれませんので
 そこはご了承ください。
 （ｍｏｍｏ）

コメント返信：

[ 一覧(最新更新順) ]

[[20100520162047]] 『エクセル2007：マクロの写真挿入がうまくいかない』（ぴい） ページの最後に飛ぶ

[[20100520162047]]　『エクセル2007：マクロの写真挿入がうまくいかない』（ぴい）　ページの最後に飛ぶ