如何给外发邮件自动编号实现邮件控制

sunhill

办公室和工厂相隔两地，经常会有办公室发出的邮件工厂漏收的情况，现在解决的办法是办公室每发出一封电邮就在标题栏手动编一个流水号，但因为有很多人，又要按顺序取号，很麻烦。可否通过宏实现邮件自动编号呢？（很多人按统一流水号编号，不能重复）
（ps:关于收条功能，如果收件人设置为不回复收条，也是无法达到邮件控制的目的。）

dsd999

自动编号加到什么地方？

subject还是哪里？

sunhill

加到SUBJECT栏，谢谢

dsd999

拷到ThisOutlookSession

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)

If TypeName(Item) <> "MailItem" Then Exit Sub

Dim myFile As String
Dim No As Integer

myFile = Dir("*.d99")
If myFile = "" Then
No = 1
Else
pos = InStr(1, myFile, ".")
No = Left(myFile, pos - 1)
No = No + 1
End If

Kill "*.d99"

CreateFile No

Dim newSubject As String

newSubject = "(" & No & ")" & Item.Subject

Item.Subject = newSubject


End Sub


Function CreateFile(No As Integer)
Dim sFilename As String
sFilename = No & ".d99"
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(sFilename, True)
a.Close
End Function

sunhill

十分感谢斑竹。
1.初次运行需手动添加一个.d99文件或将kill语句放到if语句内，否则报错。
2.在建立和检索文件语句里添加路径（共享目录），这样可以实现多人按统一流水号编号（测试ok)。

另外并不是所有的邮件都是发给工厂即不是所有邮件都需要编号，所以设想将以上代码放到一个模块里，然后在新邮件item里添加一个类似“发送”的按钮，需要编号的邮件则点此按钮调用以上模块发送邮件，不需要编号的邮件则按OL发送按钮。
看了斑竹的VBA开发教程里的添加按钮的方法，但怎么将按钮添加到新邮件窗口呢？还请指教，多谢嗮。

dsd999

原帖由 sunhill 于 2010-12-21 14:54 发表
十分感谢斑竹。
1.初次运行需手动添加一个.d99文件或将kill语句放到if语句内，否则报错。
2.在建立和检索文件语句里添加路径（共享目录），这样可以实现多人按统一流水号编号（测试ok)。

另外并不是所有的邮件都 ...

看看第四讲，里面有代码

sunhill

有点晕，按钮添加了，可是click事件调用模块出错-"子过程或函数未定义"，需要申明吗，怎么申明或调用这个ItemSend, 谢

dsd999

把代码贴出来。

sunhill

Private WithEvents vsoCommbandButton As CommandBarButton
Private WithEvents vsoCommbandReplyAllWithAttach As CommandBarButton
Private WithEvents colInspectors As Outlook.Inspectors
Private WithEvents vsoCommbandReplyAllWithAttachInspector As CommandBarButton

Private Sub Application_Startup()

Call addTotalButton
Set colInspectors = Application.Inspectors

End Sub

'增加工具栏
Sub addTotalButton()

'On Error Resume Next
Dim vsoCommandBar As CommandBar

'得到要添加的工具栏
Set vsoCommandBar = Outlook.ActiveExplorer.CommandBars("Point")
'如果工具栏为空，则增加
If (vsoCommandBar Is Nothing) Then

Set vsoCommandBar = Outlook.ActiveExplorer.CommandBars.Add("Point", msoBarTop)

'在工具栏上增加一个按钮
Set vsoCommbandReplyAllWithAttach = vsoCommandBar.Controls.Add(1)
vsoCommbandReplyAllWithAttach.Caption = "Send w/3&AS Coding"
vsoCommbandReplyAllWithAttach.FaceId = 68
vsoCommbandReplyAllWithAttach.Style = msoButtonIconAndCaption

'显示增加的工具栏
vsoCommandBar.Visible = True

Else

Set vsoCommbandReplyAllWithAttach = vsoCommandBar.Controls(1)

End If

End Sub

'得到当前选择的邮件
Function GetCurrentItem() As Object
    Dim objApp As Outlook.Application
        
    Set objApp = Application
    'On Error Resume Next
    Select Case TypeName(objApp.ActiveWindow)
        Case "Explorer"
            Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
        Case "Inspector"
            Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
    End Select
   
    Set objApp = Nothing
End Function

Private Sub vsoCommbandReplyAllWithAttach_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
'On Error Resume Next

Dim rpl As Outlook.MailItem
    Dim itm As Object
   
    Set itm = GetCurrentItem()
    If Not itm Is Nothing Then
        Set rpl = itm.ReplyAll
        CopyAttachments itm, rpl
        rpl.Display
    End If
   
    Set rpl = Nothing
    Set itm = Nothing

End Sub

Sub colInspectors_NewInspector(ByVal Inspector As Inspector)
     On Error Resume Next
     Dim objCommandBar As CommandBar
     Set objCommandBar = Inspector.CommandBars("Point")
     If (objCommandBar Is Nothing) Then
     Set objCommandBar = Inspector.CommandBars.Add("Point", msoBarTop, , True)
     Set vsoCommbandReplyAllWithAttachInspector = objCommandBar.Controls.Add(msoControlButton, , , , True)
     vsoCommbandReplyAllWithAttachInspector.Caption = "Send w/3&AS Coding"
     vsoCommbandReplyAllWithAttachInspector.FaceId = 68
     vsoCommbandReplyAllWithAttachInspector.Style = msoButtonIconAndCaption
     objCommandBar.Visible = True
     Else
     Set vsoCommbandReplyAllWithAttachInspector = objCommandBar.Controls(1)
     End If
End Sub

Private Sub vsoCommbandReplyAllWithAttachInspector_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)

call 模块1.Application_ItemSend(ByVal Item As Object, Cancel As Boolean)  '<<这里报错-“子过程或函数未定义”
CreateFile

End Sub

dsd999

把Application_ItemSend里的代码拷到 vsoCommbandReplyAllWithAttachInspector_Click里

前面加上
Dim Item as MailItem
set Item = GetCurrentItem()