使用用户表单时Outlook中的VBA公共变量问题

问题描述

Outlook中VBA宏的新增功能。该宏为电子邮件正文创建PDF，保存所有附件，并将其保存到文件夹中。该代码要求用户输入作业号：“ 6-######”，该作业号用于标记要保存的每个文件并可能创建Outlook文件夹。

下面的代码在我的计算机上有99％的时间可以工作。但是，当我尝试将其部署到其他计算机上时，公共变量将返回到模块中的“”（空变量）。这意味着，它永远找不到要保存文件的正确文件夹。我通过从系统中导出模块和表单，并导入到我的同事中来部署它。

这是代码：

Public STYPE As Long Public Jobnumber As String

Public Sub RFQ_SAVER()

    
     
    Dim Selection As Selection
    Dim obj As Object
    Dim Item As MailItem
     
    Dim wrdApp As Word.Application
    Dim wrdDoc As Word.Document
    Set wrdApp = CreateObject("Word.Application")
    Set Selection = Application.ActiveExplorer.Selection

For Each obj In Selection
 
    Set Item = obj
    
    Dim FSO As Object,TmpFolder As Object
    Dim sName As String
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set tmpFIleName = FSO.GetSpecialFolder(2)
    
    sName = Item.Subject
    ReplaceCharsForFileName sName,"-"
    tmpFIleName = tmpFIleName & "\" & sName & ".mht"
    
      ' C:\Users\caustin\AppData\Local\Temp  'On Error GoTo quickexit

If Not FSO.FileExists(tmpFIleName) Then
    Item.SaveAs tmpFIleName,olMHTML
    Else
    ButtonChosen = MsgBox("Can I close all word documents?",vbQuestion + vbYesNo + vbDefaultButton2,"Continue?")
    If ButtonChosen = vbYes Then
    Dim objWord As Object

    Do
        On Error Resume Next
        Set objWord = GetObject(,"Word.Application")
        If Not objWord Is Nothing Then
            objWord.Quit
            Set objWord = Nothing
        End If
    Loop Until objWord Is Nothing
   
    Kill (tmpFIleName)
    Item.SaveAs tmpFIleName,olMHTML
     Else
    GoTo quickexit
    End If End If
     Set wrdDoc = wrdApp.Documents.Open(FileName:=tmpFIleName,Visible:=True)
  
    Dim WshShell As Object
    Dim SpecialPath As String
    Dim strToSaveAs As String
    Set WshShell = CreateObject("WScript.Shell")
    MyDocs = WshShell.SpecialFolders(16) UserForm1.Show Select Case STYPE
    Case -1 '  -1 is what you want to use if nothing is selected
         MsgBox ("You need to select document type,try again")
         Exit Sub
    Case 0
        strTYPE = "RFQ"
    Case 1
        strTYPE = "email_order_"
    Case 2
         strTYPE = "email_correspondence_"
    Case 3
         strTYPE = "notes_"
    Case 4
         strTYPE = "PL"
    Case 5
         strTYPE = "ack"
    Case 6
         strTYPE = "conf"
    End Select ' check for duplicate filenames ' if matched,add serialization 1 to 50 'Jubnumber = InputBox("Job Number:") If Jobnumber = vbNullString Then MsgBox ("You need to enter Job Number,try again") Exit Sub ElseIf Jobnumber = "" Then MsgBox ("You need to enter Job Number,try again") Exit Sub ElseIf Len(Jobnumber) < 7 Then MsgBox ("Please check your Job Number,try again") ElseIf Len(Jobnumber) > 7 Then MsgBox ("Please check your Job Number,try again") Exit Sub End If 'strToSaveAs = "\\Scans\" & Jobnumber & "\" & Jobnumber & " " & "rfq" & ".pdf" strToSaveAs = "\\Scans\" & "6-" & Jobnumber & "\" & "6-" & Jobnumber & " " & strTYPE & ".pdf" For Each Atmt In Item.Attachments
            If LCase(Right(Atmt.FileName,Len(ExtString))) = LCase(ExtString) Then
                FileName = "\\Scans\" & "6-" & Jobnumber & "\" & "6-" & Jobnumber & " " & strTYPE & "attachment-" & I & Atmt.FileName
                If Not FSO.FileExists(FileName) Then
                Atmt.SaveAsFile FileName
                Else
                I = I + 1
                End If
            End If
        Next Atmt For I = 1 To 50 If FSO.FileExists(strToSaveAs) Then    'strToSaveAs = "\\Scans\" & Jobnumber & "\" & Jobnumber & " " & "rfq" & "-" & i & ".pdf"    strToSaveAs = "\\Scans\" & "6-" & Jobnumber & "\" & "6-" & Jobnumber & " " & strTYPE & "-" & I & ".pdf" Else GoTo continue1 End If Next I continue1: wrdApp.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
    strToSaveAs,ExportFormat:=wdExportFormatPDF,_
    OpenAfterExport:=False,OptimizeFor:=wdExportOptimizeForPrint,_
    Range:=wdExportAllDocument,From:=0,To:=0,Item:= _
    wdExportDocumentContent,IncludeDocProps:=True,KeepIRM:=True,_
    CreateBookmarks:=wdExportCreateNoBookmarks,DocStructureTags:=True,_
    BitmapMissingFonts:=True,UseISO19005_1:=False
              Next obj
    wrdDoc.Close
    wrdApp.Quit
    Set wrdDoc = Nothing
    Set wrdApp = Nothing
    Set WshShell = Nothing
    Set obj = Nothing
    Set Selection = Nothing
    Set Item = Nothing '*************** move the file ****************** Dim CurrentFolder As Outlook.MAPIFolder Dim Subfolder As Outlook.MAPIFolder Dim List As New VBA.Collection Dim Folders As Outlook.Folders Dim FolderItem As Variant


