Outlookで予定の件名をVBAから書き換える方法

前へ 次へ
このQ&Aのポイント
  • Outlookの予定の件名をVBAを使用して書き換えたい場合、Subjectプロパティを使用しますが、うまくいかない場合があります。
  • 以下のコードを使用することで予定の件名を変更できるはずですが、現在の状況ではうまく機能しません。
  • 対象の予定の件名が変更されていない場合、他の方法を検討する必要があります。
回答を見る
  • ベストアンサー

Outlookで、予定の件名をVBAから書き換えたいのですが

Outlookで、予定の件名をVBAから書き換えたいのですが うまくいきません。 環境は、OS:Win2000、Ver: Outlook2000 SP3です（古いですが）。 今のところ、ネット上で拾ったコードを元に、 Dim colAppts As Items Set colAppts = Application.Session.GetDefaultFolder(olFolderCalendar).Items For i = 1 To colAppts.Count MsgBox colAppts.Item(i).Subject colAppts.Item(i).Subject = "ほげ" colAppts.Item(i).Save MsgBox colAppts.Item(i).Subject Next というようなことをやってみたのですが、Subjectプロパティへの代入前後で、 内容がまったく変わりません。 どうやったらいいのでしょうか？

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

  • ベストアンサー
回答No.2

以下でどうでしょうか? Dim colAppts As Items Dim apptItem As Appointmentitem Set colAppts = Application.Session.GetDefaultFolder(olFolderCalendar).Items For i = 1 To colAppts.Count Set apptItem = colAppts(i) MsgBox apptItem.Subject apptItem.Subject = "ほげ" apptItem.Save MsgBox apptItem.Subject Next

hzd00430
質問者

お礼

カンペキです。 いったんAppointmentitemオブジェクトに書き出すのがポイントなんですね。 ありがとうございました。

その他の回答 (1)

  • Wendy02
  • ベストアンサー率57% (3570/6232)
回答No.1

こんな風にしたらいかがでしょうか？ Sub OutlookTest1() 　　Dim colAppts As Items 　　Set colAppts = Application.Session.GetDefaultFolder(olFolderCalendar).Items 　　For i = 1 To colAppts.Count 　　　　MsgBox colAppts.Item(i).Subject 　　　　colAppts.Item(i).Display 　　　　colAppts.Item(i).Subject = "ほげ" 　　　　colAppts.Item(i).Close olSave 　　　　MsgBox colAppts.Item(i).Subject 　　Next End Sub

hzd00430
質問者

お礼

すみません。環境の違いかもしれませんが、 私のところではこれでは前後で変化なしでした。 ご回答ありがとうございました。

  1. カテゴリ
  2. パソコン・スマートフォン
  3. ソフトウェア
  4. オフィス系ソフト

