PR
キーワードサーチ
▼キーワード検索
EXCEL VBA TIPS
わたしのブログへようこそ
カレンダー
コメント新着
フリーページ
2008.07.12
テーマ： パソコン講師(297)
カテゴリ： カテゴリ未分類
前提：MeiwakuKW.txtのファイル名で迷惑メールと判断するキーワードが１行１件記述すること
動作：受信トレイのタイトルとMeiwakuKW.txt中の迷惑キーワードをつき合わせ、含まれるものを"迷惑"のフォルダーに移動する
以下スクリプトのソースです
Dim objMail, objApp, objArgs
dim kw(9999)
Set objApp = CreateObject("Outlook.Application")
Set olNameSPC = objApp.GetNamespace("MAPI")
dest = "迷惑"
mail_folder = "受信トレイ"
Set Fs = WScript.CreateObject("Scripting.FileSystemObject")
Set oTs1 = Fs.OpenTextFile("MeiwakuKW.txt",1)
kc=0
Do Until oTs1.AtEndOfStream 'oTs1を末端まで読み込むまでループを繰り返す
s = oTs1.ReadLine
kw(kc)=s
kc=kc+1
loop
oTs1.Close
mcnt=0
ac=0
mc=0
For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count
If olNameSPC.Folders(1).Folders(nFCNT).name = mail_folder Then Exit For
Next
If nFCNT > olNameSPC.Folders(1).Folders.Count Then
MsgBox (mail_folder & "はありません")
else
For Each objItem In olNameSPC.Folders(1).Folders(nFCNT).Items
mcnt=mcnt+1
With objItem
'dteCreateDate = .CreationTime
strSubject = .Subject
'strAddress = .To
'strItemType = TypeName(objItem)
'strBody = .body
End With
hit=false
for i=0 to kc-1
if instr(kw(i),strSubject)>0 then
mc=mc+1
objItem.Move olNameSPC.Folders(1).Folders(dest)
exit for
end if
next
next
End If
Set oTs1 = Fs.OpenTextFile("MeiwakuKW.txt",2,true)
for i=0 to kc-1
oTs1.writeline kw(i)
next
oTs1.Close
msgbox "total=" & mcnt & " move=" & mc
Set olNameSPC = Nothing
Set objApp = Nothing
動作：受信トレイのタイトルとMeiwakuKW.txt中の迷惑キーワードをつき合わせ、含まれるものを"迷惑"のフォルダーに移動する
以下スクリプトのソースです
Dim objMail, objApp, objArgs
dim kw(9999)
Set objApp = CreateObject("Outlook.Application")
Set olNameSPC = objApp.GetNamespace("MAPI")
dest = "迷惑"
mail_folder = "受信トレイ"
Set Fs = WScript.CreateObject("Scripting.FileSystemObject")
Set oTs1 = Fs.OpenTextFile("MeiwakuKW.txt",1)
kc=0
Do Until oTs1.AtEndOfStream 'oTs1を末端まで読み込むまでループを繰り返す
s = oTs1.ReadLine
kw(kc)=s
kc=kc+1
loop
oTs1.Close
mcnt=0
ac=0
mc=0
For nFCNT = 1 To olNameSPC.Folders(1).Folders.Count
If olNameSPC.Folders(1).Folders(nFCNT).name = mail_folder Then Exit For
Next
If nFCNT > olNameSPC.Folders(1).Folders.Count Then
MsgBox (mail_folder & "はありません")
else
For Each objItem In olNameSPC.Folders(1).Folders(nFCNT).Items
mcnt=mcnt+1
With objItem
'dteCreateDate = .CreationTime
strSubject = .Subject
'strAddress = .To
'strItemType = TypeName(objItem)
'strBody = .body
End With
hit=false
for i=0 to kc-1
if instr(kw(i),strSubject)>0 then
mc=mc+1
objItem.Move olNameSPC.Folders(1).Folders(dest)
exit for
end if
next
next
End If
Set oTs1 = Fs.OpenTextFile("MeiwakuKW.txt",2,true)
for i=0 to kc-1
oTs1.writeline kw(i)
next
oTs1.Close
msgbox "total=" & mcnt & " move=" & mc
Set olNameSPC = Nothing
Set objApp = Nothing
お気に入りの記事を「いいね！」で応援しよう
【毎日開催】
15記事にいいね！で1ポイント
© Rakuten Group, Inc.
