☰

vba Outlook以csv格式儲存附件

tag-icon • tag-icon microsoft-excel microsoft-outlook vba csv
vba Outlook以csv格式儲存附件

我正在嘗試以 CSV 格式儲存電子表格附件。

當找到電子表格附件時，我可以觸發該過程，但我很難將其與帶有兩個參數的轉換腳本結合。

儲存附件

Public Sub saveAttachToDiskcvs(itm As Outlook.MailItem) 

 ' --> Settings. change to suit
Const MASK = "Olus" ' Value to be found
Const SHEET = "sheet2" ' Sheet name or its index where to find
 ' <--

 ' Excel constants
Const xlValues = -4163, xlWhole = 1, xlPart = 2 

 ' Variables
Dim objExcel As Object, IsNew As Boolean, x As Object 
Dim objAtt As Outlook.Attachment 
Dim saveFolder As String, sFileName As String, sPathName As String 
saveFolder = "C:\form" 

If Not TypeName(itm) = "MailItem" Then Exit Sub 
If Dir(saveFolder, vbDirectory) = "" Then MkDir saveFolder 

 ' Get/Create Excel object
On Error Resume Next 
Set objExcel = GetObject(, "Excel.Application") 
If Err Then 
    Err.Clear 
    IsNew = True 
    Set objExcel = CreateObject("Excel.Application") 
End If 
objExcel.FindFormat.Clear 

 ' Main
For Each objAtt In itm.Attachments 
    sFileName = LCase(objAtt.FileName) 
    If sFileName Like "*.xls" Or sFileName Like "*.xls?" Then 
        sPathName = saveFolder & "\" & sFileName 
        objAtt.SaveAsFile sPathName 
        With objExcel.workbooks.Open(sPathName, ReadOnly:=True) 
            Set x = .sheets(SHEET).UsedRange.Find(MASK, LookIn:=xlValues, LookAt:=xlPart) 
            If x Is Nothing Then Kill sPathName Else Set x = Nothing 
            .Close False 
        End With 
    End If 
Next 

If IsNew Then objExcel.Quit 

End Sub

CSV 格式

if WScript.Arguments.Count < 2 Then
WScript.Echo "Error! Please specify the source path and the     
destination. Usage: XlsToCsv SourcePath.xls Destination.csv"
Wscript.Quit
End If
Dim oExcel
Set oExcel = CreateObject("Excel.Application")
Dim oBook
Set oBook = oExcel.Workbooks.Open(Wscript.Arguments.Item(0))
oBook.SaveAs WScript.Arguments.Item(1), 6
oBook.Close False
oExcel.Quit
WScript.Echo "Done"

這個想法是If InStr(objAtt.DisplayName, ".xls")如果.xls找到然後

轉變.xls文件輸入.csv和

將檔案保存在資料夾中objAtt.SaveAsFile saveFolder & "" & objAtt.DisplayName

我嘗試了很多次但從未成功，轉換腳本採用兩個參數用法：XlsToCsv SourcePath.xls Destination.csv”

答案1

如果您只想將其另存為CSV 格式然後使用 FileFormat:=xlCSV

例子

For Each objAtt In itm.Attachments
    sFileName = LCase(objAtt.FileName)
    If sFileName Like "*.xls" Or sFileName Like "*.xls?" Then
        sPathName = saveFolder & "\" & sFileName
        objAtt.SaveAsFile sPathName

        CVSName = Split(objAtt.FileName, ".")(0)

        Debug.Print CVSName

        CVSName = saveFolder & "\" & CVSName

        Debug.Print CVSName

        With objExcel.Workbooks.Open(sPathName)
            .SaveAs FileName:=CVSName, _
                    FileFormat:=xlCSV, _
                    CreateBackup:=False
            .Close SaveChanges:=True
        End With

        Kill sPathName
        objExcel.Quit
    End If
Next

答案2

啊！當人們發布程式碼片段但不提供全部清理乾淨的內容時，我是多麼討厭它......:)

不管怎樣，多虧了你們的共同努力，我才能夠在不到一天的時間內完成我的任務，所以你可以上網了。免費代碼。

添加：

  1. 我清理了它，甚至添加了一些邏輯來刪除 Excel 工作表中的前十行，因為我們的資料提取帶有標題，所以現在它是一個乾淨的 CSV 檔案。
  2. 我新增了使用電腦上的「本機」設定的參數，因此您可以在「區域設定」下的「控制面板」中將「清單分隔符號」設定為您想要的任何內容。無論我的系統設定如何，它都會保存逗號分隔，因此現在應該尊重我的系統設定並使用 PIPE。
  3. 最後，我正在使用 Office 2016，我必須確保 EXCEL 16 LIBRARY 已添加到引用中。

Outlook 中的 VBA 參考

簡直完美！

Public Sub Convert_CSV(itm As Outlook.MailItem)

' Variables
Dim objExcel As Object, IsNew As Boolean
Dim objAtt As Outlook.Attachment
Dim saveFolder As String, sFileName As String, sPathName As String

' CONFGURE FOR YOUR DEPLOYMENT
saveFolder = "C:\inetpub\wwwroot\xls"

If Not TypeName(itm) = "MailItem" Then Exit Sub
If Dir(saveFolder, vbDirectory) = "" Then MkDir saveFolder

' Get/Create Excel object
On Error Resume Next
Set objExcel = GetObject(, "Excel.Application")
If Err Then
    Err.Clear
    IsNew = True
    Set objExcel = CreateObject("Excel.Application")
End If
objExcel.FindFormat.Clear

' Main
For Each objAtt In itm.Attachments
  sFileName = LCase(objAtt.FileName)
  If sFileName Like "*.xls" Or sFileName Like "*.xls?" Then
    sPathName = saveFolder & "\" & sFileName
    objAtt.SaveAsFile sPathName
    CVSName = Split(objAtt.FileName, ".")(0)
    CVSName = saveFolder & "\" & CVSName
    With objExcel.Workbooks.Open(sPathName)
      ' Delete first ten rows.
      For i = 1 To 10
        Rows(1).EntireRow.Delete
      Next

      .SaveAs FileName:=CVSName, _
        FileFormat:=xlCSV, _
        Local:=True, _
        CreateBackup:=False
      .Close SaveChanges:=True
    End With

    Kill sPathName
    objExcel.Quit
  End If
Next

If IsNew Then objExcel.Quit


Set objExcel = Nothing
Set objAtt = Nothing


End Sub

相關內容