Outlook を最小化して起動する方法

コメントにて以下のご要望をいただきました。


いつもお世話になっております。
VBSでの外部コマンド実行する際のRunメソッドに関して
分からない動作があり、質問をさせていただきます。
元々、Outlookの実行を最小化して表示したいと考え、調べたところ
Runメソッドの実行オプションから実行した際のウィンドウのオプションが
指定できるとのことで指定を行ったのですが最小化、最大化、非表示など
何を指定しても、展開されるウィンドウに変化が無くネット上サンプルを動かしてみたところ
全く同じ処理で実行した際にメモ帳(“notepad”)の時には指定通りウィンドウが
最大化して開かれるにもかかわらず、電卓(“calc”)など他アプリケーションでは
エラーも出ていないが指定の実行ウィンドウオプションが全く反映されない現象が発生しました。
同現象について調べてみましたが有用なものが無く、手詰まり困っております。
分かる方がもしおられましたら、ご教授願えると幸いです。
実行環境は
Windows10 Pro 64bitにです。

以下スクリプトになります。
Dim oWshShell
Set oWshShell = CreateObject(“WScript.Shell”)
‘// メモ帳実行、最大化指定(3)→最大化され開かれた
oWshShell.Run “notepad”, 3, True
WScript.Echo “Bye!”

Set oWshShell = CreateObject(“WScript.Shell”)
‘// 電卓実行、最大化指定(3)→最大化されない、念のため非表示(0)でも試したが反映されない
oWshShell.Run “calc”, 3, True
WScript.Echo “Bye!”


私の手元で試す限り、Outlook については以下のような動作となりました。

第 2 パラメータで指定する値 Outlook のウィンドウの動作
2 通常のウィンドウで開く
6 通常のウィンドウで開く
7 最小化で開く

したがって、Run メソッドの第 2 パラメータに 7 を指定すれば Outlook を最小化して開くことができるはずです。
Calc のようなストア アプリなどでは、通常の Windows アプリケーションとウィンドウの操作方法が異なるため、Run メソッドの第2パラメータが有効にならないのではないかと考えられます。

なお、Outlook のオブジェクト モデルにもウィンドウの状態を設定するプロパティ (Explorer オブジェクトの WindowState) があるため、これを設定して起動すれば起動後にウィンドウを最小化することもできます。(ただし、起動直後にいったんウィンドウが表示されます。)
Outlook を起動してウィンドウを最小化するスクリプトは以下のようになります。    

' ここをトリプルクリックでスクリプト全体を選択できます。
Const olFolderInbox = 6
Const olMinimized = 1
Dim olkApp
Dim fldInbox
Dim expInbox
Set olkApp = CreateObject("Outlook.Application")
If olkApp.Explorers.Count = 0 Then
     Set fldInbox = olkApp.Session.GetDefaultFolder(olFolderInbox)
     fldInbox.Display
     Set expInbox = fldInbox.GetExplorer()
     expInbox.WindowState = olMinimized
End If

広告

連絡先のすべてのサブフォルダーをアドレス帳に表示するスクリプト

コメントにて以下のご要望をいただきました。


いつも参考にさせていただいております。
連絡先のサブフォルダに「電子メールのアドレス帳にこのフォルダーを表示する」のチェックボックスにチェックを利用者が入れなくても良いように、スクリプトでチェックを入れさせたいと考えています。
レジストリ操作かとは思いますが、良きお知恵がありましたら、ご教示いただけますと嬉しく思います。


[電子メールのアドレス帳にこのフォルダーを表示する] の設定をオンにするには、Outlook の Folder オブジェクトの ShowAsOutlookAB プロパティを True にします。
ただ、Exchange サーバー環境などでは連絡先のサブ フォルダーに Outlook や Exchange が使用する隠しフォルダーが生成される場合があり、これらをアドレス帳に表示するとユーザーが混乱することになります。
そのため、隠しフォルダーである場合に True となる PidTagAttributeHidden プロパティで隠しフォルダーかどうかを判断し、隠しフォルダーでない場合だけ ShowAsOutlookAB を True とします。
スクリプトは以下の通りです。

