Outlook VBA 代码仅适用于一台计算机
Posted
技术标签:
【中文标题】Outlook VBA 代码仅适用于一台计算机【英文标题】：Outlook VBA code only works on one computer 【发布时间】：2014-01-06 16:38:52 【问题描述】：所以，这可能是迄今为止我在使用 VBA 时遇到的最奇怪的问题之一。
我研究过一个宏，它执行以下操作：
-
在当前电子邮件中，它会检查单个 XLS 文件。
如果找到，将附件保存在临时文件夹中，以便通读文件。
将特定区域复制/粘贴到电子邮件正文中。
使用电子邮件中的某些字段自动填充主题行
所以，我可以在我开发它的计算机上完成所有这些工作。工作正常，没有问题。我的老板试图将其添加到他的计算机中，但它不起作用。它给出了这个错误
Run Time error -382271456(e9370020)
Cannot save the attachment
下面是代码，抱歉看了，我知道很多。
Sub Parse_Excel()
Dim NewMail As MailItem, oInspector As Inspector
Set oInspector = Application.ActiveInspector
Dim eAttachment As Object, i As Integer, lRow As Integer, lCol As Integer, rng As Range, subject As String
Dim codes As String, c As Variant, dArea As Range, dType As Range, dSev As Range, result As String, damage As String
Dim lCommentRowRng As Range
'~~> Get the current open item
Set NewMail = oInspector.CurrentItem
Set eAttachment = Excel.Application
With NewMail.Attachments
For i = 1 To .Count
If InStr(.Item(i).FileName, ".xls") > 0 Then
sFileName = Environ$("temp") & "/" & .Item(i).FileName
' Creates a temporary file in the temp folders for Outlook
Debug.Print sFileName
'Used to test something
.Item(i).SaveAsFile sFileName
' Save file there
eAttachment.Workbooks.Open sFileName
'Open the saved file - this is necessary as you can't simply open it from outlook
With eAttachment.Workbooks(.Item(i).FileName).Sheets(1)
Set lCommentRowRng = .Cells.Find("Comments")
Set rng = lCommentRowRng.Offset(0, 1)
' Sometimes the comments will be on the bottom, so we need to have this to figure out how far down exactly the comment box goes
If Not lCommentRowRng.Row = (rng.Row + rng.MergeArea.Rows.Count) Then
lCommentRow = rng.Row + rng.MergeArea.Rows.Count
lCol = rng.Column + rng.MergeArea.Columns.Count - 1
Else
lCommentRow = lCommentRowRng.Row
End If
lPriorRow = .Cells.Find("Prior Inspections").Row
lRow = eAttachment.Max(lCommentRow, lPriorRow)
'The date of the report
Set rng = .Cells.Find("Date")
ddate = .Cells(rng.Row, rng.Column + rng.MergeArea.Columns.Count).Value
'The VIN we are using
result = ""
With .Cells
Set c = .Find("VIN", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
result = result & " " & Right(c.Offset(0, 1).Value, 8)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
vin = result
'Make/Model
result = ""
With .Cells
Set c = .Find("Model", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
If uInStr(result, c.Offset(0, 1).Value) = -1 Then
result = result & " " & c.Offset(0, 1).Value
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
model = result
Set rng = .Cells.Find("Origin")
' Not all reports have Origin/Railcar Number fields, thus the If statements
If Not rng Is Nothing Then
origin = .Cells(rng.Row, rng.Column + rng.MergeArea.Columns.Count).Value
End If
Set rng = .Cells.Find("Railcar Number")
If Not rng Is Nothing Then
Railcar = .Cells(rng.Row, rng.Column + rng.MergeArea.Columns.Count).Value
End If
'Not all Reports have "Bay" Information
Set rng = .Cells.Find("Bay Location")
If Not rng Is Nothing Then
bay = rng.Offset(0, 1).Value
End If
result = ""
'The result variable, that will hold the string for the top
With .Cells
Set c = .Find("Damage Code", LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
Do
Set dArea = c.Offset(0, 1)
Set dType = dArea.Offset(0, 1)
Set dSev = dType.Offset(0, 1)
' It got really tricky trying to just use the c.offset thing since the columns are all merged - This works better.
damage = Left(dArea.Value, 2)
damage = damage & "." & Left(dType.Value, 2)
damage = damage & "." & dSev.Value & " "
If uInStr(result, damage) = -1 Then
' If the damage is not found within the string already, include it, otherwise just continue through the loop
result = result & " " & damage
End If
Set c = .FindNext(c)
' Get the next value
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
Set rng = .Range("A1", .Cells(lRow, lCol))
With NewMail
subject = .subject
subject = Replace(subject, "00/00/00", ddate)
subject = Replace(subject, "VIN# ", "VIN# " & vin)
subject = Replace(subject, "Make Model", model)
subject = Replace(subject, "ORIGIN", UCase(origin) & " ORIGIN")
subject = Replace(subject, "TTGXxxxx", Railcar)
subject = Replace(subject, "CODE: ", "CODE: " & result)
subject = Replace(subject, "CODES: ", "CODES: " & result)
subject = Replace(subject, "BAY#", "BAY# " & bay)
subject = Replace(subject, " ", " ")
.subject = subject
.BodyFormat = olFormathtml
.HTMLBody = RangetoHTML(rng)
.Display
End With
End With
eAttachment.Workbooks(.Item(i).FileName).Close
Exit For
End If
Next
End With
End Sub
Function RangetoHTML(rng As Range)
' By Ron de Bruin.
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As workBook
Dim excelApp As Excel.Application
Set excelApp = New Excel.Application
TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a new workbook to past the data in
rng.Copy
Set TempWB = Workbooks.Add(1)
With TempWB.Sheets(1)
.Cells(1).PasteSpecial Paste:=8 ' Paste over column widths from the file
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).PasteSpecial xlPasteFormats
.Cells(1).Select
excelApp.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
On Error GoTo 0
End With
'Publish the sheet to a htm file
With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
FileName:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=TempWB.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the htm file into RangetoHTML
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Function uInStr(haystack As String, needle As String) As Integer
Dim nStr As Integer
If haystack = "" Then
' Kept getting an error because I was trying to use the Left function an a string with no length
uInStr = -1
Exit Function
End If
nStr = InStr(haystack, needle)
If haystack = needle Then
uInStr = 0
Exit Function
End If
If nStr > 0 Then
uInStr = nStr
Exit Function
Else
If Not Left(haystack, Len(needle)) = needle Then
uInStr = -1
Exit Function
Else
uInStr = 0
Exit Function
End If
End If
End Function
编辑：为了让它工作，我只需要更改保存文件的目录。由于某种原因，我老板的计算机无法访问环境路径（这本身就很奇怪）。所以现在代码如下：
sFileName = "C:/temp/" & .Item(i).FileName
... Other Code here
Kill "C:/temp/*.xls"
感谢大家的帮助。
【问题讨论】：
不确定你为什么使用/而不是`. Are you sure your boss has access to sFileName`路径？
这是一个临时文件夹，所以我可以想象？我会检查，但我无法直接访问该位置，因为它是一个临时文件夹。
为了进一步混淆，我的老板说，如果他有 2 个我们使用 open 的电子邮件模板实例，并且他将相同的文件附加到这两个实例，它将适用于第二个，但不是首先。
尝试使用类似 c:\temp\ 而不是 Environ$("temp")
我到办公室时会试试看。那是我之前所做的，但我在 RangetoHTML 函数上得到了一些帮助，并且更喜欢简单的“c:/temp/”
【参考方案1】：
我已经编辑了这个，所以我们很清楚，最终发生的事情是我老板的计算机由于某种奇怪的原因无法访问环境变量。现在代码如下：
sFileName = "C:/temp/" & .Item(i).FileName
... Other Code here
Kill "C:/temp/*.xls"
【讨论】：
以上是关于Outlook VBA 代码仅适用于一台计算机的主要内容，如果未能解决你的问题，请参考以下文章