|
楼主 |
发表于 2010-12-29 14:25
|
显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
应该是网路发现的问题...,我在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 |
|