' ここをトリプルクリックでスクリプト全体を選択できます。
Const olFolderContacts = 10
Dim olkApp 'As Outlook.Application
Dim fldContacts 'As Folder
'
Set olkApp = CreateObject("Outlook.Application")
Set fldContacts = olkApp.Session.GetDefaultFolder(olFolderContacts)
MakeContactsVisible(fldContacts)
'
Private Sub MakeContactsVisible(fldContacts)
     Const PidTagAttributeHidden = "http://schemas.microsoft.com/mapi/proptag/0x10F4000B"
     Dim fldSub 'As Folder
     '
     WScript.Echo fldContacts.FolderPath
     If fldContacts.PropertyAccessor.GetProperty(PidTagAttributeHidden) = False Then
         fldContacts.ShowAsOutlookAB = True
     End If
     '
     For Each fldSub In fldContacts.Folders
         MakeContactsVisible fldSub
     Next
End Sub

受信したメールの埋め込み画像を除いた添付ファイルを自動保存するマクロ

受信したメールの添付ファイルを自動保存するマクロのコメントにて以下のご要望をいただきました。


お世話になっております。

添付ファイルを自動保存するマクロを利用させていただいています。

メールに保存したいExcelファイルと同時に、図が貼り付けてある場合(Excelのシートをコピーして図として貼り付け)、下記の部分でエラーとなります。

  strFileName = SAVE_PATH & objAttach.FileName

図は無視して、Excelファイルのみ自動保存するマクロにする変更をご教示ください。

なお、保存したいファイル名には ”PDD****”という特定の文字列が入っています。


添付ファイルが埋め込み画像のファイルかどうかを判断するには、添付ファイルが埋め込み画像かどうかを判断する方法で紹介したマクロ関数により可能です。
この関数を使用して埋め込み画像以外の添付ファイルを保存するマクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

' メール受信時に発生するイベント
Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim i As Integer
     Dim c As Integer
     Dim colID As Variant
     '
     SaveAttachments EntryIDCollection
End Sub
'
' 添付ファイルの保存を行うサブ プロシージャ
Private Sub SaveAttachments(ByVal strEntryID As String)
     Const SAVE_PATH = "C:\attachments\"
     Dim objFSO As Object ' FileSystemObject
     Dim objMsg As Object
     Dim objAttach As Attachment
     Dim strFileName As String
     Dim c As Integer: c = 1
   
     Set objFSO = CreateObject("Scripting.FileSystemObject")
     Set objMsg = Application.Session.GetItemFromID(strEntryID)
'
' ここで条件指定
'
     For Each objAttach In objMsg.Attachments
         If Not IsAttachEmbedded(objAttach) Then
             With objAttach
              
                 strFileName = SAVE_PATH & objAttach.FileName
               
                 While objFSO.FileExists(strFileName)
                     strFileName = SAVE_PATH & Left(.FileName, InStrRev(.FileName, ".") - 1) _
                         & "-" & c & Mid(.FileName, InStrRev(.FileName, "."))
                     c = c + 1
                 Wend
               
                 .SaveAsFile strFileName
             End With
         End If
     Next
     Set objMsg = Nothing
     Set objFSO = Nothing
End Sub
'
' 添付ファイルが埋め込み画像かどうかをチェックする関数
Private Function IsAttachEmbedded(objAttach As Attachment)
      Const PR_ATTACH_FLAGS = "http://schemas.microsoft.com/mapi/proptag/0x37140003"
      Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
      Dim iAttFlags As Integer
      Dim strAttCID As String
      ' 既定は通常の添付ファイル
      IsAttachEmbedded = False
      ' フラグが 0 以外なら埋め込み画像
      iAttFlags = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_FLAGS)
      If iAttFlags <> 0 Then
          IsAttachEmbedded = True
      End If
      ' Content ID があれば埋め込み画像
      strAttCID = objAttach.PropertyAccessor.GetProperty(PR_ATTACH_CONTENT_ID)
      If strAttCID <> "" Then
          IsAttachEmbedded = True
      End If
      ' OLE オブジェクトなら埋め込み画像
      If objAttach.Type = olOLE Then
          IsAttachEmbedded = True
      End If
End Function

マクロの登録方法やメニューへの追加について

Outlook 2010 以降で返信や転送の際の自動折り返しを行わずにインデント記号を挿入するマクロ

返信や転送の際の自動折り返しをなくす方法のコメントにて以下のご要望をいただきました。


