Accessメール取り込みで重複問題

このQ&Aのポイント
  • VBAを使用してOutlookのメールをAccessのテーブルに取り込む際、重複するメールが取り込まれてしまう問題が発生しています。
  • 対象フォルダは「個人用フォルダ」の中の「受信トレイ」の中の「集荷」です。
  • 最近ADOを勉強し始めたばかりで原因がわからないため、解決策を探しています。
回答を見る
  • ベストアンサー

Access 重複しないメールをテーブルに取り込む

参考サイトのサンプルをマネしながら少しだけ改造して、OutLookのメールをAccessのテーブル"tbl_mail"に取り込むVBAを書いてみました。 一度取り込んだメールは二度と取り込まない仕組みなのですが、実行してみると必ず1通だけ重複したメールを取り込んでしまいます。 対象フォルダは「個人用フォルダ」の中の「受信トレイ」の中の「集荷」です。 サンプルとして3通のメールを入れていますが、何度実行しても、 "新しいメールはありませんでした。"とはならずに、 "読込み1件・重複2件"となります。 最近ADOを勉強し始めたばかりで原因がさっぱりわかりません。 このサンプルに対する質問は検索してもほとんど見つけられませんでした。 よろしくお願いいたします。 Access2010(Win7)で作り、DBはUSBに保存して、Access2007(vista)でも使っています。 フォームのボタンで標準モジュールのFunction MailGetoを呼び出して実行しています。 Function MailGeto() On Error GoTo エラー Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Dim myNaSp As NameSpace Dim myFolder As MAPIFolder Dim mySecFolder As MAPIFolder Dim myThrFolder As MAPIFolder Dim myItem As MailItem Dim myindex As Long, x As Long, y As Long, i As Long, r As Long Dim MyCri As String Set cn = Application.CurrentProject.Connection Set rs = New ADODB.Recordset rs.Open "tbl_mail", cn, adOpenKeyset, adLockOptimistic Set myNaSp = GetNamespace("MAPI") Set myFolder = myNaSp.GetDefaultFolder(olFolderInbox) i = 0: r = 0 For x = 1 To myFolder.Folders.Count Set mySecFolder = myFolder.Folders(x) For myindex = 1 To mySecFolder.Items.Count Set myItem = mySecFolder.Items(myindex) '受信日時と件名をつなげた文字列を一意とする MyCri = myItem.ReceivedTime & myItem.Subject '条件…"tbl_mail"テーブルの"KEY"フールドの値と一致するもの rs.Find "KEY='" & MyCri & "'" If rs.EOF Then '検索条件と合致する物がない場合 rs.AddNew rs!Key.Value = MyCri rs.Fields("フォルダー").Value = mySecFolder rs.Fields("受信日").Value = myItem.ReceivedTime rs.Fields("送信者").Value = myItem.SenderName rs.Fields("件名").Value = myItem.Subject rs.Fields("メール").Value = myItem.SenderEmailAddress rs.Fields("内容").Value = myItem.Body rs.Update i = i + 1 'メール件数を求めます。 Else r = r + 1 End If Next Next If i = 0 Then MsgBox "新しいメールはありませんでした。" Else MsgBox "メールの更新が完了しました。" & Chr(13) & Chr(13) & _ "・読込み " & i & "件" & Chr(13) & _ "・重複 " & r & "件" End If rs.Close cn.Close Exit Function エラー: If Err.Number = 287 Then MsgBox "書き出しを中止しました" Else MsgBox Err.Number & Err.Description MsgBox "予期せぬエラーが発生しました" End If End Function

質問者が選んだベストアンサー

  • ベストアンサー
  • nicotinism
  • ベストアンサー率70% (1019/1452)
回答No.2

大変申し訳ありません。 私の勘違いだったようです。 検証結果、条件に合致しない場合には、EOF BOF ともに True になりました。 迷宮に入っていたのはヘルプを~@;}%した私でした。 orz こちらでは何故か、主キー設定無し・全てのフィールドでインデックス無し にしても機能しました? >1つ目のメールアイテムに対して・・・ こちらです。

synergy472
質問者

お礼

