2017年06月23日

【Exel VBA】ハイパーリンクの画像を自動貼り付け関数

Excelのメニューから 開発 ー Visual Bbasic
→ VBAProjectを右クリック → 挿入 → 標準モジュール
→ 以下のコードを貼り付け

ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
'指定セルにハイパーリンクされた画像ファイルのフルパスをカレントセルに表示し、
'その画像を左隣セルに貼りつける関数
'---- pic_paste(セル番号)----
'
Function pic_paste(fname As Range)
Const n As Long = 2 'margin
Dim r As Range
Dim i As Long
Dim x As Double
Dim s As String

Set r = Application.ThisCell.Offset(0, 1).MergeArea

If fname.Hyperlinks.Count > 0 Then
s = fname.Hyperlinks(1).Address
Else
s = "--"
End If

ChDir ActiveWorkbook.Path

If Dir(s) = "" Then
pic_paste = s
Else
'Dir Application.Path
pic_paste = s
With ActiveSheet.Pictures.Insert(s).ShapeRange
.LockAspectRatio = msoTrue
x = Application.Min(r.Width / .Width, (r.Height - n) / .Height)
.Width = .Width * x
.Left = r.Left
.Top = r.Top + n / 2
End With
End If

End Function
ーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーーー
posted by 貝貝 at 09:23| Comment(0) | TrackBack(0) | Windows | このブログの読者になる | 更新情報をチェックする
この記事へのコメント
コメントを書く
お名前:

メールアドレス:

ホームページアドレス:

コメント:

認証コード: [必須入力]


※画像の中の文字を半角で入力してください。

この記事へのトラックバック