スパムメール対策(OutlookVBA)
2009/10/25
もう冬ですね。寒いですね。
我が家ではエアコンの暖房をつけはじめました。
さて、先日職場にて、スパムメールに悩まされている先輩がいらっしゃいました。サイトを複数運営しており、その問い合わせ用メールアドレスには、世界中からスパムメールが届き、それを区分けするだけでいっぱい時間がかかっちゃうと・・・
んで、その先輩のために、「オリジナルスパムメール対策ＶＢＡマクロ」を作ったので、ついでにここで紹介しちゃいます。
ちなみにメーラはoutlook2003です。
ポイントは３つに絞りました。
・１．外国からのメールはシャットアウト!
・２．タイトルも本文も半角英数記号の場合、シャットアウト!
・３．タイトルは半角英数記号、本文は日本語混じり
上記の場合、適当なフォルダに新着メールを移動します。外国人の友達がいる場合、ちょっと厳しい条件ですのでお気をつけ下さい。
１の条件の外国からのメールの条件としては、メールのヘッダ情報にあるメール送信日時に着目しました。メール送信日時は、送られてくる国からのグリニッジ時差情報も得られます。日本は＋９時間ですから、それを見て判断します。時差＋9時間の国が他にあるとか言う声は聞こえてきません。
２と３は、そのまま文字を見て判断するだけなので、正規表現でチャチャッと判定します。
・・・あれ、outlook2003じゃ、メールのヘッダー情報取れない!？
むはー、困ったなぁ・・・
と１時間悩んだ結果、色々調べてＣＤＯ．ＤＬＬってのを使うことにしました。ＯＳがＸＰの人はインストールＣＤから取れるってことですが、ネット上からダウンロードして組み込みました。ちなみにoutlook2007だと、そんなことせずにメールのヘッダー情報が取れるって話です。むぅ。
んで、せっかくなのでＣＤＯ．ＤＬＬ内にある、MAPIオブジェクトってのを使ってＶＢＡを全部実装しました。
それがこちら。
そうそう、細かい説明はしてませんが、参照設定に「Microsoft CDO 1.21 Library」を追加したり、モジュールの置き場所とかわからない人は、ご自身でお勉強ついでに調べて下さい＾＾；
オリジナルスパムメール対策ＶＢＡマクロ
Private Sub Application_NewMail()
Dim oSession As MAPI.Session
Dim oFolders As Folder
Dim Folder() As Folder
Dim Flag() As Boolean
Dim sFolderName() As String
Dim Msgs As Messages
Dim myMsg As Message
'##########初期処理##########
ReDim sFolderName(0 To 2)
sFolderName(0) = "_IKM1:送信者が日本時間以外"
sFolderName(1) = "_IKM2:件名が英語で本文も英語"
sFolderName(2) = "_IKM3:件名が英語で本文は日本語"
ReDim FolderName(UBound(sFolderName))
ReDim Flag(UBound(sFolderName))
ReDim Folder(UBound(sFolderName))
Set oSession = New MAPI.Session: oSession.Logon "Outlook"
Set oFolder = oSession.GetDefaultFolder(CdoDefaultFolderInbox)
'##########フォルダなかったら作成##########
For Each v1 In Flag: v1 = False: Next v1
For Each v2 In oFolder.Folders
For i = 0 To UBound(sFolderName) Step 1
If sFolderName(i) = v2.Name Then Flag(i) = True
Next i
Next v2
For i = 0 To UBound(sFolderName) Step 1
If Flag(i) = False Then oFolder.Folders.Add (sFolderName(i))
Next i
'##########フォルダセット##########
Set Folder(0) = oFolder.Folders(sFolderName(0))
Set Folder(1) = oFolder.Folders(sFolderName(1))
Set Folder(2) = oFolder.Folders(sFolderName(2))
'##########迷惑メール処理##########
Set Msgs = oFolder.Messages
For Each myMsg In Msgs
'既読は処理しない
If myMsg.UnRead = False Then GoTo NextForLabel:
'件名なしは処理しない
If myMsg.Subject = "" Then GoTo NextForLabel:
'日本時間じゃないときは移動
If Not IsJapaneseTime(myMsg.Fields(&H7D001E)) Then
myMsg.MoveTo (Folder(0).ID)
GoTo NextForLabel:
End If
'件名は英語？
If IsCheck(myMsg.Subject) Then
'ボディも英語!
If IsCheck(myMsg.Text) Then
myMsg.MoveTo (Folder(1).ID)
'ボディは日本語!
Else
myMsg.MoveTo (Folder(2).ID)
End If
End If
NextForLabel:
Next
'##########後処理##########
oSession.Logoff
Set myMsg = Nothing
Set Msgs = Nothing
For Each v In sFolderName: v = "": Next v
For Each v In Flag: v = False: Next v
For Each v In Folder: Set v = Nothing: Next v
Set oFolders = Nothing
Set oSession = Nothing
End Sub
Private Function IsCheck(Value As String) As Boolean
Dim RE As New RegExp
RE.Pattern = "[^!-~¥s]"
IsCheck = Not RE.test(Value)
End Function
Private Function IsJapaneseTime(Value As String) As Boolean
Dim v As Variant
IsJapaneseTime = True
v = Split(Value, vbLf)
IsJapaneseTime = False
For i = 0 To UBound(v) Step 1
If Left(v(i), 4) = "Date" Then '送信日が
If InStr(v(i), "+09") > 0 Then '日本時刻 +0900 なら
IsJapaneseTime = True 'Trueを返す
Exit Function
End If
End If
Next i
End Function
