如何解决使用用户表单时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 举报,一经查实,本站将立刻删除。