わざわざ調べていただいてありがとうございます。 おかげさまで自分なりにEOF BOFについて調べて、より深く理解することができました。 主キーについては謎のままですが、ADOで更に違うテーブルへレコードを書き移す際にも主キーがないとうまくいきませんでしたので、設定したままにしておきます。 >1つ目のメールアイテムに対して・・・ >こちらです。 なるほど、そうなんですね。 意味が分かってくると捗りますし楽しいです。 お忙しい中ありがとうございました。 次の機会があればまた宜しくお願いいたします。

その他の回答 (1)

  • nicotinism
  • ベストアンサー率70% (1019/1452)
回答No.1

ここが迷宮の入り口かも? >If rs.EOF Then '検索条件と合致する物がない場合 合致しない場合に、EOFにはならなくて最後のレコードに移動します。 ヘルプより 『カレント行の位置は、検出されたレコードに設定され、 条件を満たす行がない場合は、Recordset の最後 (または最初) に設定されます』 EOF は最後のレコードの【次】です。 『EOF カレント レコードの位置が Recordset オブジェクトの最後のレコードより後にあることを示します。』 なので、rs.EOF は常に不成立です。 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DAOのレコードセットなら、NoMatch プロパティで簡単に調べられますので DAOのレコードセットを使われるのが分かりやすいかと思います。 (Find でも Seek でも有効です) ADO で、Rs.Recordcount = Rs.AbusolutePosition で最後のレコードか否かを判断できますが 最後のレコードに行った理由が 該当するレコードが無いため、か たまたま最終レコードが該当したため、かは判別不能のような気がします。 (自信なさげ・・・)

synergy472
質問者

お礼

すみません OKwaveの利用は初めてなので… ここへの入力をしていませんでした… ありがとうございました。

synergy472
質問者

補足

ありがとうございます。 実は回答を待つ間にテーブルのKEYフィールドに主キーを設定したところ、正常に作動しました。(理由はよくわからないままですが…) >合致しない場合に、EOFにはならなくて最後のレコードに移動します。 読むほどにわからなくなってきたので少しご解説頂きたいのですが、上記rs.Find…の動作は、カレントレコードのフィールドの値1つに対してメールアイテムの最初から最後までを捜索するのか、1つ目のメールアイテムに対してフィールドの値の最初から最後までを捜索するのかどちらなんでしょうか。 自分では前者だと思っているのですが…。(トンデモ質問でしたらスミマセン)

