OLE Objects Path File location?

[Sgdva]

Greetings!
As the title states, I have managed to get some files by embedding them as OLE Objects, however, I want to copy them to a real location -I can see they are stored in the temp folder-, however, I haven't found a way to get its file location
IE: I would like to save that file in the hard drive. Any ideas on how I could get the path via VBA?

 

[RickXL]

Hi,

Embedded objects are difficult to process. The embedding part is easy but manipulating them afterwards is not made easy.

I believe that the files are stored inside the workbook. However, they are not stored as pristine files, they have wrappers added so that you cannot use them directly. You need to remove that wrapper. There is a recent thread here where Jaafar Tribak has done some good detective work on the subject. http://www.mrexcel.com/forum/excel-...opens-but-without-showing-media-player-2.html

Certain operations will make a copy of the file and place it in your TEMP folder. For instance, OLEObject.Copy will cause a copy to be made. However, it only seems to work the first time in a session. After that, Excel remembers where it is and does not copy it again.

You could experiment with OLEObject.Duplicate which makes a copy every time you run it. I have tried to get the file name and I can get a copy from the TEMP folder using this code.

Option Compare Text
Sub Test2()
    Dim OLEobj     As OLEObject
    Dim Path       As String
    Dim objFSO     As Object
    Dim objFolder  As Object
    Dim objFile    As File
    
    Path = Environ("Tmp") & "\"
    Set OLEobj = Sheet1.OLEObjects(1)
    OLEobj.Duplicate

    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(Path)
    For Each objFile In objFolder.Files
        If Not objFile.Name Like "*TMP" Then
            If objFile.DateCreated > (Now - TimeValue("00:00:05")) Then
                Debug.Print objFile.DateCreated, objFile.Name
            End If
        End If
    Next
End Sub

Please do not consider it as complete or finished because I have no idea about its reliability or repeatability. It is in the "well it worked once" category.

What it does is duplicate the first OLE Object. This puts a copy in the TEMP folder.
Then a File System Object is used to read the TEMP folder and it lists anything created in the last 5 seconds that is not a TMP file. If you know your files will all end in .jpg then I would try searching on that.

 

[RickXL]

OK, I've had a bit more time to look at this. A couple of small additions to the above code will loop through a worksheet and copy the files to another folder:

Option Compare Text
Sub Test3()
    Dim OLEobj     As OLEObject
    Dim Path       As String
    Dim objFSO     As Object
    Dim objFolder  As Object
    Dim objFile    As File
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Path = Environ("Tmp") & "\"
    Set objFolder = objFSO.GetFolder(Path)
    For Each OLEobj In Sheet1.OLEObjects
        Set OLEobj = OLEobj.Duplicate
        OLEobj.Delete
        For Each objFile In objFolder.Files
            If Not objFile.Name Like "*TMP" Then
                If objFile.DateCreated > (Now - TimeValue("00:00:05")) Then
                    objFile.Move ThisWorkbook.Path & "\Save Files\" & objFile.Name
                End If
            End If
        Next
    Next
End Sub

It is still not a perfect solution so you may need to "tune" it to make it work for you.

How it works:

Set a Path to the Temporary Folder.
Loop round all embedded objects
Duplicate the object. This creates an extra icon on the worksheet.
Delete the extra icon - the copied file remains in the temporary folder.
Loop round the Temporary Folder looking for files that have appeared in the last 5 seconds and do not end in .TMP.
Move that file into a sub-folder of the folder where the workbook is.

If you know your file extensions then I would look for those rather than exclude .TMP files.
The 5 second limit appears to be OK. The process does rely on Excel being the only application to be populating the temporary folder within that period.
Using the "Move" operation will remove the file from the Temporary Folder preventing it being picked up again.

I hope this helps.

Regards,

 

[Sgdva]

Great! It works! However, I noticed that, by some random reason, it creates a duplicate of itself (I had the object already stored and while in the cycle I save it)
I modified it to work for those scenarios just copying one of the archives, hope it helps someone!

...
'try to save in the hard disk
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Path = Environ("Tmp") & "\"
    Set objFolder = objFSO.GetFolder(Path)