関連するQ&A

  • Outlook2007のVBAで

    Outlook2007のVBAで Outlook2007のVBAで件名か本文にAかBの文字列を含んでいるときにアラートを表示させるというマクロを作りたいのですがどのようにすればいいのかわかりません。 あと本文はItem.bodyで件名はItem.Subjectを使ってますがこれでよろしいのですか？

  • OutlookのVBAについて教えてください

    はじめまして。 Outlookにて仕訳ルールの処理にて 特定のアドレスの方からのメールを仕訳け、さらに 添付ファイルを保存する。という処理を行っています。 添付ファイルの保存自体はネットでのVBAを参考に 作成することができました。 ただ、OutLook起動時に複数件、同じメールがある場合、 一番古いメールの添付ファイルのみが保存されてしまっているようです。 解決方法がわかる方、教えてください。 やりたいことは以下のとおりです。 宜しくお願い致します。 ■実現したいこと ・件名Aのメールの場合：添付ファイルをフォルダーAへ保存 ・件名Bのメールの場合：添付ファイルをフォルダーBへ保存 ・件名Cのメールの場合：添付ファイルをフォルダーCへ保存 ・件名Dのメールの場合：添付ファイルをフォルダーDへ保存 ■OutLookのVBA Public Sub SaveAttachments(objMsg As MailItem) Const SAVE_Dir = "C:\" Dim objFSO As Object Dim objAttach As Attachment Dim strFileName As String Dim c As Integer: c = 1 Dim flg As Integer: flg = 1 Dim SAVE_PATH As String Set objFSO = CreateObject("Scripting.FileSystemObject") ' 件名により、保存先のパスを変更します。 SAVE_PATH = SAVE_Dir If VBA.Right(SAVE_PATH, 1) <> "\" Then SAVE_PATH = SAVE_PATH & "\" Select Case objMsg.Subject Case "件名A" SAVE_PATH = SAVE_PATH & "フォルダーA" Case "件名B" SAVE_PATH = SAVE_PATH & "フォルダーB" Case "件名C" SAVE_PATH = SAVE_PATH & "フォルダーC" Case "件名D" SAVE_PATH = SAVE_PATH & "フォルダーD" Case Else flg = 0 End Select If VBA.Right(SAVE_PATH, 1) <> "\" Then SAVE_PATH = SAVE_PATH & "\" ' 指定のフォルダに添付ファイルを格納 If flg = 1 Then For Each objAttach In objMsg.Attachments With objAttach strFileName = SAVE_PATH & objAttach.FileName .SaveAsFile strFileName End With Next End If End Sub

  • エクセル2007　VBAでアウトルック2007の予定表を作るんですが、

    エクセル2007　VBAでアウトルック2007の予定表を作るんですが、 日付まではうまくいったのに開始時刻が指定できません。 エクセルでのファイルを保存した後にそのファイルを添付したアウトルック予定表を作成します。 予定日は3ヶ月後、開始時刻は8:30amにしたいのですが、どうにも開始時刻だけが指定できません。 なにかいい方法があるでしょうか？ こちらを参考に途中までは出来ています。 http://www.ken3.org/cgi-bin/group/vba_outlook.asp ただし、予定表の開始時刻が0:00となっているので、ここを8時30分にしたいのです。 （終了時間はあまり気にしません） そもそも出来ないのかな？ コードは下記です。 Sub 保存() '保存コード省略　Flnm=フォルダとファイル名 'ここからアウトルックの操作 Dim oApp As Object Dim myNameSpace As Object Dim myFolder As Object Dim strMOJI As String Dim objITEM As Object 'outlook 起動 Set oApp = CreateObject("Outlook.Application") Set myNameSpace = oApp.GetNamespace("MAPI") Set myFolder = myNameSpace.GetDefaultFolder(9) '起動時フォルダーを指定 myFolder.Display 'アイテムの作成 Set objITEM = oApp.CreateItem(1) '予定表作成画面を指定 objITEM.Display '編集画面を表示 '予定表内容 objITEM.Subject = "見積り発行後のフォロー" '件名 objITEM.body = "見積り発行から3ヶ月経ちました" '本文 objITEM.Attachments.Add Flnm 'ファイルの添付 objITEM.Start = DateAdd("m", 3, Date) '予定日 'ここらへんがわからない　　　　　　　 '開始時間も入れたい 'objITEM.Save 　　　　　　　　　　　　　　　　'保存 'objITEM.Close 2 　　　　　　　　　　　　　　　　 '閉じる End Sub 開始時刻以外はすべてうまく処理出来ています。

  • 実行時エラー配列のインデックスが範囲内にありません

    アウトルックvbaで、受信トレイのメールをすべてループして、 該当のメールを削除するコードを作ったのですが 連続して削除しようとすると 実行時エラー-2147352567 「配列のインデックスが範囲内にありません」になります。 ------------------------------------------------------------------- Sub test() Dim requestsFolder As MAPIFolder Dim appNameSpace As NameSpace Dim requestMailItem As MailItem Dim i As Integer Dim j As Long '削除した個数を数える Set appNameSpace = Application.GetNamespace("MAPI") Set requestsFolder = appNameSpace.GetDefaultFolder(olFolderInbox) j = 1 For i = 1 To requestsFolder.Items.Count Set requestMailItem = requestsFolder.Items.Item(i) If requestMailItem.Subject Like "*キャンペーン*" Then '削除済みフォルダへ移動する requestMailItem.Delete Debug.Print j & "個目削除" j = j + 1 End If Next i End Sub ------------------------------------------------------------------- このコードを使っています。 エラーになるのは、 2個目削除後だったり、３個目削除後だったりさまざまで安定しません。 このエラーになる原因がわからないので教えていただけますか？ アウトルックのエラーというより、 Fornextステートメントのエラーという気がします。 ご教授よろしくお願いします。

  • VBAです。OUTLOOKでウンドウを選択

    OUTLOOKでVBAでマクロを組んでいます。 自動的に新規メッセージ画面を開くように設定しています。 何枚もウィンドウが開かれているので、特定の新規メッセージ画面を最前面に表示する事はできないでしょうか？ イメージではexcelのsheetをfor each でworksheetsコレクションを全部検索し、activateするイメージです。 コードは簡単に下記のようにメッセージを作成しています。 Dim oApp As New Outlook.Application Dim objmail As Object Set oApp = CreateObject("Outlook.Application") Set objmail = oApp.CreateItem(0) 'olMailItem=0 objmail.To = "宛先" objmail.Subject = "件名" objmail.Body = "本文の代入" objmail.Display '新規メッセージ画面表示 わかりにくいかもしれませんがよろしくお願いします。

  • Outlook内のZipをフォルダに送るスクリプト

    Outlookに送られてくるメール内のZipファイルをあるサーバーのフォルダに送りたいのですが、どうもEnd Subエラーが出てうまくいきません。下記のVBスクリプトを見ていただき回答をいただければ助かります。どうぞよろしくお願いいたします。 Public Sub Application_Startup() Call MailParser End Sub Private Sub Application_NewMail() Call MailParser End Sub Public Sub MailParser() Dim objContactsFolder, objContactItem, intItemCounter Dim tdystart As Date Const olFolderContacts = 6 '6 (Inbox) subject line 5 (Sent) uses mail subject line 10 (Contacts) uses full name Dim MyTempFolderString As String MyTempFolderString = "" Dim Mydate Mydate = DateFix Set objContactsFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts) Set SubFolder = objContactsFolder.Folders("Inbox") ' Example ("AAA") intItemCounter = SubFolder.Items.Count If intItemCounter = 0 Then Exit Sub 'position counter for the item Set objContactItem = SubFolder.Items(intItemCounter) 'set to last email Set mymailitem = SubFolder.Items(intItemCounter) For I = 1 To intItemCounter Step 1 DoEvents Dim TempDir As String TempDir = "" Set mymailitem = SubFolder.Items(I) 'check for source If InStr(mymailitem.Subject, "Outlook内のファイル件名が入ります") <> 0 Then MyTempFolderString = "\\フォルダ名が入ります\" ElseIf InStr(mymailitem.Subject, "上と同じOutlook内のファイル件名が入ります") <> 0 Then MyTempFolderString = "\\上と同じフォルダ名が入ります\" End If If MyTempFolderString = "" Then GoTo NextI myAttachCount = mymailitem.Attachments.Count 'set counter for number of attachments Do Until myAttachCount = 0 DoEvents Set myAttachments = mymailitem.Attachments myAttachments.Item(myAttachCount).SaveAsFile MyTempFolderString & Mydate & myAttachments.Item(myAttachCount).DisplayName Loop NextI: Next I End Function Function OpenOutlookFolder(StrFolderPath As String) As Outlook.MAPIFolder Dim arrFolders As Variant, _ varFolder As Variant, _ bolBeyondRoot As Boolean On Error Resume Next If StrFolderPath = "" Then Set OpenOutlookFolder = Nothing Else Do While Left(StrFolderPath, 1) = "\" StrFolderPath = Right(StrFolderPath, Len(StrFolderPath) - 1) Loop arrFolders = Split(StrFolderPath, "\") For Each varFolder In arrFolders Select Case bolBeyondRoot Case False Set OpenOutlookFolder = Outlook.Session.Folders(varFolder) bolBeyondRoot = True Case True Set OpenOutlookFolder = OpenOutlookFolder.Folders(varFolder) End Select If Err.Number <> 0 Then Set OpenOutlookFolder = Nothing Exit For End If Next End If On Error GoTo 0 End Function Function DateFix() If Len(Month(Now)) < 2 Then strMM = "0" & Month(Now) Else strMM = Month(Now) End If If Len(Day(Now)) < 2 Then strDD = "0" & Day(Now) Else strDD = Day(Now) End If DateFix = Year(Now) & "_" & strMM & "_" & strDD End Function

  • 【outlook】１か月分の予定表を書き出すＶＢＡ

    こんにちは。 Outlook2010で１か月分の予定をエクセルに書き出したいと考えています。 以下のＶＢＡを見つけることはできましたが、１か月分の予定を書き出すＶＢＡに書き換えができませんでした。 どのように修正すべきかご教示いただければと存じます。 よろしくお願いします。 ---------------------------------------------- Sub Excel週間予定() '期間指定 Dim dateFrom As Date Dim dateTo As Date '初期値 dateFrom = Date '入力ダイアログを表示 dateFrom = InputBox("開始日を入力してください。", "週間予定", dateFrom) '7日間 dateTo = DateAdd("d", 7, dateFrom) 'MsgBox dateFrom 'MsgBox dateTo '予定表モジュールを取得 Dim calmod As CalendarModule Set calmod = Application.ActiveExplorer.NavigationPane.Modules.GetNavigationModule(olModuleCalendar) 'MsgBox calmod 'Excelを取得 Dim Excelapp As Object Set Excelapp = CreateObject("Excel.Application") '表示 Excelapp.Visible = True 'ブックを作成 Excelapp.Workbooks.Add 'ヘッダを準備 Excelapp.Range("A1:G1") = Array("予定表", "件名", "場所", "開始時刻", "終了時刻", "終日イベント") '2行目から Dim row As Integer row = 2 'すべての予定表グループに対して Dim grp As NavigationGroup For Each grp In calmod.NavigationGroups 'MsgBox grp 'すべての予定表に対して Dim fol As NavigationFolder For Each fol In grp.NavigationFolders 'MsgBox fol 'チェックされている予定表のみ If fol.IsSelected Then 'MsgBox fol '予定の絞り込み Dim col As Items Set col = fol.Folder.Items col.Sort "[Start]" col.IncludeRecurrences = True Dim appointment Set appointment = col.Find("[Start] < """ & Format(dateTo, "yyyy/mm/dd") & """ AND [End] >= """ & Format(dateFrom, "yyyy/mm/dd") & """") '見つかった予定に対して While Not appointment Is Nothing Excelapp.Cells(row, 1).Value = fol.DisplayName Excelapp.Cells(row, 2).Value = appointment.Subject Excelapp.Cells(row, 3).Value = appointment.Location Excelapp.Cells(row, 4).Value = appointment.Start Excelapp.Cells(row, 5).Value = appointment.End Excelapp.Cells(row, 6).Value = appointment.AllDayEvent row = row + 1 Set appointment = col.FindNext Wend End If Next Next 'MsgBox "end" End Sub

  • outlook　実際のアイテム数より１多い数が取得

    http://www.geocities.co.jp/SiliconValley-Bay/3475/outlook_vba.html の フォルダ内のすべてのメールを処理 　 Dim ns As NameSpace Dim mf As MAPIFolder Dim x As Integer Set ns = GetNamespace("MAPI") Set mf = ns.Folders("個人用フォルダ").Folders("test") For x = 1 To mf.Items.Count 　　' ここに処理を記述 Next MsgBox x & "件の処理が終了しました。" を実行すると、実際のアイテム数より１多い数が取得されるのですが なぜでしょうか？

  • <EXCEL/VBA> OUTLOOKのウインドを閉じる方法

    EXCEL/VBAで、OUTLOOKのウインドを閉じる方法を教えて下さい。 OUTLOOKを立ち上げた状態で、EXCEL/VBAで下記のようにOUTLOOKのフォルダーを指定してウインドを表示していますが、 VBAで開いたウインドのみ閉じたいのですが、うまく行きません。 oApp.Quitだと元々立ち上げていたoutlookも含めて終了してしまいます。宜しく、お願いします。 Sub OL_TEST() Dim oApp As Object 'OutlookのApplication オブジェクト Dim myNameSpace As Object '名前スペース Dim myFolder As Object 'フォルダー指定 Set oApp = CreateObject("Outlook.Application") Set myNameSpace = oApp.GetNamespace("MAPI") Set myFolder = myNameSpace.GetDefaultFolder(6) '規定のフォルダー olFolderInbox=6 指定 myFolder.Display '表示

  • VBAで二重起動を防止したいのですが、

    VBAで二重起動を防止したいのですが、 いろいろ調べましたが、わかりませんでした。 なにかいい方法はないでしょうか？ EXCELで見積書を作成して、そのファイルをVBAで保存するとき、ついでに、Outlook予定表に見積り期限日予定を入れるものです。 ファイル保存コード省略　Flnm=パス 'ここからアウトルック操作 Dim oApp As Object Dim myNameSpace As Object Dim myFolder As Object Dim objITEM As Object 'outlook 起動 Set oApp = CreateObject("Outlook.Application") '既に起動してても新規起動 Set myNameSpace = oApp.GetNamespace("MAPI") Set myFolder = myNameSpace.GetDefaultFolder(9) '起動時フォルダーを指定 myFolder.Display 'アイテムの作成 Set objITEM = oApp.CreateItem(1) '予定表作成画面を指定 objITEM.Display '編集画面を表示 '予定表内容 objITEM.Subject = "見積り発行後のフォロー" '件名 objITEM.body = "見積り発行から3ヶ月経ちました" '本文 objITEM.Attachments.Add Flnm 'ファイルの添付 objITEM.Start = DateAdd("m", 3, Date) & " 8:30" '予定日と開始時間 objITEM.Save '保存 objITEM.Close 2 '閉じる EXCEL2007とOutlook2007を使用しています。 1.多重起動しないことと 2.起動中で最小化されたOutlookがあるならアクティブ化して予定を入れる、または 3.起動していなかったら起動させて、予定を入れる と云うことがやりたいのですが・・・

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する