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
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
Please show the code for the macro that inserts the objects.
Kind regards,
Stellan