Question

我想创建一个vba脚本，该脚本将在Outlook中创建一封邮件以查找地址（来自excel）。搜索应基于Outlook中的选定邮件（特定字符串-ID）。我知道如何在vba脚本中创建电子邮件，但是我不知道如何从Outlook vba在excel中打开和搜索数据。下面的一些代码。

Sub SMSKI()
    Dim objOL As Outlook.Application
    Dim objItem As Object
    Dim objFwd As Outlook.MailItem
    Dim strAddr As String
    Dim xlApp As Object 
    Dim sourceWB As Workbook 
    Dim sourceWS As Worksheet 
    On Error Resume Next
    Set myItem = Application.CreateItem(olMailItem)

     Dim rng1 As Range
     Dim strSearch As String



    Set xlApp = CreateObject("Excel.Application") 
    Set objOL = Application
    Set objItem = objOL.ActiveExplorer.Selection(1)


    With xlApp 
       .Visible = True 
       .EnableEvents = False 
     End With 

     strFile = "C:\Users\User\Desktop\SMS.xlsx"  'Put your file path.

    Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True) 
    Set sourceWH = sourceWB.Worksheets("SalesForm") 
    sourceWB.Activate 


    If Not objItem Is Nothing Then
        strAddr = objItem.Body
        If strAddr <> "" Then
            ' Set objFwd = objItem.CreateItem(olMailItem)
            ' objFwd.To = strAddr


            vText = Split(strAddr, Chr(13))
            strAddr = Right(Left(vText(0), 9), 8)
            strAddr = Left(strAddr, Len(strAddr) - 8)
            vText = Split(strAddr, " ")
            vText = Split(strAddr, Chr(58))
            strSearch = Right(Left(vText(0), 9), 8)
            myItem.Subject = Right(Left(vText(0), 9), 8)
            Set rng1 = Range("C:C").Find(strSearch, , sourceWB.xlValues, sourceWB.xlWhole)
            myItem.SentOnBehalfOfName = "mail@bla.com"
            myItem.To = ?
            myItem.Cc = ""
            'myItem.Subject = FindWord(strAddr, 1)
            ' objFwd.Sent = False
            myItem.Display
            ' objFwd.Body = ""




            myItem.HTMLBody = "reboot"

        Else
            MsgBox "Could not extract address from message."
        End If
    End If
    Set objOL = Nothing
    Set objItem = Nothing
    Set objFwd = Nothing
End Sub

Answer 1

当我忘记了我曾经知道的一点法语和俄语很久以来，我就不喜欢批评某人的英语。我认为应该“找到”；动词“查找”是许多不规则动词。我不知道“宿舍”是什么意思。

您的代码对使用资源管理器选择的电子邮件的文本正文进行解码。这意味着用户必须先选择一封电子邮件，然后再运行该电子邮件。该电子邮件包含您希望在工作簿中找到的字符串。在不了解使用这种方法的原因的情况下，我无法提供任何建议，但这对我来说似乎很奇怪。

您没有说为什么要搜索“ SalesForm”工作表，也没有说发现搜索值时将执行的操作。我已经从包含搜索值的行的D列中返回了该值。您可以将“ D”替换为其他列的字母或数字。如果您的要求更为复杂，则必须提供您所寻求的解释。

我提供了一个函数“ GetValueFromExcel”和一个例程来展示如何使用它。您可以复制我的函数并从您的代码中调用它，也可以研究我的代码如何工作并构建自己的版本。

您有：

Dim xlApp As Object 
Set xlApp = CreateObject("Excel.Application")

我有：

Dim xlApp As New Excel.Application

使用“ New”关键字和“ Excel.Application”来标识所需的对象意味着我不需要CreateObject语句。我已经读到您的方法比我的方法稍微有效，但是您经常会看到这种不同的方法。

您有：

Dim objOL As Outlook.Application
Dim objItem As Object
Set objItem = objOL.ActiveExplorer.Selection(1)

您位于Outlook中，因此不需要objOL。这与：

Dim objItem As Object
Set objItem = ActiveExplorer.Selection(1)

按您的用法使用，On Error Resume Next的意思是“不要告诉我任何错误，因为我喜欢神秘的失败。除非您知道自己需要它并且知道如何正确使用它，否则请不要使用该语句。

您有：

strFile = "C:\Users\User\Desktop\SMS.xlsx"  'Put your file path.
Set sourceWB = Workbooks.Open(strFile, , False, , , , , , , True)

我有：

With xlApp
  Set WbkSrc = .Workbooks.Open(FileName:=Environ("UserProfile") & "\Desktop\SMS.xlsx")
End With

Environ("UserProfile")返回“ C：\ Users \ xxxx”，其中“ xxxx”是当前用户。如果您与同事共享此宏，则该宏将调整为新用户，而无需进行任何更改。

我已经在Workbooks的调用中包含了路径和文件名。打开以显示它是可能的。

您已经为工作簿指定了参数。按其位置打开。当显而易见的是什么参数时，我将执行此操作，但是我不喜欢倒数逗号来计算False和True的含义。 FileName:=绝对清楚此参数是什么。您似乎不想修改此工作簿，因此我看不到ReadOnly:=False的值。我认为Editable:=True不相关。

sourceWB.Activate是不必要的。

我的代码如下。将其复制到Outlook安装中的模块，并尝试一下，然后再决定如何将其添加到例程中。为了测试我的代码，我在桌面上创建了一个名为“ SMS.xlsx”的工作簿，在C列中放置了搜索值（例如“ Aaaaa”），在D列中放置了返回值。

宏“ GetValueFromExcel”在引用的工作表的C列中搜索指定的搜索值。如果找到搜索值，则从D列返回值；如果找不到搜索值，则返回空字符串。

宏“ TestGetValueFromExcel”演示了如何使用“ GetValueFromExcel”。您将需要替换SearchValues = VBA.Array("Aaaaa", "Bbbbb", "Fffff", "Hhhhh")。值“ Aaaaa”，“ Bbbbb”和“ Fffff”出现在我的列C中。值“ Fffff”没有出现在我的列C中。将我的值替换为列C中的值。

Option Explicit
Sub TestGetValueFromExcel()

  Dim ReturnedValue As String
  Dim SearchValue As Variant
  Dim SearchValues As Variant
  Dim WbkSrc As Workbook
  Dim WshtSrc As Worksheet
  Dim xlApp As New Excel.Application

  SearchValues = VBA.Array("Aaaaa", "Bbbbb", "Fffff", "Hhhhh")

  With xlApp
    .Visible = True   ' Slows execution but helpful during debugging
    .EnableEvents = False
    Set WbkSrc = .Workbooks.Open(FileName:=Environ("UserProfile") & "\Desktop\SMS.xlsx")
  End With
  With WbkSrc
    Set WshtSrc = .Worksheets("SalesForm")
  End With

  For Each SearchValue In SearchValues
    ReturnedValue = GetValueFromExcel(WshtSrc, CStr(SearchValue))
    If ReturnedValue = "" Then
      Debug.Print """" & SearchValue & """ not found"
    Else
      Debug.Print """" & SearchValue & """ returned """ & ReturnedValue & """"
    End If
  Next

  WbkSrc.Close SaveChanges:=False
  Set WbkSrc = Nothing
  With xlApp
    .EnableEvents = False
    .Quit
  End With
  Set xlApp = Nothing

End Sub

更新：GetValueFromExcel加上DsplInHex，PadL和PadR的诊断版本

