Solved

OLEObject export from excel VB and get file name

Posted on 2009-04-14
9
3,138 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
PeopleSoft Has Never Been Easier

PeopleSoft Adoption Made Smooth & Simple!

On-The-Job Training Is made Intuitive & Easy With WalkMe's On-Screen Guidance Tool.  Claim Your Free WalkMe Account Now

 

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 500 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

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

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

Suggested Solutions

This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Access developers frequently have requirements to interact with Excel (import from or output to) in their applications.  You might be able to accomplish this with the TransferSpreadsheet and OutputTo methods, but in this series of articles I will di…
The viewer will learn how to use a discrete random variable to simulate the return on an investment over a period of years, create a Monte Carlo simulation using the discrete random variable, and create a graph to represent the possible returns over…
This Micro Tutorial demonstrates how to create Excel charts: column, area, line, bar, and scatter charts. Formatting tips are provided as well.

730 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