☰

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 表中删除前十行，因为我们的数据提取带有 HEADERS，所以现在它是一个干净的 CSV 文件。
  2. 我添加了参数以使用机器上的本地设置，因此您可以在控制面板中的区域设置下将列表分隔符设置为您想要的任何内容。无论我的系统设置如何，它都会一直保存逗号分隔符，所以现在这应该尊重我的系统设置并使用管道。
  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

相关内容