エクセルマクロで相対パスから画像を読み込む方法

このQ&Aのポイント
  • エクセルのマクロを使用して相対パスから画像を読み込む方法について教えてください。
  • 以前は絶対パスで画像を読み込んでいましたが、相対パスでも読み込めるようにしたいです。
  • 具体的なセルの配置などの情報も教えてください。
回答を見る
  • ベストアンサー

エクセル マクロ 相対パスから画像を読み込みたいです。

エクセル マクロ 相対パスから画像を読み込みたいです。 以前、こちらで同様の質問をして無事に解決していただきました。  ↓ 「エクセル マクロ フルパスから画像を読み込む」(回答番号:No.1) http://okwave.jp/qa/q5527067.html この時は、絶対パスから画像を読み込む方法を教えていただいたのですが、 相対パスでも読み込むようにできるでしょうか (相対パスに変えたら画像が表示されませんでした)。 ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ ■表の内容 【Sheet1】…(商品在庫一覧) 【Sheet2】…「印刷用シート」※必要なデータだけをSheet1から呼び出し、印刷用として同じシート上で並べ替える(図では‘行5’から下が印刷範囲です) ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ Sheet2のD列(D1~D3‥)に商品画像の「絶対パス」を呼び出しておき、 「写真を配置」のボタンを押すと、印刷範囲の‘行7’のセルに自動で画像が配置されます (‘あ’のパスの画像が‘い’のセルに)。 今までは自分のパソコンのみでこの表を使っていたのですが 他の複数のパソコンでも使用することになり、 絶対パスではフォルダ名(C:\Documents ~)がそれぞれ違うため 相対パスで読み込めたら…と思っています。 ※並び替えなどがあってD列に直接リンクを貼ることができないので、  別に呼び出しておいた「ファイル名」と「C:\Documents ~(格納場所)」を  CONCATENATE関数でくっつけています。 ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ ■構文(教えていただいたものをそのまま貼り付けています。すみません) Private Sub photo_1() Const n As Long = 2 'margin Dim r As Range 'Loop用 Dim tr As Range '読み込みセル用 Dim s As String 'セル文字列 Dim X As Double '縦横比固定での縮小率 Dim i As Long With Sheets("【Sheet1】") For Each r In .Range("D1", "D3") s = r.Value If Len(s) = 0 Then Exit For i = i + 1 If Len(Dir(s)) > 0 Then Set tr = .Cells(7, i + 2) With .Pictures.Insert(s).ShapeRange .LockAspectRatio = msoTrue X = Application.Min((tr.Width - n) / .Width, (tr.Height - n) / .Height) .Width = .Width * X .Left = tr.Left + (tr.Width - .Width) / 2 .Top = tr.Top + (tr.Height - .Height) / 2 End With End If Next (-略-) End With '念のためファイルを解放 Dir Application.Path Set tr = Nothing End Sub ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ どうぞよろしくお願いいたします。

質問者が選んだベストアンサー

  • ベストアンサー
  • myRange
  • ベストアンサー率71% (339/472)
回答No.1

このブックと画像を同じフォルダーに入れておくと Thisworkbook.Pathでブックのパスが取得できるのでそれを利用したらどうでしょう。 現在、Sheet1の画像はフルパスになってますが、 パスは、ThisWorkbook.Pathで取得しますので 画像ファイルの名前だけにしてください。 例えば、Pic1.jpg とか。。 下記●のコード1行追加するだけです。 '---------------------------------- For Each r In .Range("D1", "D3") s = r.Value If Len(s) = 0 Then Exit For s = ThisWorkbook.Path & "¥" & s  '●これを追加 i = i + 1 If Len(Dir(s)) > 0 Then '---------------------------------------------- ■■注意■■ 追加コードの "¥" は上記では全角になってますが、実際では半角の¥にすること 以上です。  

yooko0108
質問者

お礼

myRange様 先ほど補足を入力してすぐに 「ん?相対パスでもいいのなら…」 と思って色々試してみたところ、画像を表示することができました! 「HYPERLINK関数」で呼び出したパスの頭に「..¥」を足したらできました。 びっくりです。 ちょっと急いでいたのでとても助かりました! どうもありがとうございました。