Outlook2016でも利用可能でしょうか。
上に記載のあるOutlook2010での新しいバージョンの記述とはどちらになるのかわからないのでお手数ですがお教え願えませんでしょうか。
なお、「HKEY_CURRENT_USER\Software\Microsoft\Office\11.0\Outlook\Options\Mail 」の11.0を16.0で行ったのですが自動改行される設定のままでした。


Outlook 2007 まではレジストリ設定でインデント記号を挿入する際の折り返しの制御ができました。
しかし、Outlook 2010 以降では、このレジストリ設定が機能しません。
そのため、折り返しを行わずにインデント記号を挿入するマクロを作成しました。

Outlook 自体の返信や転送の設定では [元のメッセージを残す] にしておき、返信の際には ReplyWithTickMark、転送の時は ForwardWithTickMark を呼び出すことで、折り返しせずにインデント記号を挿入できます。
マクロは以下の通りです。

' ここをトリプルクリックでマクロ全体を選択できます。

'
'   インデント記号を付けて返信するマクロ
Public Sub ReplyWithTickMark()
     Dim objMail As MailItem
     Dim objReply As MailItem
     ' アイテムを取得
     Set objMail = GetCurrentItem()
     ' 返信を作成
     Set objReply = objMail.ReplyAll
     ' インデント記号を本文に追加
     AddTickMark objReply
End Sub
'
'   インデント記号を付けて転送するマクロ
Public Sub ForwardWithTickMark()
     Dim objMail As MailItem
     Dim objForward As MailItem
     ' アイテムを取得
     Set objMail = GetCurrentItem()
     ' 転送を作成
     Set objForward = objMail.Forward
     ' インデント記号を本文に追加
     AddTickMark objForward
End Sub
'
'   アクティブなウィンドウに応じて選択しているアイテムを取得するマクロ
Private Function GetCurrentItem()
     If TypeName(ActiveWindow) = "Inspector" Then
         Set GetCurrentItem = ActiveInspector.CurrentItem
     Else
         Set GetCurrentItem = ActiveExplorer.Selection(1)
     End If
End Function
'
'   インデント記号を追加するマクロ
Private Sub AddTickMark(objMail As MailItem)
     ' インデント記号の指定
     Const TICK_MARK = "> "
     '
     Dim iStart As Integer
     Dim strNewBody As String
     ' 引用部分の先頭を取得
     iStart = InStr(objMail.Body, "-----Original Message-----")
     ' 引用部分が存在する場合
     If iStart > 3 Then
         ' 引用部分より前はそのままコピー
         strNewBody = Left(objMail.Body, iStart - 2)
         ' 引用部分は改行の後にインデント記号を追加
         strNewBody = strNewBody & Replace(objMail.Body, vbCrLf, vbCrLf & TICK_MARK, iStart - 2)
         ' インデント記号を追加した本文を設定
         objMail.Body = strNewBody
     End If
     ' アイテムを表示
     objMail.Display
End Sub

マクロの登録方法やメニューへの追加について

特定のフォーマットのメールを受信したら、件名と本文をそのまま転送するマクロ

コメントにて以下のご要望をいただきました。


コメント

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

不躾ではございますが、案件対応上取り決められているメールを出したいのですが
送信タイミングが不定、且つ送信に使うPCは遠隔接続NGとの環境的条件がある為
とても困っております。

OutlookでのVBAはまだまだ経験値が足りず、以下の需要にご助言等頂きたく相談申し上げます。

▼参考として拝見中のコンテンツ
 転送時に差出人のアドレスを置き換えるマクロ https://outlooklab.wordpress.com/2014/01/11/%E8%BB%A2%E9%80%81%E6%99%82%E3%81%AB%E5%B7%AE%E5%87%BA%E4%BA%BA%E3%81%AE%E3%82%A2%E3%83%89%E3%83%AC%E3%82%B9%E3%82%92%E7%BD%AE%E3%81%8D%E6%8F%9B%E3%81%88%E3%82%8B%E3%83%9E%E3%82%AF%E3%83%AD/

 本文に特定の文面を含む場合に、そのメールとファイルを添付して転送するマクロ
