- 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
来源: http://www.phpxs.com/code/1008795/