保存Excel工作簿中所有的嵌入文件

以下代码由PHP站长网 52php.cn收集自互联网

现在PHP站长网小编把它分享给大家，仅供参考

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_ApplicationsGSM7_RFRequest CatalogueWFD Form ReturnsFile Attachments"
    pArchivePath = "R:Enabling_ApplicationsGSM7_RFRequest CatalogueWFD Form ReturnsImage 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,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

以上内容由PHP站长网【52php.cn】收集整理供大家参考研究

如果以上内容对您有帮助，欢迎收藏、点赞、推荐、分享。

（编辑：李大同）

【声明】本站内容均来自网络，其相关言论仅代表作者个人观点，不代表本站立场。若无意侵犯到您的权利，请及时与联系站长删除相关内容!