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

sunhill

谢谢，基本功能已可以实现，但是如果多人同时发送会出现重复取号问题，如何避免呢？
myFile = Dir(lj & "*.d99")
If myFile = "" Then
No = 10000
Else
pos = InStr(1, myFile, ".")
No = Left(myFile, pos - 1)
No = No + 1
End If

Kill lj & "*.d99"

CreateFile No

如果不kill文件似可避免重复，但怎么让取号排队及在众多文件中寻到最大号又是个问题....

dsd999

每个人建立一种文件不行吗？
比如你建立 d99’
别人建立 d88’

在subject上再加个内容 ，比如(d99_1)

sunhill

为了便于控制，要按一个序号取下去

dsd999

系统起来后，能在资源管理器看到V盘吗？

dsd999

在最开始创建个文件，abc.tmp
在过程末尾删除这个文件。

别人发邮件的时候，先检测这个文件是否存在，存在的话，就给个提示，不存在的话就发送。

sunhill

好方法，回头尝试下。

最近又发现一个问题，每天早上发第一封邮件时会出现找不到“.D88“文件的情况，可能是网络盘路径的问题。如何在OL打开的时候初始化这个路径呢？谢谢

dsd999

把访问网络盘路径的代码贴上来

sunhill

Dim lj
lj = "V:\Customer Service Team\TOOL\"  'Lan drive
....
myFile = Dir(lj & "*.d99")

dsd999

我这没问题

按理网络路径在系统启动的时候已经初始化了

sunhill

应该是网路发现的问题...,我在startup里加了Dir路径的代码，明天再看效果...
上面建立临时文件防止重号的方法很好用。
再次感谢dsd999斑竹的帮助，以下是完整代码作为此贴的完结

Private WithEvents vsoCommbandButton As CommandBarButton
Private WithEvents vsoCommandEmailCtrlNo As CommandBarButton
Private WithEvents colInspectors As Outlook.Inspectors
Private WithEvents vsoCommandEmailCtrlNoInspector As CommandBarButton

Private Sub Application_Startup()

Call addTotalButton
Set colInspectors = Application.Inspectors
Dir ("V:\Customer Service Team\TOOL\*.*")

End Sub

Sub addTotalButton()

On Error Resume Next
Dim vsoCommandBar As CommandBar

Set vsoCommandBar = Outlook.ActiveExplorer.CommandBars("Pointers")

If (vsoCommandBar Is Nothing) Then

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

Set vsoCommandEmailCtrlNo = vsoCommandBar.Controls.Add(1)
vsoCommandEmailCtrlNo.Caption = "Send w/STK Co&de"
vsoCommandEmailCtrlNo.FaceId = 2174
vsoCommandEmailCtrlNo.Style = msoButtonIconAndCaption

vsoCommandBar.Visible = True

Else

Set vsoCommandEmailCtrlNo = 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

Sub colInspectors_NewInspector(ByVal Inspector As Inspector)
     On Error Resume Next
     Dim objCommandBar As CommandBar
     Set objCommandBar = Inspector.CommandBars("Pointers")
     If (objCommandBar Is Nothing) Then
     Set objCommandBar = Inspector.CommandBars.Add("Pointers", msoBarTop, , True)
     Set vsoCommandEmailCtrlNoInspector = objCommandBar.Controls.Add(msoControlButton, , , , True)
     vsoCommandEmailCtrlNoInspector.Caption = "Send w/STK Co&de"
     vsoCommandEmailCtrlNoInspector.FaceId = 2174
     vsoCommandEmailCtrlNoInspector.Style = msoButtonIconAndCaption
     objCommandBar.Visible = True
     Else
     Set vsoCommandEmailCtrlNoInspector = objCommandBar.Controls(1)
     End If
End Sub

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

On Error Resume Next

Dim Item As MailItem
Set Item = GetCurrentItem()

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

Dim myFile, mFile, Tmp As String
Dim No As Integer
Dim lj
lj = "V:\Customer Service Team\TOOL\"
Tmp = "Wait"

mFile = Dir(lj & "Wait.tmp")
If mFile <> "" Then
MsgBox "其他同事取甘号，请再试！", vbOKOnly, "同时取号冲突提示"
Exit Sub
Else
CreateTmpFile Tmp
End If

Set fso = CreateObject("Scripting.FileSystemObject")

If MsgBox("发厂按 是, 发港司按 否", vbYesNo, "选择邮件编号") = vbYes Then

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

fso.movefile lj & myFile, lj & "STK\" & myFile

CreateFile No
Kill lj & "Wait.tmp"

Dim newSubject As String

newSubject = "(STK-" & No & ") / " & Item.Subject

Item.Subject = newSubject
'Item.Send

Else

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

fso.movefile lj & myFile, lj & "HK\" & myFile

CreateFile No
Kill lj & "Wait.tmp"

newSubject = "(STK-" & No & ") / " & Item.Subject
Item.Subject = newSubject
'Item.Send

End If
End Sub
   
Function CreateFile(No As Integer)
Dim sFilename As String
Dim lj

lj = "V:\Customer Service Team\TOOL\"

If Left(No, 1) = 1 Then
sFilename = lj & No & ".stk"
Else
sFilename = lj & No & ".hk"
End If

Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(sFilename, True)
a.Close
End Function


Function CreateTmpFile(Tmp As String)
Dim sFilename As String
Dim lj

lj = "V:\Customer Service Team\TOOL\"
sFilename = lj & Tmp & ".tmp"
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(sFilename, True)
a.Close
End Function