'        Set DuplicatedMedia = AddedMedia.Duplicate
'        DuplicatedMedia.Delete
        For Each objFile In objFolder.Files
            If Not objFile.Name Like "*TMP" Then ' 2. If Not objFile.Name Like "*TMP"
            If objFile.DateCreated > (Now - TimeValue("00:00:05")) Then ' 3. If objFile.DateCreated > (Now - TimeValue("00:00:05"))
                If InStr(objFile.Name, "(") Then ' 4. If InStr(objFile.Name, "(")
                objFileName = Trim(Left(objFile.Name, InStr(objFile.Name, "(") - 1)) & Right(objFile.Name, Len(objFile.Name) - InStr(objFile.Name, ")"))
                objFileName2 = Trim(Left(objFile.Name, InStr(objFile.Name, "(") - 1)) & " (2)" & Right(objFile.Name, Len(objFile.Name) - InStr(objFile.Name, ")"))
                Else ' 4. If InStr(objFile.Name, "(")
                objFileName = objFile.Name
                objFileName2 = Trim(Left(objFile.Name, InStrRev(objFile.Name, ".") - 1) & " (2)" & Right(objFile.Name, Len(objFile.Name) - InStrRev(objFile.Name, ".") + 1))
                End If ' 4. If InStr(objFile.Name, "(")
                On Error Resume Next
                Set AlreadyExists = FileSystemLibrary.GetFile(ThisWorkbook.Path & "\Save Files\" & objFileName)
                On Error Resume Next
                Set AlreadyExists2 = FileSystemLibrary.GetFile(ThisWorkbook.Path & "\Save Files\" & objFileName2)
                If (AlreadyExists Is Nothing) And (AlreadyExists2 Is Nothing) Then FileCopy objFile, ThisWorkbook.Path & "\Save Files\" & objFile.Name ': Application.Wait (Now() + TimeValue("00:00:01"))
            End If ' 3. If objFile.DateCreated > (Now - TimeValue("00:00:05"))
            End If ' 2. If Not objFile.Name Like "*TMP"
            objFileName = vbNullString
            objFileName2 = vbNullString
            Set AlreadyExists = Nothing
            Set AlreadyExists2 = Nothing
        Next objFile
    'try to save in the hard disk
...

 

[Sgdva]

I'm sorry! I forgot to add that you have to declare

Dim FileSystemLibrary As New Scripting.FileSystemObject

as well

 

[aboly8000]

Hello
Thank you for your very useful code.
I made some changes to the code to work for me.
I share it to help someone.

Sub OLEObject()
     
    Dim OLEobj     As OLEObject
    Dim Path       As String
    Dim objFSO     As Object
    Dim objFolder  As Object
    Dim objFile    As File
    Dim folder     As folder
    Dim strFile    As String
    
'try to save in the hard disk
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Path = Environ("Tmp") & "\"
    Set objFolder = objFSO.GetFolder(Path)
For Each OLEobj In Worksheets("Discrete Work orders").OLEObjects
    OLEobj.Copy
    Dim oData   As New DataObject 'object to use the clipboard
    oData.SetText Text:=Empty 'Clear
    oData.PutInClipboard 'take in the clipboard to empty it
Next OLEobj
       
       For Each folder In objFolder.SubFolders
       For Each objFile In folder.Files
            If Not objFile.Name Like "*TMP" Then
                If objFile.DateCreated > (Now - TimeValue("00:00:05")) Then
                strFile = ThisWorkbook.Path & "\" & objFile.Name
                If FileExists(strFile) Then
                Exit Sub
                Else
                objFile.Move ThisWorkbook.Path & "\" & objFile.Name
                End If
                Exit Sub
                End If
            End If
        Next objFile
        Next folder
        
       For Each objFile In objFolder.Files
            If Not objFile.Name Like "*TMP" Then
                If objFile.DateCreated > (Now - TimeValue("00:00:05")) Then
                strFile = ThisWorkbook.Path & "\" & objFile.Name
                If FileExists(strFile) Then
                Exit Sub
                Else
                objFile.Move ThisWorkbook.Path & "\" & objFile.Name
                End If
                Exit Sub
                End If
            End If
       Next objFile


End Sub


Function FileExists(FilePath As String) As Boolean
Dim TestStr As String
    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        FileExists = False
    Else
        FileExists = True
    End If
End Function