Dim WithEvents mySentItems As Items
Public Sub AddTrackInfo(ByVal objMail As MailItem, iRow As Integer, iCol As Integer)
Dim olkApp As Outlook.Application
Dim fldSentMail As Folder
Dim strTrackInfo As String
Dim propTrack As UserProperty
' 送信済みアイテム フォルダーを取得
Set fldSentMail = objMail.Application.Session.GetDefaultFolder(olFolderSentMail)
' mySentItems が設定されていなければ送信済みアイテム フォルダーの Items を設定
If mySentItems Is Nothing Then
Set mySentItems = fldSentMail.Items
End If
' メールに送信後の保存先フォルダーを設定
Set objMail.SaveSentMessageFolder = fldSentMail
' 送信状況を追跡するためのプロパティを設定
Set propTrack = objMail.UserProperties.Add("TrackInfo", olText, True)
' 送信日時を保存するセルの行番号と列番号を設定
propTrack.Value = iRow & "," & iCol
End Sub
' 送信済みアイテム フォルダーにアイテムが追加されたときに実行されるイベント
Public Sub mySentItems_ItemAdd(ByVal Item As Object)
Dim objMail As MailItem
Dim propTrack As UserProperty
Set objMail = Item
' 送信状況を追跡するプロパティの確認
Set propTrack = objMail.UserProperties.Find("TrackInfo")
' プロパティが存在したら
If Not propTrack Is Nothing Then
Dim arrRC As Variant
' 送信日時を保存するセルの行番号と列番号を取得
MsgBox propTrack.Value
arrRC = Split(propTrack.Value, ",")
' 取得した行、列のセルに送信日時を保存
Sheet1.Cells(CInt(arrRC(0)), CInt(arrRC(1))).Value = objMail.SentOn
End If
End Sub
For j = LBound(koumokuArray) To UBound(koumokuArray)
If InStr(preArray(i), koumokuArray(j)) > 0 Then
nukidasi = preArray(i + 1) '目的の項目の値は +1の配列に格納されている
koumoku = koumokuArray(j)
Exit For '見つかった時ループを抜ける
End If
Next j
For k = LBound(koumokuArray) To UBound(koumokuArray) '余分な項目を除く
nukidasi = Replace(nukidasi, koumokuArray(k), "")
Next k
のようにして，該当する項目を削除します。その後，koumoku に応じた外部変数に Select Case にて
記憶します。それぞれのケースでは，「県」「支部」「都」を除く処理や，文字長を制限する処理もしてあり
ます。
Select Case koumoku
Case "お名前"
simei = nukidasi
Case "ご所属"
syozoku = nukidasi
If Len(syozoku) > 20 Then
syozoku = Mid(syozoku, 1, 20)
End If
Case "電話"
denwa = nukidasi
Case "メールアドレス"
adoresu = nukidasi
Case "申し込み種別"
syubetu = nukidasi
Case "所属支部"
sibu = nukidasi
sibu = Replace(sibu, "支部", "")
sibu = Replace(sibu, "県", "")
If sibu <> "京都" Then
sibu = Replace(sibu, "都", "")
End If
Case "登録番号"
bangou = nukidasi
Case "会員番号"
kaiin_bangou = nukidasi
Case "郵便番号"
yubin = nukidas
Case "住所"
jyuusyo = nukidasi
Case "参加資格"
sanka_sikaku = nukidasi
End Select
以上が処理の流れですが，これをサブとして呼び出せるようにしてあります。以下が全文です。
Private Sub mail_koumoku_nukidasi(Honbun As String)
Dim preArray As Variant
Dim koumokuArray() As Variant
Dim buffer, buffer1, nukidasi,koumoku As String
Dim i, j, k As Integer
'最終項目の後の文字
buffer1 = "------------------------------------------------------------送信日時"
'予想される項目
koumokuArray = Array("お名前", "ご所属", "電話", "メールアドレス", "申し込み種別", "所属支部", "登録番号", "会員番号", "住所", "郵便番号", "参加資格")
'本文前処理
buffer = Mid(Honbun, InStr(Honbun, "お名前=")) '「お名前=」以前の項目を消す
buffer = Left(buffer, InStr(buffer, buffer1) - 1) '最終項目以下を消す
buffer = Replace(buffer, "ご所属先電話", "電話") '「ご所属」と「ご所属先電話」検索で区別が付かないので，置き換え
preArray = Split(buffer, "=") '"="を区切りで分割
For i = LBound(preArray) To UBound(preArray) - 1
For j = LBound(koumokuArray) To UBound(koumokuArray)
If InStr(preArray(i), koumokuArray(j)) > 0 Then
nukidasi = preArray(i + 1) '目的の項目は +1の配列に格納されている
koumoku = koumokuArray(j) '項目の保持
Exit For '見つかった時ループを抜ける
Exit For
End If
Next j
For k = LBound(koumokuArray) To UBound(koumokuArray) '余分な項目を除く
nukidasi = Replace(nukidasi, koumokuArray(k), "")
Next k
'項目に応じた変数に格納する
Select Case koumoku
Case "お名前"
simei = nukidasi
Case "ご所属"
syozoku = nukidasi
If Len(syozoku) > 20 Then
syozoku = Mid(syozoku, 1, 20)
End If
Case "電話"
denwa = nukidasi
Case "メールアドレス"
adoresu = nukidasi
Case "申し込み種別"
syubetu = nukidasi
Case "所属支部"
sibu = nukidasi
sibu = Replace(sibu, "支部", "")
sibu = Replace(sibu, "県", "")
If sibu <> "京都" Then
sibu = Replace(sibu, "都", "")
End If
Case "登録番号"
bangou = nukidasi
Case "会員番号"
kaiin_bangou = nukidasi
Case "郵便番号"
yubin = nukidas
Case "住所"
jyuusyo = nukidasi
Case "参加資格"
sanka_sikaku = nukidasi
End Select
Next i
End Sub
Public Function Search(ByVal rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean)
Dim r As Range
If Whole Then
For Each r In rng
If r.Value = keyWord Then
Set Search = r
Exit Function
End If
Next
Else
For Each r In rng
If InStr(r.Value, keyWord) > 0 Then
Set Search = r
Exit Function
End If
Next
End If
Set Search = Range("XFD1048576")←←エラー処理です。
End Function