https://outlooklab.wordpress.com/2012/01/21/%e6%9c%ac%e6%96%87%e3%81%ab%e7%89%b9%e5%ae%9a%e3%81%ae%e6%96%87%e9%9d%a2%e3%82%92%e5%90%ab%e3%82%80%e5%a0%b4%e5%90%88%e3%81%ab%e3%80%81%e3%81%9d%e3%81%ae%e3%83%a1%e3%83%bc%e3%83%ab%e3%81%a8%e3%83%95/

▼需要について
 ・最終的に実行したいこと
  - 社内デスクトップPC(社外からの遠隔操作NG)から、特定のメール3通を出させたい

  - 3通は案件で「関係者宛に送る」と取り決められているメール
    ※3通ともほぼ定型。送信先(TO、CC)は固定の面子。
    <対応開始時刻前時点>
      ①「当該案件の対応開始」告知
       ※件名は「yyyymmdd 固有文字列」。
       ※本文は、差出人苗字と責任者苗字以外定型。

    <作業完了後>
      ②対応内容の報告PDF添付メール ※報告PDF=要対応事項なしの際も必ず記載・添付。
       ※件名は「yyyymmdd 固有文字列」。
       ※本文は、差出人苗字以降は不定。報告書掲載内容のポイントに触れた文面2~3行等。

      ③(報告PDF添付メール送付も含めた) その日の「当該案件対応完了」告知
       ※件名は「yyyymmdd 固有文字列」。
       ※本文は、差出人苗字と責任者苗字以外定型。

 ・実現させたい使い方
  - 社外持ち出しPC(社内デスクトップPCや社内ネットワークへの遠隔接続NG)から
    社内デスクトップPCへメールを送る
    ※社内デスクトップPCとは別ドメインのメール
    ※社内デスクトップPCは完全に、社内ネットワーク専用。
     ただしメールやネット等の一般的な利用は可の為、外からメールを受けることはOK。

  - 受信したメールの件名ルールが合致するかを確認

  - 合致すれば、固定面子の送信先(TO、CC)を持つ新規メールに本文を転記

  - 添付があればそれも添付へ転用

▼得られる結果
 ・終了が大抵夜間~深夜に及ぶ為、現場から直帰が出来る為1~2時間早い帰宅が可能に。

こちらの都合に起因した相談の為誠に恐縮なのですが、運用のやりくり上でも手詰まりとなり
簡単に「こんな働きをするスクリプトたちを、上からこういう順に配置すれば良いのでは」等
構成配置などだけでも、ご助言を賜れれば幸いです。


ご要望のイメージとしては、外部の UserX から社内の UserA に特定フォーマットの件名のメールを送信すると、UserA の端末で実行されている Outlook からそのメールを送信したかのように転送するという処理でしょうか?
まず、「yyyymmdd 固有文字列」という件名かどうかの判断については、VBA の LIKE 演算子で “######## 固有文字列” という条件を指定します。
LIKE 演算子では “#” が 1 桁の数字に合致するという意味になるため、”########” で 8 桁の数字に合致するかどうかを確認できます。
送信するメールの作成については新規メールではなく、MailIItem オブジェクトの Forward メソッドにより転送メールを作成し、件名と本文を元のメールのものに置き換えることで、添付ファイルなども維持できます。
マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
     Dim objItem As Variant
     Set objItem = Session.GetItemFromID(EntryIDCollection)
     If objItem.MessageClass = "IPM.Note" Then
         ForwardBySubject objItem
     End If
End Sub
'
'
Public Sub ForwardBySubject(ByVal objMail As MailItem)
     ' メールの宛先を指定
     Const TO_ADDRESS = "To User <to@example.com>"
     ' メールの CC を指定
     Const CC_ADDRESS = "Cc User <cc@example.com>"
     ' 処理すべきメールの差出人アドレスを指定
     Const SENDER_ADDRESS = "from@example.com"
     '
     Dim arrKeywords
     Dim strKeyword
     Dim objForward As MailItem
     '
     arrKeywords = Array("固有文字列1", "固有文字列2", "固有文字列3")
     '
     For Each strKeyword In arrKeywords
         ' 先頭の 8 文字が数字でスペースを入れて固有文字列が続く件名
         ' かつ特定の差出人からのメールのみ
         If objMail.Subject Like "######## " & strKeyword And _
            objMail.SenderEmailAddress = SENDER_ADDRESS Then
             ' メールの転送
             Set objForward = objMail.Forward
             objForward.To = TO_ADDRESS
             objForward.CC = CC_ADDRESS
             ' 転送メールの件名と本文は元のままを維持
             objForward.Subject = objMail.Subject
             If objForward.BodyFormat = olFormatPlain Then
                 objForward.Body = objMail.Body
             Else
                 objForward.HTMLBody = objMail.HTMLBody
             End If
             objForward.Send
         End If
     Next
