戻る  □一般操作のサロン  □ 使用方法  □ 新着記事  □ 新規に質問する!  □ トピック一覧  □ 検索  □ 過去ログ
[ 最新記事及び返信フォームをトピックトップへ ]
このトピック参照回数 :
写真を張り付けるとたまにエラーメッセージが表示される

    [191365] 写真を張り付けるとたまにエラーメッセージが表示される-

    ■親トピック/記事引用/メール受信=OFF■

    □投稿者/ さかな -(2020/02/13(18:55))
    □U R L/
      お世話になります。
      使用環境はWIN10・office365(64bit)です。
      VBAの初心者です。
      エクセルに写真を張り付け作業で使用しているのですが、時々ですが、実行時エラー1004・アプリケーション定義またはオブジェクト定義のエラーと出てきます。
      エラー表示はIf Not Intersect(Target, mySh.TopLeftCell) Is Nothing Thenの所が
      黄色表示されます。
      エラー表示は出ないときは全く出ません。
      コードが間違っていたら申し訳御座いませんが、アドバイスのほどよろしくお願い致します。
      失礼します。
      
      Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
      Dim PicFile As Variant, mySh As Shape
      Dim rX As Double, rY As Double
          
      '=======================↓任意のセルに写真を入れたい場合にセル番号を設定する
      If Intersect(Range("b9,b24,i9,i24"), Target) Is Nothing Then Exit Sub
      
      '[ファイルを開く]ダイアログボックスを表示
      PicFile = Application.GetOpenFilename( _
      "画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
      If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub
      
      Application.ScreenUpdating = False
      
      '以前の画像がある場合は消す
      For Each mySh In Me.Shapes
      If Not Intersect(Target, mySh.TopLeftCell) Is Nothing Then
      mySh.Delete
      End If
      Next mySh
      
      '画像を挿入
      Set mySh = Me.Shapes.AddPicture(PicFile, False, True, Target.Left, Target.Height, 0, 0)
      
      With mySh
      .LockAspectRatio = True
      .ScaleWidth 1, True
      .ScaleHeight 1, True
      
      rX = Target.Width / .Width
      rY = Target.Height / .Height
      
      If rX > rY Then
      .Height = .Height * rY
      Else
      .Width = .Width * rX
      End If
      
      'セルの中央(横方向/縦方向の中央)に配置
      .Left = Target.Left + (Target.Width - .Width) / 2
      .Top = Target.Top + (Target.Height - .Height) / 2
      
      rX = .Left: rY = .Top: .Cut
      Me.PasteSpecial Format:="図 (JPEG)"
      Me.Shapes(Me.Shapes.Count).Left = rX
      Me.Shapes(Me.Shapes.Count).Top = rY
      
      End With
      
      Application.ScreenUpdating = True
      Cancel = True
      
      End Sub
      
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191367] Re[1]: 写真を張り付けるとたまにエラーメッセージが表示される-

    記事引用/メール受信=OFF■

    □投稿者/ まっつわん -(2020/02/13(20:52))
    □U R L/
          '以前の画像がある場合は消す
          For Each mySh In Me.Shapes
              If Not Intersect(Target, mySh.TopLeftCell) Is Nothing Then
                  mySh.Delete
                  Exit For
              End If
          Next mySh
      
      ん〜。
      
      止まった時に
      削除したらExit For で、
      ループを抜けた方がいいかもです。
      それでいいかはよくわかんないですが、
      削除したんで、Intersect関数でもうないものを参照しようとしたら、
      エラーにはなりそうです。
      そんなことが有り得るかどうかよくわかんないんですが。。。


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191368] Re[2]: 写真を張り付けるとたまにエラーメッセージが表示される-

    記事引用/メール受信=OFF■

    □投稿者/ kazuo -(2020/02/13(21:04))
    □U R L/
      シート上にたとえば、入力規則があるとその選択ボタンはShapeですが、TopLeftCellを持たないのでエラーになります。
      そのような図は判定対象から除外するか、On Error Resume Nextで処理しても問題無いでしょう。
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191371] Re[3]: 写真を張り付けるとたまにエラーメッセージが表示される-

    記事引用/メール受信=OFF■

    □投稿者/ kazuo -(2020/02/14(12:51))
    □U R L/
      ああ、知恵袋のマクロで画像データの圧縮について教えて下さいのコードそのものですね。
      コードを理解されていないと思いますから、私の指摘だけではちんぷんかんぷんでしょうね。
      
      私なら画像に名前を付けて管理しますが、今回は記載しません。
      >判定対象から除外する  一例
      '以前の画像がある場合は消す
          For Each myPic In Me.Pictures
              If Not Intersect(Target, myPic.TopLeftCell) Is Nothing Then
                  myPic.Delete
              End If
          Next myPic
      
      >On Error Resume Nextで処理  ←だけでは無理でした。
      やはり判定対象から除外ですね。別例
      '以前の画像がある場合は消す
          For Each mySh In Me.Shapes
              Set r = Nothing
              On Error Resume Next
              Set r = mySh.TopLeftCell
              On Error GoTo 0
              If Not r Is Nothing Then
                  If Not Intersect(Target, r) Is Nothing Then mySh.Delete
              End If
          Next mySh
      
      もし、上記でも発生するようなら、止まったときに、
      VBE(VBAコードが記載された画面)の表示-イミデイトウィンドウをして、
      一例のほうなら  ?mypic.name
      別例のほうなら  ?mysh.name
      と入力して出てきた値を報告してください。
      
      なお、可能なら、
      VBEの表示-ローカルウィンドウをして、デバッグにチャレンジしてください。
      


      この記事にはVBAのコードが含まれています。

      緑の太文字→注釈
      茶色の太文字→条件分岐
      赤の太文字→ループ
      青の太文字→その他




    [191372] Re[4]: 写真を張り付けるとたまにエラーメッセージが表示される-

    解決!!ありがとうございました! / 記事引用/メール受信=OFF■

    □投稿者/ さかな -(2020/02/14(16:39))
    □U R L/

      まっつわん 様
      kazuo 様

      アドバイスありがとうございます。
      コードを使用させて頂きます。
      また発生することがありましたらご質問させて頂きます。
      自分もまたVBAをもっと勉強したいと思います。

      ありがとうございました。
      失礼致します。



このトピック内容の全ページ数 / [0]

このトピックに書きこむ
Name/
E-Mail/

└>このツリーのレス記事をメールで受信しますか? YES/ NO/
Title/
URL/
Comment/ 通常モード->  図表モード-> (←の場合適当に改行を入れて下さい)
タグが使用できます。例 ⇒ <font color="blue">文字</font>
解決!!ありがとうございました! 解決       保留中です・・・ 保留        迷宮入りorほかあたって見ます・・ 迷宮入       すいませ〜ん。誰か〜! Help! ←※回答者専用
解決したらチェック       保留(コードテスト中など・・)         解決不可orレスが全く付かなくてほかのサイトに行くときなど・・
削除キー/
(半角8文字以内) 


- Child Forum -
Edit:ゆう-G