Question

我正在尝试创建一个宏，该宏在接收电子邮件时将其复制，并根据域名将其保存在网络驱动器上的特定Windows文件夹中。

我拥有的域列表很大，并且会因没有编码经验的用户而有所变化，因此我希望开发一个文本，CSV或excel文件，供他人更新以列出我公司与其的关系（客户，供应商，分包商等...）及其名称（两者均控制文件路径），域名（@ example.com）。

我想我可以弄清楚大部分操作（嵌套if和for语句的巧妙组合），但是我不知道如何将文件读入数组，而我的google-fu失败了我。

我认为这真的没有帮助，但是这里是我从网上无耻复制的代码，并打算在此代码上使用。

Option Explicit
Private WithEvents InboxItems As Outlook.Items

Sub Application_Startup()
    Dim xNameSpace As Outlook.NameSpace
    Set xNameSpace = Outlook.Application.Session
    Set InboxItems = xNameSpace.GetDefaultFolder(olFolderInbox).Items
End Sub

Private Sub InboxItems_ItemAdd(ByVal objItem As Object)
    Dim FSO
    Dim xMailItem As Outlook.MailItem
    Dim xFilePath As String
    Dim xRegEx
    Dim xFileName As String
    Dim SenderAddress As String
    On Error Resume Next

    ' Define SenderAddress as sender's email address or domain
    xFilePath = PathCreator(SenderAddress)

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FolderExists(xFilePath) = False Then
        FSO.CreateFolder (xFilePath)

    End If

    Set xRegEx = CreateObject("vbscript.regexp")
    xRegEx.Global = True
    xRegEx.IgnoreCase = False
    xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"

    If objItem.Class = olMail Then
        Set xMailItem = objItem
        xFileName = xRegEx.Replace(xMailItem.Subject, "")
        xMailItem.SaveAs xFilePath & "\" & xFileName & ".html", olHTML

    End If
    Exit Sub

End Sub

Function PathCreator(SenderAddress)

' [needs to read the file and create the path based on the values]

End Function

Answer 1

您可以使用ADODB连接到源文件，并将其读取到二维数组中。从工具-> 参考... 添加对 Microsoft ActiveX数据对象的引用。例如，如果要使用Excel文件：

Dim excelPath As String
excelPath = "C:\path\to\excel\file.xlsx" ' Replace with the path to the Excel file

Dim connectionString As String
connectionString = _
    "Provider=Microsoft.ACE.OLEDB.12.0;" & _
    "Data Source=""" & excelPath & """;" & _
    "Extended Properties=""Excel 12.0;HDR=Yes"""
'This assumes the Excel file contains column headers -- HDR=Yes

Dim sql As String
sql = "SELECT Relationship, LastName, FirstName, DomainName FROM [Sheet1$]"
'Assumes the relevant worksheet is named Sheet1
'Also assumes the first row of the sheet has the following labels: Relationship, LastName, FirstName, Domain (in no particular order)

Dim rs As New ADODB.Recordset
rs.Open sql, connectionString

Dim arr As Variant
arr = rs.GetRows 'Puts the data from the recordset into an array
rs.Close 
Set rs = Nothing

Dim row As Variant, column As Variant
For row = 0 To UBound(arr, 2)
    For column = 0 To UBound(arr, 1)
        Debug.Print arr(column, row)
    Next
Next

使用文本文件或CSV只需更改连接字符串和SQL。但是我认为使用Excel文件会迫使用户将数据保留在列中，而在CSV中，用户必须手动插入字段分隔符和行分隔符。对于其他任何文本格式都一样—用户必须记住该格式的规则并正确应用它们。

但是我怀疑数组是否是您要使用的最佳数据结构；在这种情况下，您可以直接使用记录集。为了确保文件未保持打开状态，可以使用断开连接的记录集。（如果您打算找到合适的域名并使用它来获取其他详细信息，那么我建议您将记录集中的数据加载到Scripting.Dictionary中。）

还请注意，除非您希望代码在运行时发生更改，否则可能只需要从文件中加载一次数据。

我会写这样的东西

Dim rs As ADODB.Recordset

Function PathCreator(SenderAddress) As String
    If rs Is Nothing Then
        Dim excelPath As String
        excelPath = "C:\path\to\excel\file.xlsx" ' Replace with the path to the Excel file

        Dim connectionString As String
        connectionString = _
            "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=""" & excelPath & """;" & _
            "Extended Properties=""Excel 12.0;HDR=Yes"""

        Dim sql As String
        sql = "SELECT Relationship, LastName, FirstName, DomainName FROM [Sheet1$]"

        Set rs As New ADODB.Recordset
        rs.CursorLocation = adUseClient
        rs.CursorType = adOpenStatic
        rs.Open sql, connectionString, adOpenStatic, adLockBatchOptimistic

        'Disconnect the recordset
        rs.ActiveConnection = Nothing

        'Now the data will still be available as long as the code is running
        'But the connection to the Excel file will be closed
    End If

    'build the path here, using the recordset fields
    PathCreator = rs!Relationship & "_" & rs!LastName & "_" & rs!FirstName & "_" & rs!Domain
End Function

NB。同样，您可以添加对 Microsoft脚本运行时的引用；那么您可以编写使用FileSystemObject的代码，如下所示：

Dim FSO As New Scripting.FileSystemObject
If Not FSO.FolderExists(xFilePath) Then
    FSO.CreateFolder xFilePath

End If

以及对 Microsoft VBScript正则表达式5.5 库的引用：

Set xRegEx As New VBScript_RegExp_55.RegExp
xRegEx.Global = True
xRegEx.IgnoreCase = False
xRegEx.Pattern = "\||\/|\<|\>|""|:|\*|\\|\?"

If objItem.Class = olMail Then
    Set xMailItem = objItem
    xFileName = xRegEx.Replace(xMailItem.Subject, "")
    xMailItem.SaveAs xFilePath & "\" & xFileName & ".html", olHTML

End If

将CSV / Excel文件读入数组

1 个答案: