2,503
社区成员




If wscript.arguments.count = 0 Then
Dim sh
Set sh = createobject("shell.application")
sh.shellexecute wscript.fullname,"""" & wscript.scriptfullname & """ -admin",,"runas"
wscript.quit
End If
Sub test()
Dim outlook
Set outlook = CreateObject("outlook.application")
Dim ns
Set ns = outlook.getnamespace("MAPI")
Dim objfolder
Set objfolder = ns.Folders("个人文件夹").Folders("收件箱").Folders("AA").Folders("BB")
Dim objfolder2
Set objfolder2 = objfolder.Folders("CC")
Dim reg
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.MultiLine = True
reg.Pattern = "^SKU:(.*)(?:\r?\n)+数量:(.*)$"
Dim r
r = 1
Range("A:B").Clear
Dim i
For i = objfolder.items.Count To 1 Step -1
Dim item
Set item = objfolder.items(i)
If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.Execute(item.body)
Dim objmatch
For Each objmatch In colmatches
Cells(r, 1) = objmatch.submatches(0)
Cells(r, 2) = objmatch.submatches(1)
r = r + 1
Next
item.Move objfolder2
End If
Next
MsgBox "Done!"
End Sub
Sub test()
Dim outlook
Set outlook = CreateObject("outlook.application")
Dim ns
Set ns = outlook.getnamespace("MAPI")
Dim objfolder
Set objfolder = ns.Folders("个人文件夹").Folders("收件箱").Folders("AA").Folders("BB")
Dim objfolder2
Set objfolder2 = objfolder.Folders("CC")
Dim reg
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.MultiLine = True
reg.Pattern = "SKU:(.*)(?:\r?\n)+数量:(.*)$"
Dim r
r = 1
Range("A:B").Clear
Dim i
For i = objfolder.items.Count To 1 Step -1
Dim item
Set item = objfolder.items(i)
If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.Execute(item.body)
Dim objmatch
For Each objmatch In colmatches
Cells(r, 1) = objmatch.submatches(0)
Cells(r, 2) = objmatch.submatches(1)
r = r + 1
Next
item.Move objfolder2
End If
Next
MsgBox "Done!"
End Sub
Sub test()
Dim outlook
Set outlook = CreateObject("outlook.application")
Dim ns
Set ns = outlook.getnamespace("MAPI")
Dim objfolder
Set objfolder = ns.Folders("个人文件夹").Folders("收件箱").Folders("AA").Folders("BB")
Dim objfolder2
Set objfolder2 = objfolder.Folders("CC")
Dim reg
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.MultiLine = True
reg.Pattern = "\r\nSKU:(.*)\r\n数量:(.*)\r\n"
Dim r
r = 1
Dim item
For Each item In objfolder.items
If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.Execute(item.body)
Dim objmatch
For Each objmatch In colmatches
Cells(r, 1) = objmatch.submatches(0)
Cells(r, 2) = objmatch.submatches(1)
r = r + 1
Next
item.Move objfolder2
End If
Next
MsgBox "Done!"
End Sub
Option Explicit
Dim fso
Set fso = createobject("scripting.filesystemobject")
Dim curdir
curdir = fso.getparentfoldername(wscript.scriptfullname)
Dim outlook
set outlook = createobject("outlook.application")
Dim outfile
outfile = fso.buildpath(curdir,"output.csv")
Dim stream
Set stream = fso.opentextfile(outfile,2,True)
Dim ns
set ns = outlook.getnamespace("MAPI")
Dim objfolder
set objfolder = ns.folders("个人文件夹").folders("收件箱").folders("AA").folders("BB")
Dim objfolder2
set objfolder2 = objfolder.folders("CC")
Dim reg
Set reg = createobject("vbscript.regexp")
reg.Global = True
reg.ignorecase = True
reg.multiline = True
reg.pattern = "\r\nSKU:(.*)\r\n数量:(.*)\r\n"
Dim item
for each item in objfolder.items
If reg.test(item.body) Then
Dim colmatches
Set colmatches = reg.execute(item.body)
Dim objmatch
For Each objmatch In colmatches
stream.writeline objmatch.submatches(0) & "," & objmatch.submatches(1)
Next
item.move objfolder2
End If
Next
stream.close
msgbox "Done!"