Go Premium for a chance to win a PS4. Enter to Win

x
?
Solved

OLEObject export from excel VB and get file name

Posted on 2009-04-14
9
Medium Priority
?
3,464 Views
Last Modified: 2012-05-06
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

0
Comment
Question by:jodymichael
  • 5
  • 4
9 Comments
 
LVL 13

Expert Comment

by:StellanRosengren
ID: 24146155
Hi Jody,

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

Kind regards,

Stellan
0
 

Author Comment

by:jodymichael
ID: 24146989
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
0
 

Author Comment

by:jodymichael
ID: 24147041
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

0
Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

 

Author Comment

by:jodymichael
ID: 24147165
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
0
 
LVL 13

Expert Comment

by:StellanRosengren
ID: 24153119
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
0
 

Author Comment

by:jodymichael
ID: 24155650
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
0
 
LVL 13

Accepted Solution

by:
StellanRosengren earned 2000 total points
ID: 24161387
Hi Jody,
Thank you. You are very kind.
Here is a sample code that shows how you can loop through (as before) all the OLEobjects and match each object's name with a row in the table. In this example I assume the filename is in column B. That name is then used to save the embedded document (or image).
I have assumed that the names of the OLEobjects are "myObjX" where X is the number. Of course you can use any name you want.

I hope you can make use of this. Tell me if you need more assistance.

Kind regards,
Stellan

Sub SaveEmbeddedFiles()
    
    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 sNameOfOLEobj As String
    Dim iNumberInTheName As Integer
    Dim rngCell As Range
    Dim wordDoc As Word.Document
    
    sArchivePath = "C:\Temp\" '"C:\ArchiveAttachments\"
 
    Set wkB = ActiveWorkbook
    Set wksLog = wkB.Worksheets("WorksheetF")
    Set wksDetail = wkB.Worksheets("Attachments")
    
    For Each oOLE In wksDetail.OLEObjects
        'Get the object name
        sNameOfOLEobj = oOLE.Name
        'And the trailing number
        iNumberInTheName = CInt(Right(sNameOfOLEobj, Len(sNameOfOLEobj) - Len("myObj")))
        'Find the cell with that number
        Set rngCell = wksLog.Columns(miOBJNUM_COLUMN).Find(what:=iNumberInTheName, lookat:=xlWhole)
        If rngCell Is Nothing Then
            MsgBox "Found an object that cannot be matched with any table item!"
            'Do something?
            Stop
        End If
        '
        'Now let us read the filename from the table
        sFileName = rngCell.Offset(0, -2).Value 'the column 2 positions to the left
        
        If LCase(Left(oOLE.progID, 4)) = "word" Then
            
            oOLE.Activate
            Set wordDoc = oOLE.Object
            wordDoc.SaveAs sArchivePath & sFileName
            wordDoc.Close
        
        ElseIf LCase(oOLE.progID) = "package" Then
        
            oOLE.Verb xlVerbOpen 'Open the MS Object Packager
            SendKeys "%FS", True 'Alt-F-S, Save content
            SendKeys sArchivePath & sFileName, True 'Filename with path
            SendKeys "%S", True 'Alt-S, Save button
            SendKeys "%Fx", True 'Alt-F-x, Exit
        
        End If
    Next oOLE
        
End Sub

Open in new window

0
 

Author Closing Comment

by:jodymichael
ID: 31571396
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.
0
 
LVL 13

Expert Comment

by:StellanRosengren
ID: 24169152
Thanks for the kind words.
And the points ;-)

Stellan

0

Featured Post

Technology Partners: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Excel can be a tricky bit of software to get your head around. Whilst you’ll be able to eventually get to grips with the basic understanding of how to get by, there are a few Excel tips that not everybody will even know about let alone know how to d…
Do you use a spreadsheet like Microsoft's Excel?  Have you ever wanted to link out to a non excel file on your computer or network drive?  This is the way I found to do it!
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …
Although Jacob Bernoulli (1654-1705) has been credited as the creator of "Binomial Distribution Table", Gottfried Leibniz (1646-1716) did his dissertation on the subject in 1666; Leibniz you may recall is the co-inventor of "Calculus" and beat Isaac…

926 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question