Re: Insert image to Excel programmatically by Miyahn
Miyahn
Tue Aug 16 09:07:27 CDT 2005
"LBT" wrote in message news:C94EFD33-1611-4C3F-B54B-A4974E7CD692@microsoft.com
> I have another question here. If multiple pictures are going to be inserted
> to the Excel sheet, I face problem to arrange the pictures properly in
> different rows since the size of the pictures is varying.
Take a look at this post.
news:edSRYuBoFHA.3380@TK2MSFTNGP12.phx.gbl
> Anyway I can get the picture to fit into one cell so that the pictures won't
> be overlapped?
Yes you can.
Here is a sample VBA source code for add-in. (not VBScript.)
Attribute VB_Name = "InsertCellPictures"
Option Explicit
' Add-in for Cell-Size Pictures
' Ver. : 1.0
' Translated: 2005/ 8/16
'
Sub Auto_Open()
If Val(Application.Version) < 9 Then
MsgBox "This add-in works on Excel2000 or later."
ThisWorkbook.Close
End If
If Application.CommandBars("Cell").Controls(5).Caption = _
"Insert Cell-Size Pictures" Then
MsgBox "This add-in has already been registered."
ThisWorkbook.Close
End If
If ThisWorkbook.Sheets(1).Names.Count = 0 Then SetNames
With Application.CommandBars("Cell").Controls.Add(Before:=5, _
Temporary:=True)
.Caption = "Set Picture Quality"
.FaceId = 2144
.OnAction = "PictureSetting"
End With
With Application.CommandBars("Cell").Controls.Add(Before:=5, _
Temporary:=True)
.Caption = "Insert Cell-Size Pictures"
.FaceId = 267
.OnAction = "InsertCellSizePicture"
End With
End Sub
Sub SetNames()
With ThisWorkbook.Sheets(1)
.Names.Add "Quality", .Range("$A$1"): .Range("Quality") = 1#
End With
ThisWorkbook.IsAddin = True: ThisWorkbook.Save
ThisWorkbook.Saved = True
End Sub
Sub Auto_Close()
Dim aCtrl As CommandBarControl
For Each aCtrl In Application.CommandBars("Cell").Controls
If aCtrl.Caption = "Insert Cell-Size Pictures" Or _
aCtrl.Caption = "Set Picture Quality" Then aCtrl.Delete
Next aCtrl
End Sub
Sub InsertCellSizePicture()
Dim Mag, aPath
Dim Target As Variant, X As Single, Y As Single, W As Single, H As Single
Dim FName As String, CellRatio As Single
Target = Application.GetOpenFilename( _
"Picture file (*.jpg;*.gif;*.bmp),*.jpg;*.gif;*.bmp", , _
"File(s) Selection", , True)
If TypeName(Target) <> "Variant()" Then Exit Sub
Mag = ThisWorkbook.Sheets(1).Range("Quality")
Application.ScreenUpdating = False
For Each aPath In Target
With ActiveCell
X = .Left: Y = .Top: W = .Width: H = .Height: CellRatio = H / W
End With
ActiveSheet.Pictures.Insert(aPath).Select
With Selection.ShapeRange(1)
.LockAspectRatio = True
If .Height / .Width > CellRatio Then
.Height = H - 4: .Left = X + (W - .Width) / 2: .Top = Y + 2
Else
.Width = W - 4: .Top = Y + (H - .Height) / 2: .Left = X + 2
End If
X = .Left: Y = .Top: H = .Height: W = .Width
.Width = .Width * Mag: .Cut
End With
Select Case LCase(Mid(aPath, InStrRev(aPath, ".") + 1))
Case "jpg", "bmp"
ActiveSheet.PasteSpecial "Picture (JPEG)"
Case "gif"
ActiveSheet.PasteSpecial "Picture (GIF)"
End Select
With Selection.ShapeRange(1)
.Left = X: .Top = Y: .Height = H: .Width = W
End With
ActiveCell.Offset(, 1).Select ' advance to column direction.
Next aPath
Application.ScreenUpdating = True
ActiveCell.Offset(, -1).Select
End Sub
Sub PictureSetting()
Dim Ans, Mag
Mag = Format(ThisWorkbook.Sheets(1).Range("Quality"), "0.0")
Ans = InputBox("Input Picture Quality.(Low 1.0-3.0 High)", "Picture Quality", Mag)
If IsNumeric(Ans) Then
If Ans < 1# Or Ans > 3# Then Ans = 1#
ThisWorkbook.Sheets(1).Range("Quality") = Ans
End If
End Sub
--
Miyahn (Masataka Miyashita) JPN
Microsoft MVP for Microsoft Office - Excel(Jan 2005 - Dec 2005)
HQF03250@nifty.ne.jp