How to export a worksheet objust to a folder?

Hi jodymichael,

Please show the code for the macro that inserts the objects.

Kind regards,
Stellan

Hello Stellan,
The code below is for the two seperate attachment options, image and file, which loads the objects on a different worksheet. So the next stage of the process is to export those attachments.
Many thanks
Jody

Sub AttachFile()
    Dim fn
    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
        ActiveSheet.OLEObjects.Add FileName:=fn, Link:=False, DisplayAsIcon:=True, IconFileName:=fn, IconIndex:=9, IconLabel:=fn, Left:=50, Top:=5, Width:=50, Height:=40
        Sheets("Workflow-Offering Detail").Select
        Sheets("Workflow-Offering Detail").Unprotect
        Range("OffAttach").Value = fn
        Sheets("Workflow-Offering Detail").Protect
        Range("A8").Select
    End If
TheEnd:
End Sub
 
Sub AttachImage()
    Dim vFile As Variant
    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
        ActiveSheet.OLEObjects.Add FileName:=vFile, Link:=False, DisplayAsIcon:=True, IconIndex:=9, IconFileName:=vFile, IconLabel:=vFile, Left:=250, Top:=5, Width:=100, Height:=30
        Sheets("Workflow-Offering Detail").Select
        Sheets("Workflow-Offering Detail").Unprotect
        Range("OffImage").Value = vFile
        Sheets("Workflow-Offering Detail").Protect
        Range("A8").Select
    End If
TheEnd:
End Sub

Select allOpen in new window

Hi Jody,

To get the embedded word document is quite straightforward. The document is opened in Word and saved, with the filename given from the cell where it was stored but with the path changed to your archive folder. The original filename cannot be retrieved from the embedded object but the progID property of the OLEobject is helpful in identifying what kind of file that was embedded.
However, the embedded image file is wrapped in a object package which does not expose the containing image file to VBA. To manually save the embedded image file you can right-click and select 'Package Object' -> 'Edit package' which will start the Microsoft Object Packager from where you can save the content as an image file. Sadly, the MS Object Packager cannot be controlled like MS Word. My best attempt is to use SendKeys after starting the Object Packager by sending the verb xlOpen to the OLEobject. SendKeys sends keystrokes to the active window as if typed at the keyboard.

Please try this code and tell me if you need more help or explanations. You have to set the reference to the MS Word Object library. In the VBE window select Tools->References..

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 wordDoc As Word.Document
    
    sArchivePath = "C:\ArchiveAttachments\"
 
    Set wkB = ActiveWorkbook
    Set wksLog = wkB.Worksheets("Log File")
    Set wksDetail = wkB.Worksheets("Workflow-Offering Detail")
    
    For Each oOLE In wksLog.OLEObjects
        Debug.Print oOLE.progID
        
        If LCase(Left(oOLE.progID, 4)) = "word" Then
            sFullFileName = wksDetail.Range("OffAttach").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("OffImage").Value
            iPos = InStrRev(sFullFileName, "\", -1, vbTextCompare)
            sFileName = Right(sFullFileName, Len(sFullFileName) - iPos)
        
            oOLE.Verb xlVerbOpen 'Open the MS Object Packager
            SendKeys "%FS", True 'Alt-F-S, Save content
            SendKeys rngFileName.Value, True 'Filename with path
            SendKeys "%S", True 'Alt-S, Save button
            SendKeys "%Fx", True 'Alt-F-x, Exit
        
        End If
    Next oOLE
        
End Sub

Select allOpen in new window

Hello Stellan,
Fabulous!
I did get the debug error at line 13: Dim wordDoc As Word.Document
but by removing the 'As Word.Document' it works Ok
I also get an error on Line 41: SendKeys rngFileName.Value, True
This is the only place that I cant get passed, however the saving of the word Doc works perfectly!
Any idea what i might be doing wrong here? i am using excel 2007 and 2003 for these forms.
Many thanks
Jody

Excelent, I anderstand the risks of using SendKeys, however the solution provides the facility to do what I couldnt without manual intervention. Thank you for the assistnace, this has helped a great deal!

Thank you Jody,
I am glad that I could help.

Kind regards,
Stellan