End Sub

マクロの登録方法やメニューへの追加について

Excel のデータを Outlook の本文に表としてコピーするマクロ

コメントにて以下のご要望をいただきました。


Office2016を利用しています。ExcelのVBAでOutlookメールを送信しようとしています。
リッチテキスト型の本文に、「表を挿入」する方法が分からず困っています。また、挿入した表の任意のセルに文字を代入する手順も知りたいです。(Excelシートの貼り付けではありません。)
よろしくお願いします。


Outlook のメールの本文に表を挿入するには、Inspector オブジェクトの WordEditor プロパティにより取得できる、Word の Document オブジェクトを使用します。
これにより、Word のマクロで文書を編集する場合と同様に Outlook の本文の編集ができます。
本文に表を挿入する場合、Document オブジェクトの Tables プロパティの Add メソッドを使用します。
Add メソッドで返される Table オブジェクトを使って表のスタイルなどを設定し、Cell プロパティで表のセルの値を変更します。
表のスタイルやセルの書式設定の方法などについては Word のマクロのサンプルなどを参考にしてください。

以下のマクロでは、COL_START や ROW_START  などで指定した範囲の Excel の表のデータを本文に挿入した表にコピーします。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub CopyTableToMail()
     ' 転記する Excel ファイルの列の開始位置
     Const COL_START = 1
     ' 転記する Excel ファイルの列の数
     Const NUM_COLS = 5
     ' 転記する Excel ファイルの行の開始位置
     Const ROW_START = 1
     ' 転記する Excel ファイルの行の数
     Const NUM_ROWS = 10
     ' Outlook の定数
     Const olMailItem = 0
     Const olFormatRichText = 3
     '
     Dim appOlk As Object ' Outlook.Application
     Dim objItem As Object ' Outlook.MailItem
     Dim wrdEditor As Object ' Word.Document
     Dim wrdTable As Object ' Word.Table
     Dim wrdRange As Object ' Word.Range
     Dim iCol As Integer
     Dim iRow As Integer
     ' Outlook の Application オブジェクトを取得
     Set appOlk = CreateObject("Outlook.Application")
     ' 新規アイテムを作成
     Set objItem = appOlk.CreateItem(olMailItem)
     '
     objItem.BodyFormat = olFormatRichText
     ' 新規アイテムの WordEditor オブジェクトを取得
     Set wrdEditor = objItem.GetInspector().WordEditor
     ' WordEditor にフォーカス設定
     wrdEditor.Activate
     ' 表の挿入位置を取得
     Set wrdRange = wrdEditor.Application.Selection.Range
     ' 本文に表を挿入
     Set wrdTable = wrdEditor.Tables.Add(wrdRange, NUM_ROWS, NUM_COLS)
     '
     With wrdTable
         ' 表のスタイルを指定
         .Style = "表 (格子)"
         ' 表の [タイトル行] をオン
         .ApplyStyleHeadingRows = True
         ' 表の [集計行] をオン
         .ApplyStyleLastRow = False
         ' 表の [最初の列] をオン
         .ApplyStyleFirstColumn = True
         ' 表の [最後の列] をオン
         .ApplyStyleLastColumn = False
         ' 表の [縞模様 (行)] をオン
         .ApplyStyleRowBands = True
         ' 表の [縞模様 (列)] をオフ
         .ApplyStyleColumnBands = False
         ' Excel の表のデータを本文のテーブルに転記
         For iCol = 1 To NUM_COLS
             For iRow = 1 To NUM_ROWS
                 ' .Cell は本文の表のセル
                 ' Cells は Excel の表のセル
                 .Cell(iRow, iCol).Range.Text = _
                     Cells(ROW_START + iRow - 1, COL_START + iCol - 1).Value
             Next
         Next
     End With
     ' 表を挿入したアイテムを表示
     objItem.Display
