VBにおいて，セルから画像を読み込むことは可能ですか？

写真のように、その問題によって、写真が変わるようにしたいのです。

VBでセルからの画像の読み込みの仕方を詳しく説明してほしいのです。

よろしくお願いします。

No.2 ベストアンサー 回答者： end-u 回答日時： 2010/01/09 22:53

添付画像から判断して、VBというよりExcelVBAでの手法という事で良いですね？

【画像の元ファイルがある場合】
PCのローカルに画像の元ファイルがあり、それをシート上に配置している場合は
元画像のフルパスが解るでしょうから、比較的簡単です。
仮にActiveSheetのE2セルに "C:\temp\test.jpg" など、ファイル名がフルパスではいっている場合はそれを参照します。

Private Sub CommandButton1_Click()
　　Dim fn As String
　　
　　fn = ActiveSheet.Range("E2").Value
　　If Len(Dir(fn)) = 0& Then
　　　　MsgBox "no file"
　　Else
　　　　Dir Application.Path
　　　　With Me.Image1
　　　　　　.PictureSizeMode = fmPictureSizeModeZoom
　　　　　　.Picture = LoadPicture(fn)
　　　　End With
　　End If
End Sub


【画像の元ファイルがない場合】
ちょっと厄介です。
簡易的にChartのExport機能を使う方法もありますが、画像の質は落ちます。

Private Sub CommandButton2_Click()
　　Const f As String = "c:\temp\test."
　　Const e As String = "jpg"
　　Dim r　 As Picture

　　On Error GoTo errHndr
　　Set r = ActiveSheet.Pictures(1)
　　r.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
　　With Workbooks.Add(xlWBATWorksheet)
　　　　With .Sheets(1).ChartObjects.Add(0, 0, r.Width, r.Height).Chart
　　　　　　.Paste
　　　　　　.ChartArea.Border.LineStyle = 0 '※
　　　　　　.Shapes(1).Left = -3.4　　　　　'※
　　　　　　.Shapes(1).Top = -3.4　　　　　 '※
　　　　　　.Export Filename:=f & e, Filtername:=e
　　　　End With
　　　　.Close savechanges:=False
　　End With
　　With Me.Image1
　　　　.PictureSizeMode = fmPictureSizeModeZoom
　　　　.Picture = LoadPicture(f & e)
　　End With

errHndr:
　　Set r = Nothing
　　If Err().Number <> 0 Then MsgBox Err().Number & ":" & Err().Description
End Sub
'※は2007ではあまり効果ないみたい

きっちりやろうとするならWindowsAPI関数を使う事になります。
『CopyPictureOf』をキーワードにgoogle検索してください。

この回答へのお礼

ありがとうございました。

この方法で出来ました!!

お礼日時：2010/01/10 16:49

No.1 回答者： mitarashi 回答日時： 2010/01/09 21:16

詳しく説明するのはご容赦いただきますが、A列の値変化に伴い、E列の画像パスが変化する様に、VLOOKUPなどで構築してあるとして当該行のD列にある画像を削除し、新たな画像を読み込むシートのイベントマクロのコードです。

当方XL2000なので、上位バージョンで動かなかったら悪しからず。
Private Sub Worksheet_change(ByVal Target As Range)
Dim filename As String
Dim myPic As Picture
Dim myCell As Range

If Target.Column <> 1 Then Exit Sub
If Target.Cells.Count > 1 Then Exit Sub
Application.ScreenUpdating = False
Set myCell = Target.Offset(0, 3)
filename = myCell.Offset(0, 1).Value
For Each myPic In ActiveSheet.Pictures
If Not Intersect(myPic.TopLeftCell, myCell) Is Nothing Then
myPic.Delete
End If
Next myPic
myCell.Activate
Set myPic = ActiveSheet.Pictures.Insert(filename)
With myPic
.Top = myCell.Top
.Left = myCell.Left
.Width = myCell.Width
.Height = myCell.Height
End With
Set myPic = Nothing
Application.ScreenUpdating = True
End Sub

参考URL：http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/v …