'List.Add Array("Job Numbers",olFolderInbox)

Dim objNS As Outlook.NameSpace Dim objDestFolder As Outlook.MAPIFolder Dim objItem As Outlook.MailItem


Set objNS = Application.GetNamespace("MAPI")

Set objParent = Session.GetDefaultFolder(olFolderInbox) Set objDestFolder = objParent.Parent.Folders("Job Folders") 'Set objItem = ActiveExplorer.Selection

'Folders = objDestFolder.Folders On Error GoTo Foldercontinue Set myJobFolder = objDestFolder.Folders.Add("6-" & Jobnumber,olFolderInbox) Foldercontinue: Set objDestFolder = objDestFolder.Folders("6-" & Jobnumber)

For Each obj In ActiveExplorer.Selection
    If TypeName(obj) = "MailItem" Then
      Set msg = obj
      msg.Move objDestFolder
    End If   Next obj

Exit Sub quickexit:   MsgBox ("Program needs to close Word in order to continue,try again after closing Word")  Exit Sub End Sub

以及该表单的代码：

Private Sub CommandButton1_Click()
STYPE = ComboBox1.ListIndex
Jobnumber = TextBox1.Value
Unload Me
End Sub

Private Sub Label3_Click()

End Sub

Private Sub UserForm_Initialize()
With ComboBox1
.AddItem "RFQ"
.AddItem "email_order_"
.AddItem "email_correspondence_"
.AddItem "notes_"
.AddItem "PL"
.AddItem "ack"
.AddItem "conf"
End With
Me.ComboBox1.Text = Me.ComboBox1.List(0)
End Sub
Private Sub CancelButton_Click()
    Unload Me
    End
End Sub

以及表单本身： enter image description here

解决方法

暂无找到可以解决该程序问题的有效方法，小编努力寻找整理中！

如果你已经找到好的解决方法，欢迎将解决方案带上本链接一起发送给小编。

小编邮箱:dio#foxmail.com (将#修改为@）