[[20110324093457]]　『どこを変更したらいいですか？』（あき）　ページの最後に飛ぶ

『どこを変更したらいいですか？』（あき）

Excel2010

下記のマクロがあります。以前2003で使用していた時は、これで画像を張り付けて

写真を移動してもそのまま張り付けられた状態だったのですが、2010に変更してから

一度張り付けて、画像を違う場所に移したりすると

『リンクされたイメージを表示できません。

ファイルが移動または削除されたか、名前が変更された可能性があります。

リンクに正しいファイル名と場所が指定されていることを確認してください。』

と表示されて張り付けていた画像が出てきません。

教えていただけないでしょうか、よろしくお願いします。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim myRange As Range
    Dim v       As Variant
    Dim vv      As Variant
    v = Array("B3", "B6", "I3", "I6")
    Set myRange = Range(Join(v, ","))
    If Application.Intersect(Target, myRange) Is Nothing Then
        Exit Sub
    End If

    Cancel = True
    Dim myPic As Picture
    Dim sFile As String

    sFile = Application.GetOpenFilename("画像ファイル(*.jpg),*.jpg")
    If sFile = "False" Then Exit Sub

    Set myPic = ActiveSheet.Pictures.Insert(sFile)
    sFile = StrReverse(Split(Split(StrReverse(sFile), "\")(0), ".")(1))
    For Each vv In v
        If Not Application.Intersect(Target, Range(vv)) Is Nothing Then
            With myPic.ShapeRange
                .Left = Range(vv).Left
                .Top = Range(vv).Top
                .LockAspectRatio = msoTrue
                ' ↓サイズを指定
                .Height = 410
                .Width = 547
                .Rotation = 0
            End With
            Select Case Range(vv).Column
                Case 2: Range(vv).Cells(-1).Offset(, 4).Value = sFile
                Case 9: Range(vv).Cells(-1).Offset(, 4).Value = sFile
            End Select
            Exit For
        End If
    Next
End Sub

 2007では現象が再現されません2010特有の事象でしょうかね？
 2010の環境が無いので確認できませんが、以前の回答が参考になるでしょうか？
　[[20110117143927]]　『マクロを使ってＥｘｃｅｌ2010で作ったファイルを』（ｍｓｄ）

 （ｍｏｍｏ）

さっそくのご回答ありがとうございます。

Pictures.Insert　がいけないって事でしょうか？

勉強不足な為、自分の場合どのように書いていいのか

わからなかったです。

（あき）

 ↑のコードはご自身で書かれたのではないのですか？
 それだけ書けるのであれば充分変更可能と判断したのですが

 >勉強不足な為
 では、一緒に勉強していきましょう。
 わからないのはどこですか？
 （ｍｏｍｏ）

会社で使ってまして、上のコードは前任者が作ったものです。

なので、Wクリックをする場所・サイズを変える・ファイル名を入れる場所の変更を私がしただけでした。

今、コードを勉強中ですが追いついていない状態です。

あたかも自分が作ったような書き方でした。

書き方が悪くてすみません。

（あき）

 まず、元のコードには無駄が多いので簡単にまとめてみます。

  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim myPic As Picture
  Dim sFile As String

  If Application.Intersect(Target, Me.Range("B3,B6,I3,I6")) Is Nothing Then
      Exit Sub
  End If

  Cancel = True
  sFile = Application.GetOpenFilename("画像ファイル(*.jpg),*.jpg")
  If sFile = "False" Then Exit Sub

  Set myPic = ActiveSheet.Pictures.Insert(sFile)
  sFile = StrReverse(Split(Split(StrReverse(sFile), "\")(0), ".")(1))
  With myPic.ShapeRange
      .Left = Target.Left
      .Top = Target.Top
      .LockAspectRatio = msoTrue
      ' ↓サイズを指定
      .Height = 410
      .Width = 547
      .Rotation = 0
  End With
  Target.Offset(-1, 4).Value = sFile
  End Sub

 ここでPictureの貼り付けに関するコードは

  Set myPic = ActiveSheet.Pictures.Insert(sFile)

と

  With myPic.ShapeRange
      .Left = Target.Left
      .Top = Target.Top
      .LockAspectRatio = msoTrue
      ' ↓サイズを指定
      .Height = 410
      .Width = 547
      .Rotation = 0
  End With

 ですね。
 で、リンク先のコードと比べてみると解りやすいかもしれません。

 >あたかも自分が作ったような書き方でした。 
 >書き方が悪くてすみません。
 そこはどうでも良いのですが、わからない事を明確に質問してみてください。
 私以外にも回答者は沢山いますし、質問を明確にしたほうが的確な回答が得られます。
 （ｍｏｍｏ）

Set myPic = ActiveSheet.Pictures.Insert(sFile)から

With myPic.ShapeRange

      .Left = Target.Left
      .Top = Target.Top
      .LockAspectRatio = msoTrue
      ' ↓サイズを指定
      .Height = 410
      .Width = 547
      .Rotation = 0
  End With

の間の部分を

For Each mySP In ActiveSheet.Shapes

    If Not Application.Intersect(Target, mySP.TopLeftCell.MergeArea) Is Nothing Then
      mySP.Delete
    End If

  Next mySP
    With Me.Shapes.AddPicture(myF, msoFalse, msoTrue, Target.Left, Target.Top, 1, 1)
    sFile = StrReverse(Split(Split(StrReverse(sFile), "\")(0), ".")(1))
    For Each vv In v
        If Not Application.Intersect(Target, Range(vv)) Is Nothing Then

に変更しました。
「指定したファイルが見つかりません」となります。

sFile と言うのがいけないのかと思い　myF　にしたり変えてみましたができませんでした。

指定したファイルと言うのはどの部分なのでしょうか？

（あき）

できました！

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim myRange As Range
    Dim v       As Variant
    Dim vv      As Variant
    v = Array("B3", "B6", "I3", "I6")
    Set myRange = Range(Join(v, ","))
    If Application.Intersect(Target, myRange) Is Nothing Then
        Exit Sub
    End If

    Cancel = True
    Dim myPic As Picture
    Dim sFile As String

    sFile = Application.GetOpenFilename("画像ファイル(*.jpg),*.jpg")
    If sFile = "False" Then Exit Sub

  For Each mySP In ActiveSheet.Shapes
    If Not Application.Intersect(Target, mySP.TopLeftCell.MergeArea) Is Nothing Then
      mySP.Delete
    End If

  Next mySP
    With Me.Shapes.AddPicture(sFile, msoFalse, msoTrue, Target.Left, Target.Top, 410, 547)
    sFile = StrReverse(Split(Split(StrReverse(sFile), "\")(0), ".")(1))
    For Each vv In v
        If Not Application.Intersect(Target, Range(vv)) Is Nothing Then
            .ScaleHeight 1, msoTrue
    .ScaleWidth 1, msoTrue
    .LockAspectRatio = msoTrue
    .Height = Target.Height
    If .Width > Target.Width Then
      .Width = Target.Width

            End If
            Select Case Range(vv).Column
                Case 2: Range(vv).Cells(-1).Offset(, 4).Value = sFile
                Case 9: Range(vv).Cells(-1).Offset(, 4).Value = sFile
            End Select
            Exit For
        End If
    Next
End With
End Sub

という風に書き換えたら

張り付ける事は出来ました。

これで間違いがないかチェックしていただけますか？
（あき）

 出来ているのなら問題ないんだと思いますが、
 最初に書いたように無駄な部分がかなり多いように見えます。

 >sFile と言うのがいけないのかと思い　myF　にしたり
 という事ですと・・・変数とかＶＢＡの一番基本の部分がわからないという事ですかね？
 困った所だけではなく、基本から理解しておかないと
 また変更の都度苦労する事になるので時間をかけて勉強してみましょう。

 とりあえず、叩き台です。
 あきさんのコードとほぼ同じ動作をします。（既存Shapeを消す以外）
 エラーが回避されるか確認してください。

  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim sFile As String
  If Not Application.Intersect(Target, Me.Range("B3,B6,I3,I6")) Is Nothing Then
    Cancel = True
    sFile = Application.GetOpenFilename("画像ファイル(*.jpg),*.jpg")
    If sFile <> "False" Then
      Me.Shapes.AddPicture sFile, msoFalse, msoTrue, Target.Left, Target.Top, 547, 410
      Target.Offset(-1, 4).Value = StrReverse(Split(Split(StrReverse(sFile), "\")(0), ".")(1))
    End If
  End If
  End Sub

 （ｍｏｍｏ）

基本がわかっていないです。

今まで困った所を直すと言う作業で来ました。

一から勉強していきたいと思います。

教えていただいたコードで、エラーは出ませんでした。

（あき）

 当初の問題は解決。という事でよろしいでしょうか？

 以下に、私のコードにコメントを付けましたので確認してください。
 解らない単語にカーソルを当ててF1キーを押すとヘルプが開きます。
 １つ１つ確認しながら覚えていってください。

  'セルをダブルクリックした時に起動するイベントです。
  Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
  Dim sFile As String
  'ダブルクリックしたセルがB3,B6,I3,I6セルのいずれかなら
  If Not Application.Intersect(Target, Me.Range("B3,B6,I3,I6")) Is Nothing Then
    '右クリックメニューをキャンセルします
    Cancel = True
    'ファイルを開くダイアログを表示
    sFile = Application.GetOpenFilename("画像ファイル(*.jpg),*.jpg")
    'キャンセルでなければ
    If sFile <> "False" Then
      '画像を貼り付け
      Me.Shapes.AddPicture sFile, msoFalse, msoTrue, Target.Left, Target.Top, 547, 410
      'ファイル名をセルにセット
      Target.Offset(-1, 4).Value = StrReverse(Split(Split(StrReverse(sFile), "\")(0), ".")(1))
    End If
  End If
  End Sub

 （ｍｏｍｏ）

当初の問題は解決しました。

長い時間をかけて教えていただきありがとうございます。

まずは、教えていただいたコードを勉強していきたいと思います。

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

また、何かわからない事がありましたら質問させていただきます。

その時はよろしくお願いいたします。

（あき）

コメント返信：

[ 一覧(最新更新順) ]

[[20110324093457]] 『どこを変更したらいいですか？』（あき） ページの最後に飛ぶ

[[20110324093457]]　『どこを変更したらいいですか？』（あき）　ページの最後に飛ぶ