- 日時： 2012/06/06 19:02
- 名前： VBレスキュー(花ちゃん)
- ***********************************************************************************
* カテゴリー：[エクセル][][] *
* キーワード：Excel VBA,Excel2010,画像を表示,拡大,縮小,Pictureオブジェクト *
***********************************************************************************
'===================================================================================================
'投 稿 日：2012.05.05
'投 稿 者：VBレスキュー(花ちゃん)
'タイトル：VB2010 から Excel のセル上に画像を表示及び拡大・縮小
'========1=========2=========3=========4=========5=========6=========7=========8=========9=========0
Private Sub Button8_Click(sender As System.Object, e As System.EventArgs) Handles Button8.Click
Call ExcelOpen("", "") '新規ファイルをオープンして、Excel を起動
'==================== セル上に画像を表示及び拡大・縮小 =======================
'-------------------- 下記のVB6.0用コードを移植 ---------------------------
' http://hanatyan.sakura.ne.jp/vbhlp/Excel12.htm
'１．Pictureオブジェクトを使って表示
'xlSheet.Range("B2").Select()
'xlSheet.Pictures.Insert(MyPath).Select()
'２．クリップボード経由での貼付け
'xlSheet.Range("H2").Select()
'xlSheet.Paste()
'--------------------------------------------------------------------------
'１．Pictureオブジェクト(隠しオブジェクト)を使っての表示
Dim myPath As String = System.IO.Path.GetFullPath(".\Test.gif")
Dim xlRange As Excel.Range
xlRange = xlSheet.Range("B2")
Dim xlPictures As Excel.Pictures
Dim xlPicture As Excel.Picture
'Debug.Print(TypeName(xlSheet.Pictures)) 'Pictures
'面倒でも下記のように変数に受けないと解放されない
xlPictures = DirectCast(xlSheet.Pictures, Excel.Pictures)
xlPicture = xlPictures.Insert(myPath)
'Excel 2007では画像の挿入位置指定が下記のようにしないと指定できません。
With xlPicture
.Top = CDbl(xlRange.Top)
.Left = CDbl(xlRange.Left)
End With
MRComObject(xlPicture)
MRComObject(xlPictures)
MRComObject(xlRange)
'テストの為１秒間表示
System.Threading.Thread.Sleep(1000)
''２．Web 上の画像を指定して、Pictureオブジェクト(隠しオブジェクト)を使っての表示
myPath = "http://www.hanatyan.sakura.ne.jp/toppicture.gif"
xlRange = xlSheet.Range("I2")
xlPictures = DirectCast(xlSheet.Pictures, Excel.Pictures)
xlPicture = xlPictures.Insert(myPath)
With xlPicture
.Top = CDbl(xlRange.Top)
.Left = CDbl(xlRange.Left)
End With
MRComObject(xlPicture)
MRComObject(xlPictures)
MRComObject(xlRange)
'テストの為１秒間表示
System.Threading.Thread.Sleep(1000)
'３．Web 上の画像を指定して、Shapes.Add メソッドを使っての表示
'Excel 2010 で Pictures.Insert メソッドを使用して図をワークシートに挿入すると
'図がリンクオブジェクトとして挿入される
'http://support.microsoft.com/kb/2396509/ja
myPath = "http://www.hanatyan.sakura.ne.jp/toppicture.gif"
Dim xlShapes As Excel.Shapes
xlRange = xlSheet.Range("I15")
xlShapes = xlSheet.Shapes
Dim xlShape As Excel.Shape
'画像のサイズが前もって解らない場合は、適当なサイズで仮取得(縦横共 100ピクセルで)
xlShape = xlShapes.AddPicture(Filename:=myPath, _
LinkToFile:=MsoTriState.msoFalse, SaveWithDocument:=MsoTriState.msoTrue, _
Left:=CSng(xlRange.Left), Top:=CSng(xlRange.Top), Width:=CSng(100), Height:=CSng(100))
'図のサイズを元のサイズに戻します
With xlShape
.ScaleHeight(1.0!, MsoTriState.msoTrue)
.ScaleWidth(1.0!, MsoTriState.msoTrue)
End With
MRComObject(xlShape)
MRComObject(xlShapes)
MRComObject(xlRange)
'テストの為１秒間表示
System.Threading.Thread.Sleep(1000)
'４．クリップボード経由での貼付け
'下記のリンクの画像をクリップボードにコピーしておいてから実行して下さい。
'http://www.hanatyan.sakura.ne.jp/toppicture.gif
Dim iData As IDataObject = Clipboard.GetDataObject()
'クリップボードにBMPファイルがあれば
If iData.GetDataPresent(DataFormats.Bitmap) = False Then
'Excel の裏に隠れたりしますので、オーナーウィンドウ(Me)を指定下さい。
MessageBox.Show(Me, "クリップボード上に画像がありませんので、すぐにコピーして下さい。")
End If
xlRange = xlSheet.Range("M2")
xlRange.Select()
xlSheet.Paste()
MRComObject(xlRange)
'テストの為１秒間表示
System.Threading.Thread.Sleep(1000)
'５．拡大表示（1.25 = 拡大率(1.25倍)で指定）
xlShapes = xlSheet.Shapes
xlShape = xlShapes.Item(1)
xlShape.Select()
xlShape.ScaleWidth(1.25, MsoTriState.msoFalse, MsoScaleFrom.msoScaleFromTopLeft)
xlShape.ScaleHeight(1.25, MsoTriState.msoFalse, MsoScaleFrom.msoScaleFromTopLeft)
MRComObject(xlShape)
MRComObject(xlShapes)
'テストの為１秒間表示
System.Threading.Thread.Sleep(1000)
'６．縮小表示
xlShapes = xlSheet.Shapes
xlShape = xlShapes.Item(2)
xlShape.Select()
xlShape.ScaleWidth(0.75, MsoTriState.msoFalse, MsoScaleFrom.msoScaleFromTopLeft)
xlShape.ScaleHeight(0.75, MsoTriState.msoFalse, MsoScaleFrom.msoScaleFromTopLeft)
MRComObject(xlShape)
MRComObject(xlShapes)
'テストの為１秒間表示
System.Threading.Thread.Sleep(1000)
'=============================================================================
'Excelファイルを上書き保存(True 又省略すれば)して終了処理を実行
Call ExcelClose(IO.Path.GetFullPath(".\Test.xlsx"), False) 'False の場合保存しないで終了
'Excel.EXE がタスクマネージャに残っていないか調査(実使用時は必要なし)
Call ProcessCheck()
End Sub
|
VB2010からExcelのセル上に画像を表示及び拡大・縮小(VB.NET)