End Sub

マクロの登録方法やメニューへの追加について

連絡先のデータを一括で書き換えるマクロ

コメントにて以下のご要望をいただきました。


お世話になります。
  個人用の連絡先に既にある連絡先の内容をマクロの実行で一括変更するマクロを作成したいと考えております。
お力添えをいただけると助かります。

◆環境
Win10、Outlook2016

◆実施したいこと
選択した既にある連絡先をマクロの実行で一括変更したい
(例として架空の設定を使用しますが書式は全て同じです)

==変更前==
姓:YAMADA
名:TARO
勤務先:○○社
部署:Engineering Div. (エンジニア部 第三係)
役職:Team Leader (班長)
表題:YAMADA, TARO
電子メール:taro.yamada@example
表示名:Taro Yamada (山田 太郎) (taro.yamada@example)
国:Japan
その他:空白

==変更後==
姓:山田
名:太郎
フリガナ姓:YAMADA
フリガナ名:TARO
勤務先:○○社
部署:エンジニア部 第三係
役職:班長
表題:山田, 太郎
電子メール:taro.yamada@example
表示名:山田 太郎
国:Japan
その他:空白

上記のように英語部を省くようにするのと、名前を表示名の漢字から参照したいです。
  (フリガナはあってもなくてもどちらでも構いません)

何卒、よろしくお願い致します。


電子メールの表示名は ContactItem オブジェクトの Email1DisplayName プロパティになります。
取得した表示名の括弧内の文字列を取得するには、InStr 関数で ( と ) の位置を検索し、その間の文字列を Mid 関数で取得します。
括弧内の文字列取得は部署や役職の設定でも使用するので関数化しました。
後は取得した文字列を ContactItem オブジェクトの以下のそれぞれのプロパティに設定していきます。

姓: LastName
名: FirstName
フリガナ姓: YomiLastName
フリガナ名: YomiFirstName
部署: Department
役職: JobTitle
表題: FileAs

マクロは以下のようになります。

' ここをトリプルクリックでマクロ全体を選択できます。

Public Sub ReplaceNamesInContacts()
     Dim fldContacts As Folder
     Dim colContacts As Items
     Dim i As Integer
     Dim contItem As ContactItem
     Dim strFullName As String
     Dim arrName As Variant
     Dim strDept As String
     Dim strTitle As String
     ' 既定の連絡先フォルダーを取得
     Set fldContacts = Session.GetDefaultFolder(olFolderContacts)
     ' 連絡先アイテムのみを取得
     Set colContacts = fldContacts.Items.Restrict("[MessageClass] = 'IPM.Contact'")
     ' すべての連絡先について処理
     For Each contItem In colContacts
         With contItem
             ' 表示名から括弧内の文字列を取得
             strFullName = GetTextInParenthesis(.Email1DisplayName)
             If InStr(strFullName, " ") > 0 Then
                 ' 表示名を空白で分割
                 arrName = Split(strFullName, " ")
                 ' 英語の名前をフリガナに移動
                 .YomiFirstName = .FirstName
                 .YomiLastName = .LastName
                 ' 漢字の名前を設定
                 .FirstName = arrName(1)
                 .LastName = arrName(0)
                 .Email1DisplayName = strFullName
                 .FileAs = .LastName & ", " & .FirstName
             End If
             ' 部署名からカッコ内の文字列を取得
             strDept = GetTextInParenthesis(.Department)
             If strDept <> "" Then
                 .Department = strDept
             End If
             ' 役職からカッコ内の文字列を取得
             strTitle = GetTextInParenthesis(.JobTitle)
             If strTitle <> "" Then
                 .JobTitle = strTitle
             End If
             ' 変更後のアイテムを保存
             .Save
         End With
     Next
End Sub
' () 内の文字列を取り出す関数
Private Function GetTextInParenthesis(strText As String)
     Dim s As Long
     Dim e As Long
     s = InStr(strText, "(")
     e = InStr(strText, ")")
     If s > 0 And e > s Then
         GetTextInParenthesis = Mid(strText, s + 1, e - s - 1)
     Else
         GetTextInParenthesis = ""
     End If
End Function

マクロの登録方法やメニューへの追加について