Function GetValueFromExcel(ByRef Wsht As Worksheet, ByVal SearchValue As String) As String

  Dim Rng As Range
  Dim RowCrnt As Long
  Dim RowLast As Long

  With Wsht

    Set Rng = .Columns("B").Find(What:=SearchValue, After:=.Range("B1"), LookIn:=xlValues, _
                                 LookAt:=xlWhole, SearchOrder:=xlByRows, _
                                 SearchDirection:=xlNext, MatchCase:=False, _
                                 SearchFormat:=False)
    If Rng Is Nothing Then
      ' SearchValue not found
      Debug.Print "SearchValue not found"
      RowLast = .Cells(.Rows.Count, "B").End(xlUp).Row
      For RowCrnt = 2 To RowLast
        Debug.Print Wsht.Name & ".Cells(" & RowCrnt & ",B):"
        Call DsplInHex(.Cells(RowCrnt, "B").Value)
      Next
      Debug.Print "SearchValue:"
      Call DsplInHex(SearchValue)
      GetValueFromExcel = ""
    Else
      ' Return value in column D of row containing SearchValue
      GetValueFromExcel = .Cells(Rng.Row, "C")
    End If

  End With

End Function
Public Sub DsplInHex(Stg As String)

  ' Display Stg in text and hex-digit format.

  ' 19Apr16  Latest date on which it might have been coded.
  ' Pre-     / Hex-digit format only as single row with space between
  ' 17Aug17  \ each character and no padding of short hex values.
  ' 17Aug17  Amended to display text value of characters as well as hex values
  '          and for fixed width display with position within string upto 999.

  Dim ChrGt255 As Boolean
  Dim ChrLng As Long
  Dim ChrStr As String
  Dim LineHex As String
  Dim LineTxt As String
  Dim PadLen As Long
  Dim Pos As Long

  ' Check for (1) all characters at most two hex-digits or (2) at least
  ' one character being more than two hex-digits
  ChrGt255 = False
  For Pos = 1 To Len(Stg)
    If AscW(Mid(Stg, Pos, 1)) > 255 Then
      ChrGt255 = True
    End If
  Next

  If ChrGt255 Then
    ' Need upto four hex-digits per character
    PadLen = 4
  Else
    ' Need at most two hex-digits per character
    PadLen = 2
  End If

  LineHex = "   |"
  LineTxt = "---|"
  For Pos = 0 To 9
    LineHex = LineHex & " " & PadL(Chr$(Asc("0") + Pos), PadLen)
  Next
  LineTxt = PadR(LineTxt, Len(LineHex), "-")

  For Pos = 0 To Len(Stg) - 1
    If Pos Mod 10 = 0 Then
      Debug.Print LineHex    ' Output heading or previous line
      Debug.Print LineTxt
      ' Initialise next line
      LineHex = PadL(Format(Pos, "###"), 3, "0") & "|" ' Position of first character on line
      LineTxt = "   |"
    End If
    ChrStr = Mid(Stg, Pos + 1, 1)
    ChrLng = AscW(ChrStr)
    If ChrLng < 0 Then
      ' Character is &H8000& or above and the top bit is negative
      ChrLng = ChrLng + 65536
    End If

    If ChrLng < 32 Or (ChrLng >= 127 And ChrLng < 160) Then
      ' Control character (non-display)
      ChrStr = "nd"
    End If
    LineHex = LineHex & " " & PadL(Hex(ChrLng), PadLen)
    LineTxt = LineTxt & " " & PadL(ChrStr, PadLen)
  Next
  Debug.Print LineHex    ' Output final line
  Debug.Print LineTxt

End Sub
Public Function PadL(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with leading PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Sep15 Coded
  ' 20Dec15 Added code so overlength strings are not truncated
  ' 10Jun16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadL = Str
  Else
    PadL = Right$(String(PadLen, PadChr) & Str, PadLen)
  End If

End Function
Public Function PadR(ByVal Str As String, ByVal PadLen As Long, _
                     Optional ByVal PadChr As String = " ") As String

  ' Pad Str with trailing PadChr to give a total length of PadLen
  ' If the length of Str exceeds PadLen, Str will not be truncated

  '   Nov15 Coded
  ' 15Sep16 Added PadChr so could pad with characters other than space

  If Len(Str) >= PadLen Then
    ' Do not truncate over length strings
    PadR = Str
  Else
    PadR = Left$(Str & String(PadLen, PadChr), PadLen)
  End If

End Function

在Excel电子表格中从Outlook搜索数据，然后复制找到的单元格（在此处找到的单元格旁边的宿舍单元格）

1 个答案: