[[20111110190836]]　『貼り付けられた画像にその画像ファイルをLINKさせ』（はんにゃ）　ページの最後に飛ぶ

『貼り付けられた画像にその画像ファイルをLINKさせる』（はんにゃ）

 WindowsXP、Excel2003
 いま　マクロでSheet”データ”からimgfilnm（￥像ファイル名.jpg)を読み取り
以下のように、その画像をsheet”系譜図”内の所定の位置に貼り付けています。
 課題：この画像をクリックすると　同じソースの画像が（別のSoftの）既定Viewerで大きく表示する　例えばWebPageの画像に元の像をLINKさせるようなことをする、にはどうしたらよいでしょうか？

    If imgflnm <> "" Then
      Set ic = Sheets("系譜図").Range(Sheets("系譜図").Range("D2").Cells(xrb +

 2, xcb + 1).Address)
          Err.Clear  'エラークリア
      Set secondimg = Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & 
 imgflnm)  '
          If Err.Number <> 0 Then '画像挿入時に何らかのエラーが発生したら
             MsgBox "データ表" & ir & "行の" & ThisWorkbook.Path & imgflnm & " 
 not exist!" & vbLf & Err.Description
          Else
            With secondimg
                .Left = ic.Left:    .Top = ic.Top
            End With
            Set Cn = shp.AddConnector(msoConnectorCurve, 1, 1, 1, 1) 
 'コネクタ描画  ※位置は仮決め　実際には表示後手操作で位置やサイズは調整できる
            Cn.Line.EndArrowheadStyle = msoArrowheadTriangle
            Cn.Line.DashStyle = msoLineDash
            Cn.Line.Weight = 1
            If InStr(Sheets("系譜図").Range("D2").Cells(xrb, xcb), "▼") > 0
    Then
                Cn.Line.ForeColor.RGB = RGB(255, 0, 0)
            Else
                Cn.Line.ForeColor.RGB = RGB(0, 0, 255)
            End If
            With Cn.ConnectorFormat
                .BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
                .EndConnect ConnectedShape:=secondimg.ShapeRange(1), 
  ConnectionSite:=1
                '.Type = msoConnectorElbow
                Cn.RerouteConnections
            End With
          End If  'If Err.Number
    End If ' If imgflnm

 既定Viewerというのが関連付けられたアプリということなら、

 Sub test()
    With CreateObject("Wscript.Shell")
       .Run """D:\My Documents\My Pictures\ラッコ.jpg"""
        '↑これは、例です。ラッコの画像があったので・・。
    End With
 End Sub

 私の環境では、上記でIEに表示されました。

 ユーザーフォームを用意して、イメージコントロールに画像を貼り付ける
 では、駄目なんですか？

 ichinose

 貼り付けた後、表示位置などを調整すると思いますが
 その時にハイパーリンクの設定もしておかれては？

 基本コードは、マクロの記録で得られると思います。

 (HANA)

 ありがとうございます
 まず　ichinoseさん助言のコードで試しました。
 小生の場合WindowsXPではIEではなく　Windows画像とFAXViewerが立ちあがり描画しました
 つぎに　HANAさん助言の記録をして　こーどを得て試しました
 この場合はIEが立ち上がり、表示しました。
 この段階で　教えを乞います。
 1：.Run """D:\My Documents\My Pictures\ラッコ.jpg"""の（"）が３つ要るのですね？
 2：.Run """\ラッコ.jpg"""はNGか　
  BooK1と同じホルダにある画像ファイルでも絶対アドレスを要しますか？
 3：IEは起動に時間が掛かるので、早いWindows画像とFAXViewerが起動しないでしょうか？
　　Wordsではこれが起動します           (hannya)

 >1：.Run """D:\My Documents\My Pictures\ラッコ.jpg"""の（"）が３つ要るのですね？
 My Documents こういう名前があると、
 .Run "D:\My Documents\My Pictures\ラッコ.jpg"

 これだとエラーになります。
 "d:\aaa\aaaa.jpg" だと、

 .Run "d:\aaa\aaaa.jpg"  'これで大丈夫ですが・・・。

 きちんとパス名をわからせるために　"で囲みます。

 文字列としての"は、""と連続して記述するのですよね？

 >BooK1と同じホルダにある画像ファイルでも絶対アドレスを要しますか？

 Thisworkbook.path を使ってみたらよいでしょう・・・。

 どのアプリが起動されるかは、Windowsの設定ですからねえ。

 ichinose

