Solved

OLEObject export from excel VB and get file name

Posted on 2009-04-14
9
2,901 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
 

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
How to run any project with ease

Manage projects of all sizes how you want. Great for personal to-do lists, project milestones, team priorities and launch plans.
- Combine task lists, docs, spreadsheets, and chat in one
- View and edit from mobile/offline
- Cut down on emails

 
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

Find Ransomware Secrets With All-Source Analysis

Ransomware has become a major concern for organizations; its prevalence has grown due to past successes achieved by threat actors. While each ransomware variant is different, we’ve seen some common tactics and trends used among the authors of the malware.

Join & Write a Comment

Suggested Solutions

Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

757 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

Need Help in Real-Time?

Connect with top rated Experts

17 Experts available now in Live!

Get 1:1 Help Now