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.起動していなかったら起動させて、予定を入れる
と云うことがやりたいのですが・・・

回答No.4

Wendy02 · ベストアンサー

#3さんのご指摘の件ですが、おそらく、Outlook の「マルチユース(Multi-Use)」のことを指しているかとは思います。それ自体では、確かに、Outlookは、「マルチユース」ですから、二重起動はしないです。 CreateObject("Outlook.Application") で、オートメーション・オブジェクトを作るなら、二重起動はしませんが、その後、MAPIで名前空間を作り、「予定表」を表示しています。だから、そのマクロを繰り返せば、「予定表」が二重に起動します。

だから、#2のコードは、既に起動している場合は、単に前面に出すだけのものです。
それ以上に、今のところ、オブジェクトを再取得する方法については、詳しく検証していませんが、

Else
'...
　　Set objWShell = Nothing　'←ここで終わった後に、
　　Set objITEM = oApp.CreateItem(1) '予定表作成画面を指定
　　objITEM.Display 'とすればよいはずです。
End If

なお、コマンドボタンなどに、マクロを登録してください。モジュールから直接行っても、Outlook の予定表は前面には出せません。

お礼

ここの文を

'予定表内容
　　objITEM.Subject = "見積り発行後のフォロー" '件名
　　objITEM.body = "見積り発行から3ヶ月経ちました" '本文
　　objITEM.Attachments.Add Flnm 'ファイルの添付
　　objITEM.Start = DateAdd("m", 3, Date) & " 8:30" '予定日と開始時間
　　objITEM.Save '保存
　　objITEM.Close 2 '閉じる

このようにすることで、

　Else
　　Set objWShell = CreateObject("WScript.Shell")
　　objWShell.AppActivate oApp.ActiveWindow.Caption 'アクティブ化
　　hwnd = FindWindow(FCLASSNAME, vbNullString)
　　SetForegroundWindow hwnd　'前面に持ってきて
　　objWShell.SendKeys "% X"　'最大化
　　Set objWShell = Nothing
　End If

'予定表内容
　　objITEM.Subject = "見積り発行後のフォロー" '件名
　　objITEM.body = "見積り発行から3ヶ月経ちました" '本文
　　objITEM.Attachments.Add Flnm 'ファイルの添付
　　objITEM.Start = DateAdd("m", 3, Date) & " 8:30" '予定日と開始時間
　　objITEM.Save '保存
　　objITEM.Close 2 '閉じる

すべて解決しました。
順番が違っていただけでした。

大変お騒がせしましたが、無事目的達成できました。
ありがとうございました。

補足

なんどもすみません。
やはり予定表を自動入力するというところがうまくいきません。
ただし、Outlookが起動していなければ、成功します。

既に起動中のものに予定を入れることが出来ません。

Outlookからデータを取得する例はたくさん検索されますが
その逆はとても少なく難儀します。

もしよろしければもう少しお付き合い下さい。

回答No.3

10CubeLeaf

Outlook は基本的に多重起動はしません。

Set oApp = CreateObject("Outlook.Application") '既に起動してても新規起動

とありますが、本来であれば上記の記述はすでに起動している場合はその Outlook を使用するという動作になります。
そうならないのだとすると、何らかの理由で Outlook が正常に終了できておらず、起動中の Outlook が使用できないので、新たに Outlook が起動されてしまうのだと考えられます。
たいていはアドインが問題ですので、アドインをアンインストールして試してみてください。

お礼

ありがとうございます。
アドインが問題になる場合があるのですね。

対策してみます。

回答No.2

Wendy02

>1.多重起動しないことと
>2.起動中で最小化されたOutlookがあるならアクティブ化して{?予定を入れる、または}
>3.起動していなかったら起動させて、予定を入れる

一部を除いて、3つの要件は満たしているはずです。予定を入れるというのは、すでに行っているのではないでしょうか。だから、最小化されたOutlook は、既に処理されていると解釈しています。

'//
Private Declare Function SetForegroundWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

Sub OutLookCheckers1()
　Dim oApp As Object 'Outlook.Application
　Dim myNameSpace As Object 'Outlook.Namespace
　Dim myFolder As Object 'MAPIFolder
　Dim objITEM As Object
　Dim objWShell As Object
　Dim Flnm As Variant
　Dim flg As Boolean

　Dim hwnd As Long
　Dim strClassName As String * 100
　Dim tmpClassName As String
　Const FCLASSNAME As String = "rctrl_renwnd32" 'クラス名
　'Outlook 起動
　On Error Resume Next
　Set oApp = GetObject(, "Outlook.Application") '既に起動している場合に取得
　If Err.Number <> 0 Then
　　Set oApp = CreateObject("Outlook.Application")
　　flg = True
　End If
　On Error GoTo 0
　If flg Then
　　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 '閉じる
　Else
　　Set objWShell = CreateObject("WScript.Shell")
　　objWShell.AppActivate oApp.ActiveWindow.Caption 'アクティブ化
　　hwnd = FindWindow(FCLASSNAME, vbNullString)
　　SetForegroundWindow hwnd　'前面に持ってきて
　　objWShell.SendKeys "% X"　'最大化
　　Set objWShell = Nothing
　End If

　Set oApp = Nothing
End Sub

お礼

大変参考になりました。
丸写しではなく、なるべく自分で記述できるように頑張ります！

補足

ありがとうございます。
Outlookが起動していない際には、予定表、下記部分は成功しました。
'　'予定表内容
　'　objITEM.Subject = "見積り発行後のフォロー" '件名
　'　objITEM.body = "見積り発行から3ヶ月経ちました" '本文
　'　objITEM.Attachments.Add Flnm 'ファイルの添付
　'　objITEM.Start = DateAdd("m", 3, Date) & " 8:30" '予定日と開始時間
　'　objITEM.Save '保存
　'　objITEM.Close 2 '閉じる
ただ、既にOutlookが起動していた場合は、予定が入らないまたは件名が「X」となってしまっています。
予定を差し込むのがうまくいかないみたいです・・・

回答No.1

kybo

多重起動するのは、OutLook自体を閉じないからです。

oApp.Quit

を、コードの最後の方に入れた方がいいです。

お礼

ありがとうございました。
無事解決しました！

補足

ありがとうございます。
ただ、oApp.Quitだともともと最小化していたOutlookまで終了してしまいます。

さらに検討してみます。