関連するQ&A

  • ダイレクトに目的のフォルダを指定する方法は?

    全てのフォルダをループするのではなく、 ダイレクトに目的のフォルダを指定する方法はありますか? アクセスからアウトルックの該当のフォルダの中身を取得したいのですが 下記コードで目的通り取得できるのですが コードが遠回りの気がします。 ダイレクトにフォルダを指定する方法があれば教えてください。 Sub test() Dim myNaSp As Namespace Dim myFolder As MAPIFolder Dim mySecFolder As MAPIFolder Dim myThrFolder As MAPIFolder Dim FolderName As String Dim myItem As MailItem Dim myindex As Long Set cn = CurrentProject.Connection Set myNaSp = GetNamespace("MAPI") For Each myFolder In myNaSp.GetDefaultFolder(olFolderInbox).Folders For myindex = 1 To myFolder.Items.Count Set myItem = myFolder.Items(myindex) If myFolder.Name = "testフォルダ" Then Debug.Print myItem.Body End If Next Next Set myNaSp = Nothing Set myFolder = Nothing End Sub

  • Access ADP テーブル 説明欄を取得したい

    大変お世話になります。 Access 2007 ADPファイルにて SQL Server 2005 との接続でのシステムを運用しています。 テーブル情報のフィールド説明欄(Description) の値の一覧を取得したいと思い下記のプログラムを作ってみたのですが、Descriptionの値以外はおおむね取得できるのですが、説明欄のところがすべてエラーになってしまい説明欄の Description の取得ができません。 格納場所か、プロパティの参照の仕方が原因だと思うのですが、解決できません。 テーブルの説明欄(Description)値の参照の仕方をご存じの方がいらっしゃいましたら何卒ご教授いただければと存じます。 よろしくお願いいたします。     Dim Cn As ADODB.Connection     Dim Rs As New ADODB.Recordset     Dim SQL As String     Dim i As Integer          Set Cn = CurrentProject.Connection          SQL = " SELECT dbo.テーブルA.* "     SQL = SQL & " FROM dbo.テーブルA"     Dim MyDB As New ADOX.Catalog     Dim MyTable As ADOX.Table     Dim MyField As ADOX.Column     MyDB.ActiveConnection = CurrentProject.Connection     Set MyTable = MyDB.Tables("テーブルA")          Rs.Open SQL, Cn, adOpenForwardOnly, adLockReadOnly         For i = 0 To Rs.Fields.Count - 1             MsgBox Rs.Fields(i).Name                                     'MsgBox MyTable.Columns(Rs.Fields(j).Name).Properties("Description").Value             MsgBox Rs.Fields(i).Properties("Description").Value             MsgBox Rs.Fields(i).ActualSize             MsgBox Rs.Fields(i).Attributes             'MsgBox Rs.Fields(i).DataFormat             MsgBox Rs.Fields(i).DefinedSize             MsgBox Rs.Fields(i).NumericScale             'MsgBox Rs.Fields(i).OriginalValue             MsgBox Rs.Fields(i).Precision                          'MsgBox Rs.Fields(i).Properties("Description")                                      MsgBox Rs.Fields(i).Status             MsgBox Rs.Fields(i).Type             'MsgBox Rs.Fields(i).UnderlyingValue             MsgBox Rs.Fields(i).Value                  Next     Set MyDB = Nothing     Rs.Close     Set Rs = Nothing     Cn.Close     Set Cn = Nothing     Exit Sub

  • アクセスVBA。ADO

    CSVから列を分割してテーブルにしたいかったので 下記のコードを記述しましたが、 Dim cn As ADODB.Connection Dim rs As New ADODB.Recordset Dim datacount As Long Set cn = New ADODB.Connection With cn .ConnectionString = "Provider=Microsoft.jet.OLEDB.4.0;Data Source=" & CurrentProject.Path & "\;" .Properties("Extended Properties").Value = "text;HDR=YES;" .Open End With Set rs = cn.Execute("SELECT * FROM 構成マスタ.csv") datacount = rs.Fields.Count For i = 0 To datacount strsql = "SELECT " & rs.Fields(i).Name & " INTO " & rs.Fields(i).Name & " FROM 構成マスタ.csv;" cn.Execute strsql Next i rs.Close cn.Close Set rs = Nothing Set cn = Nothing SQLを実行するところで、「日付エラー」となってしまいます。 データには特に日付等はないのでエラーになる原因がわかりません。 どなたかご教示いただけますでしょうか。

  • なぜrs.Move i ではダメなのでしょうか?

    access2003です。 テーブル1には、 フィールド1 あ い う え お が入っています。 Sub test() Dim cn As New ADODB.Connection Dim rs As New ADODB.Recordset Dim i As Long Set cn = CurrentProject.Connection rs.Open "テーブル1", cn, adOpenKeyset, adLockOptimistic For i = 0 To rs.RecordCount rs.Move i Debug.Print rs.Fields(0).Value Next rs.Close: Set rs = Nothing cn.Close: Set cn = Nothing End Sub をすると、 あ い え とイミディエイトウインドウに表示されるのですが Debug.Print rs.Fields(0).Value の部分で 「実行時エラー'3021' BOFとEOFのいずれかTRUEになっていか、または現在のレコードが削除されています。 要求された操作には、現在のレコードが必要です。」 となります。 その時のiの値は、3です。 rs.MoveFirst For i = 1 To rs.RecordCount Debug.Print rs.Fields(0).Value rs.MoveNext Next にすると、 あ い う え お が取得されます。 なぜrs.Move i ではダメなのでしょうか? 理由を教えてください。

  • エクセルでアクセスのクエリを更新したい

    お世話になります。 アクセスのデータをエクセルで編集する方法を勉強しています。 アクセスのクエリをエクセルで呼び出すところまで成功しました。 ところが、クエリを読み込んだ後、アクセスのクエリに戻すところで煮詰まっています。 ************************************************************** Sub btn更新_Click() Dim DelCmd As String Dim z As Long Dim i As Long Dim cn As Connection Dim rs As Recordset Set cn = New Connection cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=C:\Excel\Sample.mdb" cn.Open DelCmd = "DELETE * FROM クエリA" cn.Execute DelCmd If Range("A1").Value = "" Then z = 0 Else z = Range("A1").End(xlDown).Row End If Set rs = New Recordset rs.Open "クエリA", cn, adOpenKeyset, adLockOptimistic For i = 1 To z rs.AddNew rs!番号 = Range("A" & i).Value rs!日付 = Range("B" & i).Value rs!担当者 = Range("C" & i).Value rs!顧客名 = Range("D" & i).Value rs!内容 = Range("E" & i).Value rs.Update Next MsgBox "更新しました" '後処理 rs.Close: Set rs = Nothing cn.Close: Set cn = Nothing End Sub *********************************************************** という構文を作ってみたのですが、 rs.Open "クエリA", cn, adOpenKeyset, adLockOptimisticのところで ストップし、SQLステートメントがただしくありません。 'DELETE'、'INSERT'、'PROCEDURE'、'SELECT'、または'UPDATE'を使用してください。というエラーになります。 持っている書籍にはこのことについて何も記述が無いので、ネット検索しながら独学で解決方法を探しているのですが、めぼしい記述に出会えず、困っています。 解決方法をご存知の方、また参考になる書籍・サイトをご存知の方、お力をお貸しください。 OS:windowsXP Excel:2003 Access:2003

  • アクセスにてテーブル内の重複チェックについて

    下記の様なテーブル構成になっています。 大分類マスタ 大分類 長整数型 分類見出し 文字列 このテーブルにフォームから入力をさせているのですが重複チェックの時にvercheckのデータ形式が違いますと出てエラーが出ます。色々とデータ形式を変えたのですがうまくいきません。 どの様にすれば宜しいのでしょうか?ご教授頂きます様お願い致します。 尚、テーブルの数値を文字形式にすれば動作するのは分かっているのですが数値形式の場合の やり方を教えてください。 Dim str大分類 As String Dim str分類見出し As String Dim vercheck As Variant If IsNull(大分類) = False Then str大分類 = 大分類 vercheck = DLookup("大分類", "T大分類マスタ", "大分類='" & str大分類 & "'") If Not IsNull(vercheck) Then MsgBox ("同じ大分類番号があります") Exit Sub Cancel = True Else End If Else Exit Sub End If If IsNull(分類見出し) = False Then str分類見出し = 分類見出し vercheck = DLookup("分類見出し", "T大分類マスタ", "分類見出し='" & str分類見出し & "'") If Not IsNull(vercheck) Then MsgBox ("同じ分類見出しがあります") Exit Sub Cancel = True Else End If Else Exit Sub End If -------ここからフォームから直にテーブルに書いています。--------- Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Set cn = Application.CurrentProject.Connection Set rs = New ADODB.Recordset rs.Open "T大分類マスタ", cn, adOpenKeyset, adLockOptimistic rs.AddNew rs![大分類] = Forms!F大分類マスタ登録画面!大分類 rs![分類見出し] = Forms!F大分類マスタ登録画面!分類見出し rs.Update End Sub

  • ACCESS ADOのMovePreviousについて

    毎度お世話になっております。 ACCESS2003を使用しています。 ACCESS ADOにて、レコードセットがeofになった後、 MovePreviousをし、MoveNextをし、 さらにもう一度MovePreviousをすると、 最終レコードの一つ前に戻ってしまいます。 テーブル1 フィールド1 フィールド2    1     あ    2     い    3     う    4     え    5     お コード Sub test()   Dim cn As New ADODB.Connection   Dim rs As New ADODB.Recordset   Set cn = CurrentProject.Connection   rs.Open "select * from テーブル1 order by フィールド1", cn, adOpenDynamic, adLockReadOnly   Do Until rs.EOF    rs.MoveNext   Loop   rs.MovePrevious   Debug.Print rs.Fields("フィールド1").Value   rs.MoveNext   rs.MovePrevious   Debug.Print rs.Fields("フィールド1").Value   rs.Close: Set rs = Nothing   cn.Close: Set cn = Nothing End Sub 一度目のdebug.printは5に、 二度目のdebug.printは4になります。 このような仕組みなのでしょうか。 ご教授お願いいたします。

  • excel vba で .mdb のデータ抽出

    excel vba で postdata.mdbのpostレコードから条件に合うデータを抽出しようとしています。 数日間、いろいろ調べていますが分かりません。 おそらく、SQLの部分だと思うのですが・・・ adoは初めて使う素人なので教えていただけないでしょうか。 On Error GoTo ErrGyo Set cn = New ADODB.Connection cn.Provider = "Microsoft.Jet.OLEDB.4.0" cn.Open ThisWorkbook.Path & "\postdata.mdb" Dim Rs As ADODB.Recordset Dim SQL As String Dim T_ken As String Dim T_si As String Dim T_mati As String Dim i As Long T_ken = TextBox1.Value  ’フォームにテキストボックス T_si = TextBox2.Value T_mati = TextBox3.Value SQL = "SELECT * FROM post WHERE ken like '" & T_ken & "' and si LIKE '" & T_si & "' and mati LIKE '" & T_mati & "'" Set Rs = New ADODB.Recordset Rs.Open SQL, cn, adOpenForwardOnly, adLockReadOnly MsgBox Rs.RecordCount  ’ここでチェックすると -1 となる??? If Rs.RecordCount = 0 Then MsgBox "該当するレコードは見つかりませんでした。", vbInformation Else For i = 1 To Rs.RecordCount Cells(i, 1) = Rs!num Cells(i, 2) = Rs!ken Cells(i, 3) = Rs!si Cells(i, 4) = Rs!mati Rs.MoveNext Next End If Rs.Close: Set Rs = Nothing cn.Close: Set cn = Nothing Exit Sub ErrGyo: MsgBox "postdataへの接続に失敗しました", vbCritical

  • Accessのテーブルの文字列フィールドにVBAでアクセスするには?

    いつもお世話になっております。困っていることがありますので教えていただければ幸いです。 AccessのテーブルAに、メモ型のフィールドBがあり、1000文字くらいの文字が入っています。VBAの関数Cの中でそのテーブルにアクセスし、1000文字をいろいろ処理したいと思っています。見よう見まねで試しに Dim cn As ADODB.Connection Dim rs As ADODB.Recordset Dim FileNum As Integer Set cn = CurrentProject.Connection Set rs = New ADODB.Recordset rs.Open テーブルA, cn, adOpenDynamic, adLockOptimistic msgbox !フィールドB としてみたのですが、なぜか255文字までしか表示されません。VBAを用いてテーブル(やクエリ)にアクセスし、256文字以上の文字列を扱う方法はありませんでしょうか? 何かこちらで勘違いしているところがありましたら、ご指摘いただければと思います。よろしくお願いします。

  • いつも参考にさせて頂いてます。

    いつも参考にさせて頂いてます。 Access2003で検索フォームを作成しています。 find系メソッドで検索を行い、フォームに表示させるのですが 該当データが複数あった場合の処理について質問させてください。 現在、該当データが複数あった場合、ループの中でfindnextを使用し msgboxにて次の該当データを表示させるかどうかという条件分岐をしています。 ただ、この方法だとmsgboxが画面の真ん中に出てしまうので 表示されたフォームが見ずらく、使い勝手が悪いのです・・・。 そこで自分で作成したmsgboxのようなフォームを作ったのですが どのようにしてそのフォームからの戻り値を受け取るのかと 処理の流れがわかりません。 わかる方いましたら教えてください。 宜しくお願いします。 Private Sub 検索_Click() Dim db As Database Dim rs As Recordset Dim str As String Dim msg As String Set db = CurrentDb Set rs = db.OpenRecordset("取引テーブル", dbOpenDynaset) str = "取引番号='" & Me.検索 & "'" rs.FindFirst str If rs.NoMatch = False Then Me.torihikiNo.Value = rs.Fields("取引番号") Me.torihikiDay.Value = rs.Fields("取引日") Me.kokyakuName.Value = rs.Fields("顧客名") Do Until rs.EOF rs.FindNext str If rs.NoMatch = False Then msg = MsgBox("該当データが複数存在します。次を表示しますか?" _ '←ここを変更したいのです。 , vbYesNo _ , "確認") Select Case msg Case vbYes Me.torihikiNo.Value = rs.Fields("取引番号") Me.torihikiDay.Value = rs.Fields("取引日") Me.kokyakuName.Value = rs.Fields("顧客名") Case vbNo Exit Do End Select Else MsgBox "該当データはこれ以上ありません。" Exit Do End If Loop Else Me.torihikiNo.Value = vbNullString Me.torihikiDay.Value = vbNullString Me.kokyakuName.Value = vbNullString MsgBox "該当するデータはありません。" End If rs.Close Set rs = Nothing db.Close Set db = Nothing End Sub