asked on

OLEObject export from excel VB and get file name

I originally posted the question "How to export a worksheet object to a folder?" which Stellan provided a great solution, and I have since had a slight change in requirement. I have attempted to adapt the code accordingly but failed.

This time, I have the attachment collected on a sheet called 'Attachments', and on a sheet called WorksheetF I have two columns of data relating to the attachments. Column B rows 2 and down collate a list of the attachment names e.g. "Document 1.doc", whilst column C rows 2 and down collate the full name eg. Full file path of the machine it originated from plus the file name such as "C:\Documents and Settings\maria.morris\My Documents\My Pictures\deskmove 3.jpg".

As I cannot necessarily come up with a valid way of matching the object to the data in each row, I could do with setting it up to save any images to one folder, and any other attachments such as word documents, excel spreadsheets and PowerPoint presentations to another folder. My Last attempt produced the code below which is an adaptation of Stellan's original code, but it seems to loop through and over write each object and assign the wrong name occasionally.

Any help will be great. I just need to get the attachments stored in the correct folder locations, with the correct file name - I will probably also add a text string of a few characters to the start of the file name but im sure i can handle that.

I would also ideally like to - if possible, call this macro from Outlook :-(

Function SaveEmbeddedFiles(fname)
    Dim wkB As Workbook
    Dim wksLog As Worksheet
    Dim wksDetail As Worksheet
    Dim sArchivePath As String
    Dim sFullFileName As String
    Dim sFileName As String
    Dim iPos As Integer
    Dim oOLE As OLEObject
    Dim wordDoc
 
    sArchivePath = "R:\Enabling_Applications\GSM7_RF\Request Catalogue\WFD Form Returns\File Attachments\"
    pArchivePath = "R:\Enabling_Applications\GSM7_RF\Request Catalogue\WFD Form Returns\Image Attachments\"
    Set wkB = Workbooks(fname)
    Set wksLog = wkB.Worksheets("Attachments")
    Set wksDetail = wkB.Worksheets("WorksheetF")
    iLast = Worksheets("WorksheetF").Range("C2").End(xlDown).Row
    For iCnt = 2 To iLast
    Range("C" & iCnt).Value = Replace(Range("C" & iCnt).Value, "File Attachement - C", "C")
    Range("C" & iCnt).Value = Replace(Range("C" & iCnt).Value, "Image Attachement - C", "C")
    For Each oOLE In wksLog.OLEObjects
        Debug.Print oOLE.progID
        If Not LCase(oOLE.progID) = "package" Then
            sFullFileName = wksDetail.Range("C" & iCnt).Value
            iPos = InStrRev(sFullFileName, "\", -1, vbTextCompare)
            sFileName = Right(sFullFileName, Len(sFullFileName) - iPos)
            oOLE.Activate
            Set wordDoc = oOLE.Object
                wordDoc.SaveAs sArchivePath & sFileName
                wordDoc.Close
        ElseIf LCase(oOLE.progID) = "package" Then
            sFullFileName = wksDetail.Range("C" & iCnt).Value
            iPos = InStrRev(sFullFileName, "\", -1, vbTextCompare)
            sFileName = Right(sFullFileName, Len(sFullFileName) - iPos)
            oOLE.Verb xlVerbOpen
            SendKeys "%FS", True
            SendKeys pArchivePath & sFileName, True
            SendKeys "%S", True
            SendKeys "%Fx", True
        End If
    Next oOLE
    Next
    
End Function

Open in new window

StellanRosengren

Hi Jody,

I do not fully understand what you want to achieve. Would it be possible to upload a sample workbook?

Kind regards,

Stellan

jodymichael

ASKER

Hi Stellan,
I have attached a sample file which is returned to me, note that worksheet F lists the attachments that have been added, but there can be multiple attachments. And the other worksheet stores them.
The difficulty I have is relating which attachment on worksheet F relates to which attachment (OLEObject) on the other worksheet.
Initially, each user gets sent a form which allows them to attach the files to a spreadsheet and includes a number of fields and data which I use, the Attachments are add via a macro, and then the name is populated in the sheet.
Maybe the approach I go about getting the attachment in may need to change in order to allow me to match them to the text on its return to me in the attached form - at this stage; I am unclear on the best approach to move forward
Thanks
Jody

Sample.xls

jodymichael

ASKER

Here is a sample of how the attachment is origioanlly applied to the worksheet - again, a little help i recieved from Experts-Exchange.
Once the attachments have gone in and all the data collated, the log file is generated and exported back to me in a spreadsheet via email, that spreadsheet is the attached file above, with a few unnecessary bits taken out for you.
Thank you

Sub AttachFile()
    Dim fn, iName
    
    iName = ThisWorkbook.Name
    Sheets("Admin").Range("Z3000").Value = iName
    iNum = ExtractNumber(Sheets("Admin").Range("Z3000"), False, False)
    Application.ScreenUpdating = False
    fn = Application.GetOpenFilename("All Files,*.*", Title:=" Find file to insert")
    If FileLen(fn) > 2000000 Then
        MsgBox "File exceeds size limit of 2MB, please choose a smaller file!"
        GoTo TheEnd
    End If
    If fn = False Then
        MsgBox "No file has been selected, please try again!"
    Else
        Sheets("Log File").Select
            sFullFileName = fn
            iPos = InStrRev(sFullFileName, "\", -1, vbTextCompare)
            sFileName = iNum & "-" & Right(sFullFileName, Len(sFullFileName) - iPos)
        ActiveSheet.OLEObjects.Add FileName:=fn, Link:=False, DisplayAsIcon:=True, _
            IconFileName:=sFileName, IconIndex:=9, IconLabel:=sFileName, Left:=50, _
            Top:=5, Width:=50, Height:=40
        Sheets("Offering ADD").Select
        Sheets("Offering ADD").Unprotect
        Range("OffAttach").Value = sFileName
        Sheets("Offering ADD").Protect
        Range("A8").Select
    End If
TheEnd:
    Application.ScreenUpdating = True
End Sub
 
Sub AttachImage()
    Dim vFile As Variant
    Dim iName
    
    iName = ThisWorkbook.Name
    Sheets("Admin").Range("Z3000").Value = iName
    iNum = ExtractNumber(Sheets("Admin").Range("Z3000"), False, False)
    Application.ScreenUpdating = False
    vFile = Application.GetOpenFilename("All Files,*.*", Title:=" Find file to insert")
    If FileLen(vFile) > 2000000 Then
        MsgBox "File exceeds size limit of 2MB, please choose a smaller file!"
        GoTo TheEnd
    End If
    If LCase(vFile) = "false" Then
        MsgBox "No file has been selected, please try again!"
    Else
        Sheets("Log File").Select
            sFullFileName = vFile
            iPos = InStrRev(sFullFileName, "\", -1, vbTextCompare)
            sFileName = iNum & "-" & Right(sFullFileName, Len(sFullFileName) - iPos)
        ActiveSheet.OLEObjects.Add FileName:=vFile, Link:=False, DisplayAsIcon:=True, _
            IconIndex:=9, IconFileName:=sFileName, IconLabel:=sFileName, Left:=250, _
            Top:=5, Width:=100, Height:=30
        Sheets("Offering ADD").Select
        Sheets("Offering ADD").Unprotect
        Range("OffImage").Value = sFileName
        Sheets("Offering ADD").Protect
        Range("A8").Select
    End If
TheEnd:
    Application.ScreenUpdating = True
End Sub

Open in new window

jodymichael

ASKER

I may be off on a tangent here, but would it help if i identify the OLE Object name when attaching - e.g. 'Object 1' or 'Object 2' and so on, then prefix that to the name on the text string. then when trying to pull them back out again at the ned, i take the prefixing to identify the OLE Object and, for example, if 'Object 1' was call 'SampleFile', then i can extract 'Object 1' and resave it to the folder location with the name 'SampleFile'?
Just an idea from a beginner, but i dont know if it would help. Thanks Stellan
Jody

StellanRosengren

Hi Jody,
Yes, that is a possibility. To change the name of an OLEobject you can use the .Name property. When you add a new OLEobject you are using the .Add method of the OLEobjects collection. That method returns a reference to the new object. To capture the return value just use parentheses. I have modified your AttachFile sub to give the new OLEobject a name like "myObj" followed by a unique number which is saved in a new column. I have introduced a variable for the next free row where all new data should be written. I cannot figure out how your code is taking care of entering the data in the right place but maybe you can fix this yourself.

Please have a look at this. I will soon be back with some suggestion for the modifications of the macro that saves the embedded (attached) files.
But first a good night's sleep.

Kind regards,
Stellan

Const miOBJNUM_COLUMN As Integer = 4
'
 
Sub AttachFile()
    Dim fn, iName
    Dim lFreeNum As Long
    Dim wksF As Worksheet
    Dim lNextRow As Long
    
    'reference to the worksheet with 'Offering Attachments' data
    Set wksF = ThisWorkbook.Worksheets("WorksheetF")
    'The next row to fill in for the new file, using column 1 last non-empty cell
    lNextRow = wksF.Cells(wksF.Rows.Count, 1).End(xlUp).Row + 1
    
    iName = ThisWorkbook.Name
    Sheets("Admin").Range("Z3000").Value = iName
    iNum = ExtractNumber(Sheets("Admin").Range("Z3000"), False, False)
    Application.ScreenUpdating = False
    fn = Application.GetOpenFilename("All Files,*.*", Title:=" Find file to insert")
    If FileLen(fn) > 2000000 Then
        MsgBox "File exceeds size limit of 2MB, please choose a smaller file!"
        GoTo TheEnd
    End If
    If fn = False Then
        MsgBox "No file has been selected, please try again!"
    Else
        'Get a number for the OLEobject that has not been used, Maximum + 1
        With wksF
            lFreeNum = _
                Application.WorksheetFunction.Max( _
                .Range(.Cells(2, miOBJNUM_COLUMN), .Cells(.Rows.Count, miOBJNUM_COLUMN).End(xlUp)) _
                ) + 1
            'enter the new number in the OLEobjectNumber column
            .Cells(lNextRow, miOBJNUM_COLUMN).Value = lFreeNum
        End With
        
        
        Sheets("Log File").Select
            sFullFileName = fn
            iPos = InStrRev(sFullFileName, "\", -1, vbTextCompare)
            sFileName = iNum & "-" & Right(sFullFileName, Len(sFullFileName) - iPos)
        'Add the file to the Oleobjects collection and assign the name to the OLEobject
        ActiveSheet.OLEObjects.Add(Filename:=fn, Link:=False, DisplayAsIcon:=True, _
            IconFileName:=sFileName, IconIndex:=9, IconLabel:=sFileName, Left:=50, _
            Top:=5, Width:=50, Height:=40).Name = "myObj" & lFreeNum
            
        Sheets("Offering ADD").Select
        Sheets("Offering ADD").Unprotect
        Range("OffAttach").Value = sFileName
        Sheets("Offering ADD").Protect
        Range("A8").Select
    End If
TheEnd:
    Application.ScreenUpdating = True
End Sub

Open in new window

NewColumn.JPG

jodymichael

ASKER

Hi Stellan,
I hope you got a good night sleep :-)
Fantastic! that works like a dream - I like the naming convention a lot Stellan, thank you. I will have a go at this now but imagine that you will have a great aproach to identifying the OLEObject to match to name so I will look forward to that. You a star thanks.
Jody

ASKER CERTIFIED SOLUTION

StellanRosengren

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

jodymichael

ASKER

Fantastic Stellan, Once again that was superb! This allows me to identify each attached Object and store it by actual name without overwriting. Perfect! Thank you.

StellanRosengren

Thanks for the kind words.
And the points ;-)

Stellan