yooko0108
質問者

補足

素早いご回答ありがとうございます! 質問に書き忘れていたのですが、画像を種類ごとにいくつかのフォルダに分けています。 ・ブックを1階層とすると3階層まで ・最終のフォルダ数は30フォルダ(画像数:合わせて5000枚)) 後から大事な情報を申し上げてすみません。 ※■←ブック/□←フォルダ とすると ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ 階層1 ■ □…画像フォルダ ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ 階層2 □…Aフォルダ □…Bフォルダ □…Cフォルダ □…Dフォルダ ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ 階層3 □□□□□□□□□□□□□ (Aフォルダの中:13フォルダ) □□□□□□□□□□ (Bフォルダの中:10フォルダ) □□□□ (Cフォルダの中: 5フォルダ) □□ (Dフォルダの中: 2フォルダ) ↑それぞれに「.jpg画像」が入っている ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ という構成です。 (関係ないかもしれませんが)今の自分でもできることは 「あらかじめ関数で※のようにパスを文字列として呼び出しておくこと」 ぐらいでしょうか。 ※..\画像フォルダ\Aフォルダ\最後のフォルダ\いちご01.jpg もしお時間がありましたら、ヒントをいただけると大変助かります。 自分でも教えていただいたコードを元に調べてみたいと思います。 よろしくお願いいたします。

