« フォルダー名の表示と変更(VBA) | トップページ | Excel図書管理Ver2.02にアップ »

2010年3月 7日 (日)

画像をシート上に貼り付ける

画像(写真など)を選択して、アクティブセルにそのセルの大きさに縮小して貼り付け、さらに元ファイルへのハイパーリンクを設定し、リンク先urlをその1つ下のセルに代入するマクロです。

Sub 画像を貼り付ける()
    ' Excel 2007で確認:画像・写真を貼り付ける
Dim StrFilter As String
Dim 画像ファイル As Variant
Dim Tate As Single
Dim Yoko As Single
Dim Top As Single
Dim Left As Single
Dim PicData As Object

' Tate = ActiveCell.Height
Tate = ActiveCell.MergeArea.Height
' Yoko = ActiveCell.Width
Yoko = ActiveCell.MergeArea.Width

画像ファイル = ""
StrFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"

画像ファイル = Application.GetOpenFilename(FileFilter:=StrFilter, _
             FilterIndex:=1, _
             Title:="画像ファイルを選択してください。", _
             MultiSelect:=False)

If 画像ファイル = "False" Then Exit Sub

Top = ActiveCell.Top
Left = ActiveCell.Left

' ActiveSheet.Pictures.Insert(画像ファイル).Select
' Selection.ShapeRange.ScaleWidth 倍率, msoFalse, msoScaleFromTopLeft
' Selection.ShapeRange.ScaleHeight 倍率, msoFalse, msoScaleFromTopLeft

' ActiveSheet.Shapes.AddPicture 画像ファイル, True, True, Left, Top, Yoko, Tate
Set PicData = ActiveSheet.Shapes.AddPicture(画像ファイル, True, True, Left, Top, Yoko, Tate)
' AddPicture(Filename, LinkToFile, SaveWithDocument, Left, Top, Width, Height)
' Filename 必須 文字列型 (String) OLE オブジェクトを作成するグラフィック ファイルを指定します。
' LinkToFile 必須 MsoTriState 図をグラフィック ファイルとリンクするかどうかを指定します。
' SaveWithDocument 必須 MsoTriState 文書を保存するときに図も一緒に保存するかどうかを指定します。
' Left 必須 単精度浮動小数点型 (Single) 文書の左上隅を基準にして図の左上隅の位置をポイント単位で指定します。
' Top 必須 単精度浮動小数点型 (Single) 文書の上端を基準にして図の左上隅の位置をポイント単位で指定します。
' Width 必須 単精度浮動小数点型 (Single) 図の幅をポイント単位で指定します。
' Height 必須 単精度浮動小数点型 (Single) 図の高さをポイント単位で指定します。

' 画像にハイパーリンクを設定
ActiveSheet.Hyperlinks.Add Anchor:=PicData, Address:=画像ファイル
' リンク先をセルに代入しハイパーリンクを設定する
ActiveCell.Offset(1).Value = 画像ファイル
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell.Offset(1), Address:=画像ファイル
ActiveCell.Offset(1).ShrinkToFit = True

Set PicData = Nothing

ActiveCell.Offset(, 1).Select

End Sub

シート上の画像を近いセルに自動で合わせるマクロです。図形をマクロボタンにしているのを前提とし、また前出での処理で貼り付けた画像を前提としているので、shapesのタイプをmsoLinkedPictureとし、図形については処理外としています。

Sub 画像の大きさをセルに合わせる()

   Dim pic As Shape
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoLinkedPicture Then
    '   If pic.Type = msoPicture Then
            With pic.TopLeftCell
                pic.LockAspectRatio = msoFalse
                pic.Top = .Top
                pic.Left = .Left
                pic.Width = .MergeArea.Width
                pic.Height = .MergeArea.Height
            End With
        End If
    Next
End Sub

画像を貼り付けると、画像の大きさの問題などがあり、データとして整理しておくにはリンク先のみのurl情報だけあればよいのではないかという考えもあるので、画像を確認して選択するが、そのリンク先情報のみをセルに代入する処理も考えてみた。

Sub 選択ファイルのリンク先名をパイパーリンク()
Dim StrFilter As String
Dim 画像ファイル As Variant

画像ファイル = ""
StrFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"

画像ファイル = Application.GetOpenFilename(FileFilter:=StrFilter, _
             FilterIndex:=1, _
             Title:="画像ファイルを選択してください。", _
             MultiSelect:=False)

If 画像ファイル = "False" Then Exit Sub
' リンク先をセルに代入しハイパーリンクを設定する
' ActiveCell.Value = 画像ファイル
ActiveSheet.Hyperlinks.Add Anchor:=ActiveCell, Address:=画像ファイル
ActiveCell.ShrinkToFit = True

ActiveCell.Offset(, 1).Select

End Sub

|

« フォルダー名の表示と変更(VBA) | トップページ | Excel図書管理Ver2.02にアップ »

「ExcelVBA」カテゴリの記事

コメント

コメントを書く



(ウェブ上には掲載しません)




« フォルダー名の表示と変更(VBA) | トップページ | Excel図書管理Ver2.02にアップ »