ありがとうございます
以下の画像貼り付けの元のコードに

   If imgflnm <> "" Then
      Set ic = Sheets("系譜図").Range(Sheets("系譜図").Range("D2").Cells(xrb + 2, xcb + 1).Address)
          Err.Clear  'エラークリア
      Set secondimg = Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & imgflnm)  '
          If Err.Number <> 0 Then '画像挿入時に何らかのエラーが発生したら
             MsgBox "データ表" & ir & "行の" & ThisWorkbook.Path & imgflnm & " not exist!" & vbLf & Err.Description
          Else
         End If  'If Err.Number
    End If ' If imgflnm
'   この後の一行を追加した　 Image Highper Link 2011/11/11
       Sheets("系譜図").Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=ThisWorkbook.Path & imgflnm

 しかし、張り付いた画像にLinkはしない。多分Item(1)が　定まらない・埒外の値になったからだと思います。 どのようなコードが良いでしょうか？

 小生　混乱しています
 > .Run "D:\My Documents\My Pictures\ラッコ.jpg"  ' これだとエラーになります。
 > .Run "d:\aaa\aaaa.jpg"  　　　　　　　　　　　　'これで大丈夫ですが・・・。

 ドライブ名の大文字　小文字の違いですか？
(hannya)

すこしわかりました
以下のように　挿入した位置セル？（ic）をSelectして　HyperLink記述をいれました

            With secondimg
                .Left = ic.Left
                .Top = ic.Top

                .Select 'for Hyperlinks.'    Image Hyper Link 2011/11/11
                Sheets("系譜図").Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=ThisWorkbook.Path & imgflnm
            End With
            Set Cn = shp.AddConnector(msoConnectorCurve, 1, 1, 1, 1) 'コネクタ描画 ※位置は仮決め
            Cn.Line.EndArrowheadStyle = msoArrowheadTriangle
            Cn.Line.DashStyle = msoLineDash
            Cn.Line.Weight = 1
            With Cn.ConnectorFormat
                .BeginConnect ConnectedShape:=firstRect, ConnectionSite:=2
                .EndConnect ConnectedShape:=secondimg.ShapeRange(1), ConnectionSite:=1
                '.Type = msoConnectorElbow
                Cn.RerouteConnections
            End With

 するとばっちりLINKしました。ありがとうございました。
 しかし　これまで挿入後の画像の上下左右位置　大きさなどをマウス手動で調整できたのですが
 カーソルは手の形のままで　画像の枠組みがでないので　調整できません。
 操作手順でできるのか　コードを改修しないといけないのか
 両立させる方法はないものでしょうか？　一個か2個なら　一度リンク解除後、位置調整して、再度Linkつけを手操作ですることも可能ですが　すこし数があるので。　(Hannya)

 (hannya)
 わかりました。画像枠内でマウスRをクリックすると枠状態になり、位置・サイズが調整できる
 其の後枠外でマウスLをクリックするとLINK状態になる
 これで期待どうりの働きです。ありがとうございました。

 あと　ViewerがIEではなく、当方WindowsXP　Test　.Runで起動する画像FAX Viewerにするにはどうするかです
 変えたい理由は　立ち上がり時間が遅い、画像表示サイズが簡単に変えられない　(Ctrl＋）もあるが。
 なお　Words.Docでは　同じIEが起動するのですが、Open Document ならびにそれから変換したPDFでは
 画像は 画像FAXViewerが起動表示します

 よろしく　おねがいします

 >ドライブ名の大文字　小文字の違いですか？
 いいえ、Aaa aaaa    パスに空白があるからです。

 新規ブックの標準モジュールにて・・・、

 '=============================================================
 Option Explicit
 Sub insert_pic()
    Dim pic As Picture
    Dim rng As Range
    Set rng = Range("a1:c10")
    On Error Resume Next
    Set pic = ActiveSheet.Pictures.Insert("D:\My Documents\My Pictures\ラッコ.jpg")
                            '↑これは、例です。ラッコの画像があったので・・。

    If Err.Number = 0 Then
       pic.Left = rng.Left
       pic.Top = rng.Top
       pic.Width = rng.Width
       pic.Height = rng.Height
       pic.ShapeRange.AlternativeText = "D:\My Documents\My Pictures\ラッコ.jpg"
       pic.OnAction = "disp_pic"
    End If
    On Error GoTo 0
 End Sub
 '=============================================================
 Sub disp_pic()
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes(Application.Caller)
    If shp.AlternativeText <> "" Then
       On Error Resume Next
       With CreateObject("Wscript.Shell")
          .Run """" & shp.AlternativeText & """"
       End With
       On Error GoTo 0
    End If
 End Sub

 ラッコの画像の変わりに適当な画像ファイルを記述してください。

 insert_picを実行してください。画像がシート上に表示されます。

 この画像をクリックすれば、規定のアプリで表示されると思います。

 規定のアプリは、画像ファイルを右クリックし、アプリから開く　とかプログラムの選択　等と言う項目から指定します。

 ただ、このVBAコードを使うのが不特定多数のＰＣということなら、
 想定外のアプリが立ち上がっても表示されれば、それはそれでよいと思いますよ！！

 ichinose

 こんな回答を以前しましたが、参考になりますか？
[[20090705210700]]　『ハイパーリンクからFAXと画像のﾋﾞｭｰｱへ』（ﾑﾗ）
 （ｍｏｍｏ）

 (hannya) お礼のコメントが　書き込まれなかったようです

改めて　HANAさん　Ichinoseさん　Momoさん　アリがとうございました

 結果　希望どうりのIEの代わりにViewer-画像＆FAXViewerで表示させれました。
       そして　位置サイズ調整と手印MOUSE-Oｎとの切替も容易です

 理解したこと；現行小生のPCでは　
　　　　　　　.RUN　目標ファイルの関連付けのアプリが起動する
　　　　　　　HyperLinkはIEが起動する

 以下が実装したコードです
略
      Set ic = Sheets("系譜図").Range(Sheets("系譜図").Range("D2").Cells(xrb + 2, xcb + 1).Address)
          Err.Clear  'エラークリア
      Set secondimg = Sheets("系譜図").Pictures.Insert(ThisWorkbook.Path & imgflnm)
          If Err.Number <> 0 Then '画像挿入時に何らかのエラーが発生したら
             MsgBox "データ表" & ir & "行の" & ThisWorkbook.Path & imgflnm & " not exist!" & vbLf & Err.Description
          Else
            With secondimg
                .Left = ic.Left
                .Top = ic.Top
                .Width = ic.Width
                .Height = ic.Height
'                .ShapeRange.AlternativeText = ThisWorkbook.Path & "\Nagata-Kamon.JPG"
                .ShapeRange.AlternativeText = ThisWorkbook.Path & imgflnm
                .OnAction = "disp_pic"
'               .Select   'for Image Hyper Link 2011/11/11
'               Sheets("系譜図").Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=ThisWorkbook.Path & imgflnm
            End With
           End If  'If Err.Number

 略
 ' for  ClickOn Viewer 画像＆FAXviewer instead of IE on HyperLink
Private Sub disp_pic()
    Dim shp As Shape
    Set shp = ActiveSheet.Shapes(Application.Caller)
'    Set shp = Sheets("系譜図").Shapes(Application.Caller)
    If shp.AlternativeText <> "" Then
       On Error Resume Next
       With CreateObject("Wscript.Shell")
          .Run """" & shp.AlternativeText & """"
       End With
       On Error GoTo 0
    End If
 End Sub

コメント返信：

[ 一覧(最新更新順) ]

[[20111110190836]] 『貼り付けられた画像にその画像ファイルをLINKさせ』（はんにゃ） ページの最後に飛ぶ

[[20111110190836]]　『貼り付けられた画像にその画像ファイルをLINKさせ』（はんにゃ）　ページの最後に飛ぶ