以下代码正在创建电子邮件，同时搜索文件夹并附加相关文档。
我已将其编码以检查用户是否已发送电子邮件或已将其关闭。我已经把它放在一个输入框当用户关闭电子邮件时显示。我想要发生的事情是当电子邮件关闭时，InputBox是否设置为焦点，并且在输入电子邮件的原因之后输入，然后返回到电子邮件点击“不要保存草稿”。
甚至在电子邮件关闭后，在保存未更改对话框后显示输入框。
Userform代码：
Dim OutApp As Object
Dim itmevt As New CMailItemEvents
Private Sub btnEMSent_Click()
Dim i, j, lastG, lastD As Long
Dim OutMail As Object
Dim sFName As String, colFiles As New Collection
Dim myDir As String, ChDir As String, attName As New Collection, attName2 As String
Dim dte As String
Dim greet As String, cntName As String, SigString As String, Signature As String
lastG = Sheets("File Locations").Cells(Rows.Count, "B").End(xlUp).Row
SigString = "H:\AppData\Roaming\Microsoft\Signatures\"
If Dir(SigString, vbDirectory) <> vbNullString Then
SigString = SigString & Dir$(SigString & "*.htm")
Else:
SigString = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(SigString).OpenAsTextStream(1, -2).readall
If Me.cmbMonth.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Payment Month Required!"
Me.cmbMonth.SetFocus
Exit Sub
ElseIf Me.txtbxYear.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Payment Year Required!"
Me.txtbxYear.SetFocus
Exit Sub
ElseIf Me.cmbSubbie.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Sub-Contractor Required!"
Me.cmbSubbie.SetFocus
Exit Sub
End If
For i = 1 To lastG
lookupVal = Sheets("File Locations").Cells(i, "B") ' value to find
If Dir(lookupVal, vbDirectory) = "" Then
Else
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set itmevt.itm = OutMail
dte = Me.cmbMonth.Value & " " & Me.txtbxYear.Text
myDir = lookupVal 'Set Dir to search
ChDir = (myDir & "\" & Me.cmbSubbie.Value & "\Remittance\") 'Change to that dir
sFName = Dir(ChDir & "*" & dte & "*") 'Set Search spec
While InStr(sFName, dte)
colFiles.Add (ChDir & sFName)
attName.Add (sFName)
sFName = Dir
Wend
End If
Next i
On Error Resume Next
With OutMail
If Me.txtbxSubNAME.Value <> "" Then
cntName = " " & Me.txtbxSubNAME.Value & ","
Else
cntName = ","
End If
If Time < TimeValue("12:00:00") Then
greet = "Good Morning" & cntName
Else
greet = "Good Afternoon" & cntName
End If
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
.Attachments.Add colFiles(i)
attName2 = attName(i) & "<br>" & attName2
Next i
End If
.To = Me.txtbxSubEMAIL.Value
.CC = ""
.BCC = ""
.Subject = Me.cmbMonth.Value & "'s Remittances"
.BodyFormat = olFormatHTML
.HTMLbody = "<HTML><BODY></BODY></HTML>" & .HTMLbody & Signature
.Display True
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
在类模块CMailItemEvents：
中Option Explicit
Public WithEvents itm As Outlook.MailItem
Private Declare PtrSafe Function MessageBox _
Lib "User64" Alias "MessageBoxA" _
(ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) _
As Long
Private Sub itm_Close(Cancel As Boolean)
Dim blnSent As Boolean
Dim lastG As Long
Dim myValue As Variant
lastG = Sheets("Report").Cells(Rows.Count, "A").End(xlUp).Row + 1
On Error Resume Next
blnSent = itm.Sent
If Err.Number = 0 Then
myValue = inputBox("Why was " & usrFrmEMAIL.cmbSubbie & " Remittance E-Mail not sent?", "Remittance Error")
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
AppActivate (myValue.ActiveExplorer.CurrentItem)
Sheets("Report").Range("D" & lastG).Value = myValue
Exit Sub
Else
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
End If
End Sub
答案 0 :(得分：0)
我设法弄明白如何让它发挥作用。
课程模块：
Option Explicit
Private Declare Function GetWindowThreadProcessId Lib _
"user32" (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Private Declare Function AttachThreadInput Lib "user32" _
(ByVal idAttach As Long, ByVal idAttachTo As Long, _
ByVal fAttach As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function SetForegroundWindow Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function IsIconic Lib "user32" _
(ByVal hWnd As Long) As Long
Private Declare Function ShowWindow Lib "user32" _
(ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName _
As Long, ByVal lpWindowName As String) As Long
Const SW_SHOW = 5
Const SW_RESTORE = 9
Public WithEvents itm As Outlook.MailItem
Function ForceForegroundWindow(ByVal hWnd As Long) As Boolean
Dim ThreadID1 As Long
Dim ThreadID2 As Long
Dim nRet As Long
If hWnd = GetForegroundWindow Then
ForceForegroundWindow = True
Else
ThreadID1 = GetWindowThreadProcessId( _
GetForegroundWindow, ByVal 0&)
ThreadID2 = GetWindowThreadProcessId(hWnd, ByVal 0&)
If ThreadID1 <> ThreadID2 Then
AttachThreadInput ThreadID1, ThreadID2, True
nRet = SetForegroundWindow(hWnd)
AttachThreadInput ThreadID1, ThreadID2, False
Else
nRet = SetForegroundWindow(hWnd)
End If
If IsIconic(hWnd) Then
ShowWindow hWnd, SW_RESTORE
Else
ShowWindow hWnd, SW_SHOW
End If
ForceForegroundWindow = CBool(nRet)
End If
End Function
Private Sub itm_Close(Cancel As Boolean)
Dim blnSent As Boolean
Dim lastG As Long, currentrow As Integer
Dim myValue As String
Dim bOK As Boolean
Dim idx As Long
idx = usrFrmEMAIL.cmbSubbie.ListIndex
lastG = Sheets("Report").Cells(Rows.Count, "A").End(xlUp).Row + 1
On Error Resume Next
blnSent = itm.Sent
If Err.Number = 0 Then
itm.Close olDiscard
ForceForegroundWindow FindWindowA(0, Application.Caption)
Do
myValue = inputBox("Why was " & usrFrmEMAIL.cmbSubbie & "'s Remittance E-Mail not sent?", "Remittance Error")
If StrPtr(myValue) = 0 Then
bOK = False
MsgBox "You cannot just press Cancel!" & vbLf & vbLf & "A reason is needed for not sending the email.", vbCritical
ElseIf myValue = "" Then
bOK = False
MsgBox "You didn't enter anything, but pressed OK" & vbLf & vbLf & "A reason is needed for not sending the email.", vbExclamation
ElseIf Len(Application.WorksheetFunction.Substitute(myValue, " ", "")) = 0 Then
bOK = False
MsgBox "You only entered spaces!" & vbLf & vbLf & "A reason is needed for not sending the email.", vbExclamation
Else
bOK = True
Exit Do
End If
Loop Until bOK = True
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
Sheets("Report").Range("D" & lastG).Value = myValue
If idx <> usrFrmEMAIL.cmbSubbie.ListCount - 1 Then
usrFrmEMAIL.cmbSubbie.ListIndex = idx + 1
Else
usrFrmEMAIL.cmbSubbie.ListIndex = 0
End If
Else
For currentrow = 6 To lastG
Sheets("Report").Range("A" & lastG).Value = usrFrmEMAIL.cmbSubbie.Value
Sheets("Report").Range("B" & lastG).Value = usrFrmEMAIL.cmbMonth.Text & " " & usrFrmEMAIL.txtbxYear.Text
Sheets("Report").Range("C" & lastG).Value = Now
Sheets("Report").Range("D" & lastG).Value = "Sent"
Next
If idx <> usrFrmEMAIL.cmbSubbie.ListCount - 1 Then
usrFrmEMAIL.cmbSubbie.ListIndex = idx + 1
Else
usrFrmEMAIL.cmbSubbie.ListIndex = 0
End If
End If
End Sub
UserForm代码：
Dim OutApp As Object
Dim itmevt As New CMailItemEvents
Private Sub btnCreateEmail_Click()
Dim i, j, lastG, lastD As Long
Dim OutMail As Object
Dim sFName As String, colFiles As New Collection
Dim myDir As String, ChDir As String, attName As New Collection, attName2 As String
Dim dte As String
Dim greet As String, cntName As String, SigString As String, Signature As String
lastG = Sheets("File Locations").Cells(Rows.Count, "B").End(xlUp).Row
SigString = "H:\AppData\Roaming\Microsoft\Signatures\"
If Dir(SigString, vbDirectory) <> vbNullString Then
SigString = SigString & Dir$(SigString & "*.htm")
Else:
SigString = ""
End If
Signature = CreateObject("Scripting.FileSystemObject").GetFile(SigString).OpenAsTextStream(1, -2).readall
If Me.cmbMonth.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Required!"
Me.cmbMonth.SetFocus
Exit Sub
ElseIf Me.txtbxYear.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Required!"
Me.txtbxYear.SetFocus
Exit Sub
ElseIf Me.cmbSubbie.Value = "" Then
Me.lblErrorMsg.Visible = True
Me.lblErrorMsg.Caption = "Required!"
Me.cmbSubbie.SetFocus
Exit Sub
End If
For i = 1 To lastG
lookupVal = Sheets("File Locations").Cells(i, "B") ' value to find
If Dir(lookupVal, vbDirectory) = "" Then
Else
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
Set itmevt.itm = OutMail
dte = Me.cmbMonth.Value & " " & Me.txtbxYear.Text
myDir = lookupVal 'Set Dir to search
ChDir = (myDir & "\" & Me.cmbSubbie.Value & "\***\") 'Change to that dir
sFName = Dir(ChDir & "*" & dte & "*") 'Set Search spec
While InStr(sFName, dte)
colFiles.Add (ChDir & sFName)
attName.Add (sFName)
sFName = Dir
Wend
End If
Next i
On Error Resume Next
With OutMail
If Me.txtbxSubNAME.Value <> "" Then
cntName = " " & Me.txtbxSubNAME.Value & ","
Else
cntName = ","
End If
If Time < TimeValue("12:00:00") Then
greet = "Good Morning" & cntName
Else
greet = "Good Afternoon" & cntName
End If
If colFiles.Count > 0 Then
For i = 1 To colFiles.Count
.Attachments.Add colFiles(i)
attName2 = attName(i) & "<br>" & attName2
Next i
End If
.To = Me.txtbxSubEMAIL.Value
.CC = ""
.BCC = ""
.Subject = Me.cmbMonth.Value & "'s "
.BodyFormat = olFormatHTML
.HTMLbody = "<HTML><BODY STYLE='font-family:Calibri;font-size:14.5'>" & greet & "<br><br>" & "Thank for your . Please see the attached remittances." & "<br><br>" & "<b>" & attName2 & "</b>" _
& "<br>" & "Please submit if you are required to do so. In this email, could you please copy in:" & "<br><br>" & _
"" & "<br><br>" & _
"<b>" & "Please note: " & "</b>" & "If you need to supply a matching invoice and we do not receive one, your payment's will be held." & "<br><br>" & "Kind regards," & "</BODY></HTML>" & .HTMLbody & Signature
.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub