InSheet_ChangeImage

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

CodeFunctionName
What is this?

Public

Tested

Original Work
' 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



None

Views 717

Downloads 199

CodeID
DB ID