Allows users to inserts image into sheet, replacing old one, with ability to insert any type of images, including png, wmf in addition to jpg, gif, etc.
This was part of bigger project finished last week.
You will need function BrowseImage and ...
Create box shape with transparent fill, assign it macro below
' Create box shape with transparent fill, assign it macro below
Sub InSheet_ChangeImage()
Fii = BrowseImage()
If Fii = "False" Then Exit Sub
If Fii = "" Then Exit Sub
Dim Img1 As Shape
She1 = ActiveSheet.Name
ImgInOut_Top = 52
ImgInOut_Left = 18
imgInOut_Width = 279
ImgInOut_Height = 310
For Each Picc In ThisWorkbook.Worksheets(She1).Shapes
If UCase(Left(Picc.Name, 7)) = "PICTURE" Then
Picc.Delete
End If
Next
Set Img1 = ThisWorkbook.Worksheets(She1).Shapes.AddPicture( _
FileName:=Fii, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=ImgInOut_Left, Top:=ImgInOut_Top, _
Width:=-1, Height:=-1)
With Img1
.ZOrder msoSendToBack
MyW = 0
MyH = 0
MyT = ImgInOut_Top
MyL = ImgInOut_Left
If .Width < imgInOut_Width And .Height < ImgInOut_Height Then
If .Width >= .Height Then
MyW = imgInOut_Width
Else
MyH = ImgInOut_Height
End If
ElseIf .Width >= .Height Then
MyW = imgInOut_Width
Else
MyH = ImgInOut_Height
End If
If MyW > 0 Then .Width = MyW
If MyH > 0 Then .Height = MyH
DoEvents
If .Width < imgInOut_Width Then ' center horizontally
MyL = MyL + ((imgInOut_Width - .Width) / 2)
End If
.Left = MyL
' .Top = ThisWorkbook.Worksheets(She1).Range("A3").Top
DoEvents
End With
Set Img1 = Nothing
DoEvents
End Sub
Sub InSheet_ChangeImage()
Fii = BrowseImage()
If Fii = "False" Then Exit Sub
If Fii = "" Then Exit Sub
Dim Img1 As Shape
She1 = ActiveSheet.Name
ImgInOut_Top = 52
ImgInOut_Left = 18
imgInOut_Width = 279
ImgInOut_Height = 310
For Each Picc In ThisWorkbook.Worksheets(She1).Shapes
If UCase(Left(Picc.Name, 7)) = "PICTURE" Then
Picc.Delete
End If
Next
Set Img1 = ThisWorkbook.Worksheets(She1).Shapes.AddPicture( _
FileName:=Fii, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=ImgInOut_Left, Top:=ImgInOut_Top, _
Width:=-1, Height:=-1)
With Img1
.ZOrder msoSendToBack
MyW = 0
MyH = 0
MyT = ImgInOut_Top
MyL = ImgInOut_Left
If .Width < imgInOut_Width And .Height < ImgInOut_Height Then
If .Width >= .Height Then
MyW = imgInOut_Width
Else
MyH = ImgInOut_Height
End If
ElseIf .Width >= .Height Then
MyW = imgInOut_Width
Else
MyH = ImgInOut_Height
End If
If MyW > 0 Then .Width = MyW
If MyH > 0 Then .Height = MyH
DoEvents
If .Width < imgInOut_Width Then ' center horizontally
MyL = MyL + ((imgInOut_Width - .Width) / 2)
End If
.Left = MyL
' .Top = ThisWorkbook.Worksheets(She1).Range("A3").Top
DoEvents
End With
Set Img1 = Nothing
DoEvents
End Sub
None
Views 728
Downloads 207
CodeID
DB ID