関連するQ&A

  • エクセル マクロ セルの値が変わった時、自動でマクロを実行させたいです

    エクセル マクロ セルの値が変わった時、自動でマクロを実行させたいです。 以前、こちらで教えていただいたコードで下のような表を作りました。 ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ ■ボタンを押すと画像が配置される表 【Sheet1】…商品在庫一覧表(テキスト情報&商品画像のパス) 【Sheet2】…  1、Sheet1から必要なデータだけを関数で呼び出しておく  2、印刷用の体裁として6行目以下に並び替え(テキスト情報は‘=’で自動配置)、    「画像を配置」ボタンをトリガーにして画像を配置    (※D列の画像のパスを行7に(あ→い))  3、「リセット」ボタンで画像を削除 ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ 社内でとても便利に使っておりましたが 「毎回ボタンを押すのが面倒くさい」という意見があり、 自動で配置できないかと思っています。 やりたいこと ※A1~D3列が変わった時点で(ボタンを押さずに)6行目以下に画像を表示させたい ※「リセット」ボタンを押さなくても、次の更新があった時点で古い画像が削除され  新しい画像が配置されるようにしたい ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ ■現在の構文(教えていただいたものをほぼそのまま貼り付けています。すみません) Private Sub photo_1() '←「画像を表示」ボタン(★) Const n As Long = 2 'margin Dim r As Range 'Loop用 Dim tr As Range '読み込みセル用 Dim s As String 'セル文字列 Dim X As Double '縦横比固定での縮小率 Dim i As Long With Sheets("【Sheet2】") For Each r In .Range("D1", "D3") s = r.Value If Len(s) = 0 Then Exit For i = i + 1 If Len(Dir(s)) > 0 Then Set tr = .Cells(7, i) With .Pictures.Insert(s).ShapeRange .LockAspectRatio = msoTrue X = Application.Min((tr.Width - n) / .Width, (tr.Height - n) / .Height) .Width = .Width * X .Left = tr.Left + (tr.Width - .Width) / 2 .Top = tr.Top + (tr.Height - .Height) / 2 End With End If Next (-略-) End With '念のためファイルを解放 Dir Application.Path Set tr = Nothing End Sub Private Sub photo_2() '←「リセット」ボタン(★) Sheets("【Sheet2】").Pictures.Delete End Sub ‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥‥ (★)の部分をなくして自動化したいです。 「Worksheet_Calculate(Change?)」というのでできるらしい… と知って色々やってみましたが、うまくいきません。 お時間がありましたら教えてください。 どうぞよろしくお願いいたします。

  • エクセル マクロ

    エクセルのある特定のセルをダブルクリックすると 画像ファイルを参照しにいき 貼りつけたい画像ファイル選ぶと そのセルの大きさに合わせて 画像ファイルがそのセルに 貼りつくというマクロが以下の通りなんですが Excel2003からExcel2007へ変更すると 画像ファイルの貼りつく位置がダブルクリックしたセルではない所に 貼りつくようになりました 参照や大きさなどはちゃんと機能しているようです どこを変更すればよいでしょうか? Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Range('特定のセル)) Is Nothing Then Exit Sub Cancel = True Dim myPic Dim myRange As Range Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 .Top = .Top + (myRange.Height - .Height) / 2 End With Application.ScreenUpdating = True Cancel = True End Sub

  • Excelのパスが格納されている列の隣の列に画像を自動で表示させたい

    こんにちは。いつも過去ログを大変参考にさせていただいております。 今回も過去Q&Aを探したのですが、何分コーディングの基本を知らずに回答欄のコピペで済ましているため、自分で問題点を見つけることができません。 <質問内容> Bの列に画像のフルパスを入れてあります。その画像をAの列に自動で表示させるマクロボタンを作りたいのです。B列の2枚目までは上手く写真が表示されます。 しかし、パスが入っていない3列目はC:\NoPicture.jpgを表示させたいのですが、どうしてもそこで止まってしまい、 実行時エラー’1004:’ Picture クラスのInsert プロパティを取得できません。 とういうエラーメッセージが出ます。 正しいコードの書き方をどなたかお教えいただけますでしょうか? <問題点?> 'r.Item(1).Value = s With .Pictures.Insert(s).ShapeRange この辺がうまくいっていないかと・・ <シート内容> 行  列 1  A(画像表示)  B(画像のフルパス)   2             C:\teet01.JPG 3             C:\teet02.JPG 4               (空白) 5              C:\teet03.JPG . . 20               C:\teet19.JPG <マクロ文> Private Sub CommandButton1_Click() Const n As Long = 2 'margin Dim r As Range Dim i As Long Dim x As Double Dim s As String With ActiveSheet    For i = 2 To .Cells(.Rows.Count, 2).End(xlUp).Row '(B)セルは"2", 2行目から順にパスを取得      Set r = .Cells(i, 1).MergeArea '(A)セルは"1"      s = Cells(i, 2).Value      If Dir(s) = "" Then      s = "C:\NoPicture.jpg" '画像が無い場合NoPicture画像を表示    Else     Dir Application.Path    End If    'r.Item(1).Value = s    With .Pictures.Insert(s).ShapeRange    .LockAspectRatio = msoTrue '縦横比固定    x = Application.Min(r.Width / .Width, r.Height / .Height)    If x < 1 Then .Width = .Width * 60 '画像の幅    .Left = r.Left + (r.Width - .Width) / 2 '画像を左右中央に配置    .Top = r.Top + (r.Height - .Height) / 2 '画像を上下中央に配置    End With    Next   End With   Set r = Nothing End Sub

  • エクセル マクロ 画像についての質問です。

    エクセル マクロについての質問です。 下記のコードでセルに画像を合わせて貼り付け、表を作成しています。 が、このコードだと画像の保存先を移動させると画像が表示されなくなり、分類でフィルターをかけるとバラバラの違う画像が表示されてしまったりして困っています・・・。 どなたか良いご意見を頂ければと思い、投稿しました。よろしくお願いします! Sub PictFit() Dim PicFile As String Dim Pic As Picture PicFile = Application.GetOpenFilename() '画像のパスを取得 If PicFile = "False" Then Exit Sub Set Pic = ActiveSheet.Pictures.Insert(PicFile) '画像を貼り付ける With Pic .Height = ActiveCell.MergeArea.Height '画像の高さ .Top = ActiveCell.Top '画像の上位置を変更 .Left = ActiveCell.Left + (ActiveCell.MergeArea.Width - .Width) / 2 '画像の横位置を変更(セル幅中央に画像中央) End With End Sub

  • エクセルのマクロで画像を貼り付け 

    画像をエクセルに貼り付ける作業を行っています。 マクロを使いファイル内の画像(約30枚程度)を1列づつスペースを空け 右方向に4枚 1行スペースを空け 3行目の左に戻り その位置よりまた1列づつスペースを空け右方向に4枚・・・・・ これを繰り返しファイル内の画像をすべて 貼り付けたいのですがうまく動作が出来ません。 何卒ご教授の程よろしくお願いします。 ※マクロ Sub EggFunc_pasteDirImage() ' 変数定義 Dim fileName As String Dim targetCol As Integer Dim targetRow As Integer Dim targetCell As Range Dim shell, myPath Dim pos As Integer Dim extention As String Dim isImage As Boolean ' 選択セルを取得 targetCol = ActiveCell.Column targetRow = ActiveCell.Row ' フォルダ選択画面を表示 Set shell = CreateObject("Shell.Application") Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\Users\0602116.MS\Desktop\") Set shell = Nothing ' フォルダを選択したら... If Not myPath Is Nothing Then fileName = Dir(myPath.Items.Item.Path + "\") Do While fileName <> "" ' ファイル拡張子の判別 isImage = True pos = InStrRev(fileName, ".") If pos > 0 Then Select Case LCase(Mid(fileName, pos + 1)) Case "jpeg" Case "jpg" Case "gif" Case Else isImage = False End Select Else isImage = False End If ' 拡張子が画像であれば If isImage = True Then ' 貼り付け先を選択 Cells(targetRow, targetCol).Select Set targetCell = ActiveCell ' 画像読込み ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select ' 画像が大きい場合、画像サイズをセル幅に合わせる If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then Selection.Height = Selection.Height * (targetCell.Width / Selection.Width) Selection.Width = targetCell.Width Else Selection.Width = Selection.Width * (targetCell.Height / Selection.Height) Selection.Height = targetCell.Height End If End If ' 表示位置をセル中央に移動 Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) / 2 Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) / 2 ' 貼り付け先行を+1 targetCol = targetCol + 2 End If fileName = Dir() Loop MsgBox "画像の読込みが終了しました" End If End Sub

  • エクセルVisualBasicマクロ詳しい方

    写真を特定のセルに貼り付けるのにダブルクリックでマイドキュメントがでるようにし、 写真を貼り付けるとサイズを枠に調節するようにマクロをつくりました。 問題なく出来るようになったのですが、 ダブルクリックでマイドキュメントではなく、 別の場所を指定するにはどこをどう変えればいいですか? 現状は以下の通りです。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) If Intersect(Target, Union(Range("A1:A21"))) Is Nothing Then Exit Sub Cancel = True Dim myPic Dim myRange As Range '画像を配置するセル範囲 Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 End With Application.ScreenUpdating = True Cancel = True End Sub

  • マクロでセルに入れたファイル名の画像を隣のセルに読

    みこむ。 マクロで「セルに入れたファイル名の画像を隣のセルに読み込む」作業をVBA でつくりました。 そのファイル名がないときは、飛ばすようにできないでしょうか。 「 Set myPic = ActiveSheet.Pictures.Insert(sCurDir & myCell.Value & ".JPG")」 ここでとめられてしまいます。    A(No)  B(名)    C(画像) --------------------------------------------- 1   1   test01   D:\画像\teet01.JPG 2   2   test02   D:\画像\teet02.JPG 3   3   test03   D:\画像\teet03.JPG Private Sub CommandButton1_Click() Dim i As Long Dim myPic As Object Dim myCell As Range Dim sCurDir As String sCurDir = ThisWorkbook.Path & "\画像\" For i = 6 To Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row Step 6 Set myCell = Range("B" & i) Set myPic = ActiveSheet.Pictures.Insert(sCurDir & myCell.Value & ".JPG") With myPic .Left = Range("C" & i).Left .Top = Range("C" & i).Top .Width = Range("C" & i).MergeArea.Width .Height = Range("C" & i).MergeArea.Height End With Set myPic = Nothing Next i End Sub

  • エクセル貼付けの画像がメール添付で表示されません

    下記のようなVBA(ネット公開されているものを利用させていただいています)を使用し、エクセルに画像を貼り付けています。 画像を貼り付けたエクセルを保存後、メールに添付すると貼り付けた画像が表示されなくなります。 ファイルの容量も少なく、エクセルに取り込んだ画像は、リンク貼り付けになっているのかと考えていますが、取り込んだ画像を埋め込むにはどのようにすればいいでしょうか。 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) Dim myPic Dim myRange As Range '画像を配置するセル範囲 Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 End With Application.ScreenUpdating = True Cancel = True End Sub

  • Excelセルのサイズに合わせて画像を表示させたい

    Excelのセルの中に、画像ファイル(撮影された写真)のサイズを挿入するときに、セルのサイズに合わせて画像を表示させたいと考え、インターネット上でVBの下記のマクロを探してみました。  セルをダブルクリックすると、画像ファイルの読み出しが行なわれるのですが、セルのサイズにピッタリと合わず、 「列」にわずかに隙間が空いてしまいます・・・。  セルのサイズに合わせる為にはどうすればよいでしょうか?  もう一つ質問させていただきたいのですが、一部の画像は読み出しだ際に、縦にして自動的に表示させたいです。 (これまではExcelの「図の書式設定」で-90度と手入力していました)  何卒宜しくお願い致します。    Excel2003  Visual Basic 6.5 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _ Cancel As Boolean) Dim myPic Dim myRange As Range '画像を配置するセル範囲 Dim rX As Double, rY As Double myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif") If VarType(myPic) = vbBoolean Then Exit Sub Set myRange = Target 'このセル範囲に収まるように画像を縮小する Application.ScreenUpdating = False With ActiveSheet.Pictures.Insert(myPic).ShapeRange rX = myRange.Width / .Width rY = myRange.Height / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置 .Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置 End With Application.ScreenUpdating = True Cancel = True End Sub

  • エクセルVBAでの画像ファイル名取得他

    VBAについての質問です。 http://hp.vector.co.jp/authors/VA033788/kowaza.html#0158 上記をベースに、なんとかVBAを下記のように書き換えました。 Sub LoadPictures3() Dim Fnames As Variant Dim Fn As Variant Dim i As Integer Dim Pic As Picture Dim R As Range Dim R2 As Range Dim Pc As Integer Fnames = Application.GetOpenFilename("図(*.jpg;*.gif),*.jpg;*.gif", MultiSelect:=True) If TypeName(Fnames) = "Boolean" Then Exit Sub Application.ScreenUpdating = False '一枚目の貼付け位置 Set R = Range("B5") Set R2 = R.Offset(35) Pc = 0 For i = 1 To UBound(Fnames) Set Pic = ActiveSheet.Pictures.Insert(Fnames(i)) Select Case (i - 1) Mod 4 + 1 Case 1 Pc = Pc + 1 If Pc >= 2 Then ActiveSheet.HPageBreaks.Add R2 End If With R Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 2 With R.Offset(0, 6) '一枚目に対する二枚目の相対位置 Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 3 With R.Offset(18, 0) Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With Case 4 With R.Offset(18, 6) Pic.Left = .Left Pic.Top = .Top Pic.Width = 300 Pic.Height = 225 End With '次ページの相対位置 Set R = R.Offset(39) End Select Next Application.ScreenUpdating = True End Sub ここで、画像の上の位置(B5のセル位置の画像の場合、B4)に 元々の画像ファイル名を取得し、表記させたいのですが 調べた所、multiselect:=Trueで複数ファイルを選択するときに 画像名が図1、図2に変わっているようで、どうしていいかわかりません。 後、画像を300×225の「変倍」画像にしたいのですが どのようにすれば可能でしょうか? 全くVBAの知識がなく、上のURLを参考に、単語を調べつつ書き換えている状態で、変数やらなんやらの指定・書き方等わかりません。 どなたかご教授願います。

専門家に質問してみよう