Put Excel embedded object icon in a cell.

I am trying to attach/put embedded object in cell. I recorded a Macro. However, I have no control over the embedded icon. I want to put that embedded icon in a cell. Range("D20")=....

Any help.

Sub Macro1()
'
' Macro1 Macro

    ActiveSheet.OLEObjects.Add(Filename:= _
        "C:\Documents\PDF\Lecture_7.pdf", Link:=False, DisplayAsIcon:= _
        True, IconFileName:= _
        "C:\Windows\Installer\{AC76BA86-1033-F400-7760-000000000004}\_PDFFile.ico", _
        IconIndex:=0, IconLabel:="C:\Documents\PDF\Lecture_7.pdf"). _
        Select
End Sub
fmuftiAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Rory ArchibaldCommented:
Try:

With ActiveSheet.OLEObjects.Add(Filename:= _
        "C:\Documents\PDF\Lecture_7.pdf", Link:=False, DisplayAsIcon:= _
        True, IconFileName:= _
        "C:\Windows\Installer\{AC76BA86-1033-F400-7760-000000000004}\_PDFFile.ico", _
        IconIndex:=0, IconLabel:="C:\Documents\PDF\Lecture_7.pdf")
   .Top = Range("D20").Top
   .Left = Range(""D20").Left
End With

Open in new window

0
fmuftiAuthor Commented:
Thanks for the code, however, if I attach the code to a button, but every time I click it adds another icon over the cell. Can I put in some check that if there is already an icon it should not add another.
0
fmuftiAuthor Commented:
Can you suggest how to delete the object as well. Sine the object is not in the cell I cannot use value of the cell. Any suggestions how to delete it as well. ?
0
Cloud Class® Course: Microsoft Windows 7 Basic

This introductory course to Windows 7 environment will teach you about working with the Windows operating system. You will learn about basic functions including start menu; the desktop; managing files, folders, and libraries.

Rory ArchibaldCommented:
I would use a function like the one below and incorporate it into your code as shown:

' REVISED CODE
Dim objOLE as OLEObject
Set objole = GetOLEObject(range("D20"))
if objole is nothing then
  With ActiveSheet.OLEObjects.Add(Filename:= _
        "C:\Documents\PDF\Lecture_7.pdf", Link:=False, DisplayAsIcon:= _
        True, IconFileName:= _
        "C:\Windows\Installer\{AC76BA86-1033-F400-7760-000000000004}\_PDFFile.ico", _
        IconIndex:=0, IconLabel:="C:\Documents\PDF\Lecture_7.pdf")
   .Top = Range("D20").Top
   .Left = Range("D20").Left
  End With
Else
   ' if you wanted to delete it, uncomment this line
   ' objOLE.Delete
End If

' NEW FUNCTION
Function GetOLEObject(rngTarget As Range) As OLEObject
    Dim objOLE As OLEObject
    For Each objOLE In rngTarget.Worksheet.OLEObjects
        If objOLE.TopLeftCell.Address = rngTarget.Address Then
            Set GetOLEObject = objOLE
            Exit For
        End If
    Next objOLE
End Function

Open in new window

0
fmuftiAuthor Commented:
The codes works fine, however there is one last hitch. Sine this embedded object is not in the cell but placed as shape overlapping a cell, I am trying make IconLabel blank so that text in the cell (underneath the shape) is visible. I cannot find any property that make this Oledb icon propoerty blank. Do you have any solution to that.
0
Rory ArchibaldCommented:
You can't, as far as I know, remove the icon completely but you can remove the text and make it transparent:

With ActiveSheet.OLEObjects.Add(Filename:= _
        "C:\Documents\PDF\Lecture_7.pdf", Link:=False, DisplayAsIcon:= _
        True, IconFileName:= _
        "C:\Windows\Installer\{AC76BA86-1033-F400-7760-000000000004}\_PDFFile.ico", _
        IconIndex:=0, IconLabel:="")
   .Top = Range("D20").Top
   .Left = Range(""D20").Left
   .ShapeRange.Fill.Transparency = 1#
End With

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
fmuftiAuthor Commented:
Thanks!
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.