Outlook宏创建的新Excel工作簿未保存在目录中

Question

我有一个Outlook宏，可以将用户Tasklist导出到存储在网络驱动器上的Excel电子表格中。

我正在尝试检查目录中是否存在工作簿（If statement taken form here）。

如果没有，请使用一个名为＆＃34; Sheet 1＆＃34;的工作表创建一个新工作簿，如果已经有一个具有正确用户名的工作表，则打开它（{{3} }）：

感谢add statement taken from here，我已经解决了我遇到的命名错误，但现在新创建的worbook没有保存在目录文件夹中。没有抛出错误，宏的末尾的msg框正在正确显示，所以我不知道为什么文件没有显示在文件资源管理器中。

这是我的整个计划：

Sub Task_Grab_V2()
  Dim sKillExcel As String
  Dim strReport As String
  Dim olnameSpace As Outlook.NameSpace
  Dim taskFolder As Outlook.MAPIFolder
  Dim tasks As Outlook.Items
  Dim tsk As Outlook.TaskItem
  Dim objExcel As New Excel.Application
  Dim exWb As Excel.Workbook
  Dim sht As Excel.Worksheet
  Dim NAME_s As String
  Dim Range As Excel.Range
  Dim str As String, strClean As String
  Dim z As Integer
  Dim strMyName As String
  Dim x As Integer
  Dim y As Integer
  Dim stat_string As String
Dim r As Range, s As String, iloc As Long
Dim s1 As String, cell As Range, col As Long
Dim sChar As String
Dim strUserName As String

 objExcel.DisplayAlerts = False
 'Use the Application Object to get the Username
 NAME_s = Environ("USERNAME")

 Dim FilePath As String
    Dim TestStr As String

    FilePath = "some\directory" & NAME_s & ".xlsx"

    TestStr = ""
    On Error Resume Next
    TestStr = Dir(FilePath)
    On Error GoTo 0
    If TestStr = "" Then
        Set exWb = objExcel.Workbooks.Add(1)
        exWb.Sheets("Sheet1").Name = "Sheet1Old"
        exWb.Sheets.Add().Name = "Sheet1"
        exWb.Sheets("Sheet1Old").Delete
    Else
        Set exWb = objExcel.Workbooks.Open("some\directory" & NAME_s & ".xlsx")
          exWb.Sheets.Add().Name = "Sheet1"
          exWb.Sheets("Sheet1_old").Delete
    End If




  Set olnameSpace = Application.GetNamespace("MAPI")
  Set taskFolder = olnameSpace.GetDefaultFolder(olFolderTasks)

  Set tasks = taskFolder.Items

  strReport = ""

  'Create Header
  exWb.Sheets("Sheet1").Cells(1, 1) = "Subject"
  exWb.Sheets("Sheet1").Cells(1, 2) = "Category"
  exWb.Sheets("Sheet1").Cells(1, 3) = "Due Date"
  exWb.Sheets("Sheet1").Cells(1, 4) = "Percent Complete"
  exWb.Sheets("Sheet1").Cells(1, 5) = "Status"
  exWb.Sheets("Sheet1").Cells(1, 6) = "Notes"


  y = 2

  For x = 1 To tasks.Count

       Set tsk = tasks.Item(x)

       'strReport = strReport + tsk.Subject + "; "

       'Fill in Data
       If Not tsk.Complete Then

            If tsk.Status = olTaskDeferred Then
                stat_string = "Deferred"
            End If
            If tsk.Status = olTaskInProgress Then
                stat_string = "In Progress"
            End If
            If tsk.Status = olTaskNotStarted Then
                stat_string = "Not Started"
            End If
            If tsk.Status = olTaskWaiting Then
                stat_string = "Waiting on Someone Else"
            End If




        exWb.Sheets("Sheet1").Cells(y, 1) = tsk.Subject
        exWb.Sheets("Sheet1").Cells(y, 2) = tsk.Categories
        exWb.Sheets("Sheet1").Cells(y, 3) = tsk.DueDate
        exWb.Sheets("Sheet1").Cells(y, 4) = tsk.PercentComplete
        exWb.Sheets("Sheet1").Cells(y, 5) = stat_string
        exWb.Sheets("Sheet1").Cells(y, 6) = tsk.Body

   'the following section searches the body of the task for a specified character and deletes everything after it
        col = 6   ' assumes column 6, change to your column
sChar = "#" ' assume character to look for is hash, change to yours
With objExcel.ActiveSheet
  Set r = .Range(.Cells(2, col), .Cells(.Rows.Count, col).End(xlUp))
End With
For Each cell In r
 s = cell.Text
 If Len(Trim(s)) > 0 Then
   iloc = InStr(1, s, sChar, vbTextCompare)
   If iloc > 1 Then
     s1 = Left(s, iloc - 1)
     cell.Value = s1
   Else
     If iloc <> 0 Then
      cell.ClearContents
     End If
   End If
 End If
Next cell
        y = y + 1
        stat_string = ""
       End If

  Next x


'Autofit all column widths
On Error Resume Next
For Each sht In objExcel.ActiveWorkbook.Worksheets
    sht.Columns("A").EntireColumn.AutoFit
    sht.Columns("B").EntireColumn.AutoFit
    sht.Columns("C").EntireColumn.AutoFit
    sht.Columns("D").EntireColumn.AutoFit
    sht.Columns("E").EntireColumn.AutoFit
    sht.Columns("F").EntireColumn.AutoFit
Next sht

exWb.Save

exWb.Close

Set exWb = Nothing
'this kills the excel program from the task manager so the code will not double up on opening the application
sKillExcel = "TASKKILL /F /IM Excel.exe"
Shell sKillExcel, vbHide

MsgBox ("Tasks have been sucessfully exported.")


End Sub

有人能看出为什么上面的代码不会保存创建的文件吗？

Answer 1

您在此处保存工作簿：

didFinishLaunchingWithOptions

如果在此处创建了工作簿：

makeKeyAndVisible()

然后你没有指定工作簿的文件名，所以如果它是exWb.Save 那么你很可能在你的我的文件中有一个新的If TestStr = "" Then Set exWb = objExcel.Workbooks.Add(1) 文件文件文件夹。

如果已经有Book1个文件，则Book1.xlsx实例会弹出警告：

我需要在这里做一个假设，但我的理论是 ¹ Book1.xlsx是一个为＆＃34;运行创建的Excel应用程序实例在后台＆＃34;，它不可见。但即使应用程序不可见，通常您也会获得该警报框。除非您明确禁用它：

objExcel

禁用警报后，objExcel将覆盖现有文件。

因此，您没有收到任何错误，但该文件不在您期望的文件夹中，也不在您保存的文件名中，但 已创建。< / p>

如果您想以指定的路径/文件名保存文件，请使用objExcel.DisplayAlerts = False 方法代替Save - but that's no news。

_{¹ its just declared as Dim objExcel As New Excel.Application. – scb998 2 mins ago}

Answer 2

您需要在 exWb.SaveAs Filename:=FilePath

旁边添加 exWb.Sheets("Sheet1Old").Delete

实施例

    Set exWb = objExcel.Workbooks.Add(1)
    exWb.Sheets("Sheet1").Name = "Sheet1Old"
    exWb.Sheets.Add().Name = "Sheet1"
    exWb.Sheets("Sheet1Old").Delete
    exWb.SaveAs FileName:=FilePath