アウトルックでメール送信時に自動的に番号を付与したい

Question

アウトルックで、メール送信する際に、本文に例えば、「管理番号：YS06-100M」（送信毎に101、102とカウントしていく）を自動的に付与するVBAを作ることは出来るのでしょうか？
エクセルからメール送信する場合で本文に記載する方法は現在行っています。
方法をご存知の方教えてください。

KenKen_SP · Accepted Answer

こんにちは、KenKen_SP です。

とりあえず、Outlook VBA で書いてみました。

C ドライブに Sample という名のフォルダを作ってから、Outlook の VBE を
起動し、標準モジュールに下記のソースコードをコピペして下さい。

それから、マクロの実行で「CreateNewMessage」をクリックすれば、自動的に
管理番号が付与されたメールが新規作成されます。ボタンを作って、ツール
バーに登録しとけば便利ですかね...

なお、管理番号の書式は想像で作ってます。2007年になれば自動的に、

　YS07-001M 

となります。採番ファイル名は Number2006.dat（2007年なら Number2007.dat)
で拡張子 .dat にしましたけど、実態は単なるテキストファイルなので、メモ
帳で開けます。採番初期値を設定・編集したい場合は、メモ帳で。

ソースコードにコメントをそれなりに書き込んでおきましたので、適当にカス
タマイズして下さい。

> その情報が所定のエクセルシートに、管理番号と件名などの情報が書き込
> まれていけば効率的なのかなと考えてます。

Excel へのログ保存機能については省略しましたが、可能だと思います。
ご希望があれば、Outlook VBA の学習がてらコードを書いてみますが、結構
長いコードになると思います。


Option Explicit

' 採番ファイルを置くフォルダ（パスの最後に￥は不要）
Private Const SYS_DIRPATH = "C:\Sample"

' 管理番号付きメールの新規作成サンプル
Sub CreateNewMessage()
　　
　　Dim App　　　 As Application
　　Dim myItem　　As MailItem
　　Dim strNumber As String
　　Dim strBody　 As String
　　
　　' 新規管理番号取得（キャンセル・エラー時は終了させる）
　　strNumber = GetNewStrNumber()
　　Select Case strNumber
　　　　Case "CANCEL": Exit Sub
　　　　Case "ERROR":　Exit Sub
　　　　Case Else
　　End Select
　　' メール本文の準備
　　strBody = "管理番号：" & strNumber & vbCrLf & vbCrLf
　　' 定型句などがある場合、ここで設定しておきます(改行は vbCrLf)
　　strBody = strBody & "平素は格別なるご高配を賜り....とか." & vbCrLf & vbCrLf
　　strBody = strBody & "-----------------------------------" & vbCrLf
　　strBody = strBody & "署名とか" & vbCrLf
　　strBody = strBody & "-----------------------------------" & vbCrLf
　　' 新規メール作成
　　Set App = CreateObject("Outlook.Application")
　　Set myItem = App.CreateItem(olMailItem)
　　With myItem
　　　　' 先に設定した本文を配置して表示
　　　　.Body = strBody
　　　　.Subject = "件名をセットするならココ" ' 不要なら削除
　　　　.To = "宛先メールアドレスはココ"　　　' 不要なら削除
　　　　.Display
　　End With
　　Set myItem = Nothing
　　Set App = Nothing

End Sub

' 採番ファイルを読み込んで新規管理番号を発行する
Private Function GetNewStrNumber() As String
　　
　　' 戻り値 String
　　' 通常　　　　：書式化された新規管理番号
　　' キャンセル時："CANCEL"
　　' エラー発生時："ERROR"
　
　　Dim n　　　　　 As Integer
　　Dim strFilename As String
　　Dim strBuffer　 As String
　　Dim intRes　　　As Integer
　　Dim lngNumber　 As Long
　　Dim strNumber　 As String
　　
　　' 現在日時から読み込む採番ファイルを取得する
　　' 採番ファイル名仕様 Number＋西暦４桁.dat
　　strFilename = SYS_DIRPATH & "\Number" & Format$(Now(), "yyyy") & ".dat"
　　' 採番ファイルを排他オープンしてデータを読み込む
　　On Error GoTo ERROR_HANDLER
　　n = FreeFile()
　　Open strFilename For Binary Lock Read Write As #n
　　On Error GoTo 0
　　strBuffer = String$(LOF(n) + 1, vbNullChar)
　　Get #n, , strBuffer
　　strBuffer = Replace(strBuffer, vbNullChar, "")
　　' 初回なら 1 、既存データがあれば＋1した数が新規管理番号
　　If Len(strBuffer) = 0 Then
　　　　lngNumber = 1
　　Else
　　　　lngNumber = CLng(Val(strBuffer)) + 1
　　End If
　　' ※ 管理番号書式化（書式： YSyy-000M --> yyは西暦年下2桁）-------------
　　strNumber = "YS" & Format$(Now(), "yy-") & Format$(lngNumber, "000") & "M"
　　' ----------------------------------------------------------------------
　　' 発行確認
　　intRes = MsgBox("管理番号[ " & strNumber & " ]を発行しますか？", _
　　　　　　　　　　vbOKCancel + vbInformation + vbDefaultButton2, _
　　　　　　　　　　"新規メール作成確認")
　　If intRes = vbOK Then
　　　　' 採番ファイルに記録
　　　　Put #n, 1, CStr(lngNumber)
　　　　GetNewStrNumber = strNumber
　　Else
　　　　GetNewStrNumber = "CANCEL"
　　End If
　　Close #n
　　Exit Function
　　
ERROR_HANDLER:
　　Close #n
　　GetNewStrNumber = "ERROR"
　　Select Case Err.Number
　　　　Case 70:
　　　　　 MsgBox "採番ファイルは現在使用中のため開けません．", vbCritical
　　　　Case 76:　 
　　　　　 MsgBox "採番ファイルのパス設定が無効です．", vbCritical
　　　　Case Else:
　　　　　 MsgBox Err.Description, vbExclamation
　　End Select
　　
End Function

KenKen_SP · Answer

ThisOutlookSession の ItemSend イベントだとセキュリティー警告がでて
しまい、その警告ウインドウでアクセスを許可するを手動でクリックしない
とダメでした....これはどうしようもないですね。

　　内容：プログラムがメール、またはアドレス帳にアクセスしようと
　　　　　している。アクセスを許可しますか？

やはり、メール送信部のマクロを書いて、送信時にユーザーに実行してもら
う形式にしないと無理そうです。

KenKen_SP · Answer

すみません。Outlook VBA はほとんど使ったことが無いのと、時間がとれ
なくてコード作成の進行が遅れてます。が、私もスキルアップのチャンス
なので、コードは現在も作成中です。

ただ、丸投げ的なコード作成依頼になってしまうのでは嫌なので、一緒に
アイディアを考えて頂けるとうれしいですし、コードのテスト結果を教え
て頂けると助かります。

宜しければお付き合い頂きたいと思いますが、masakazu113 さんにもご都合
がありますよね。当初ご質問の点については、実現できたと思いますので、
下記の内容が不要であれば、このスレッドはいつでも締め切って下さい。


> 番号管理.xlsというファイルがあって...

それなら、CSV ファイルの方が良いと思います。汎用性があるし、Excel の
ような 65536行までという制限がありません。

> 同時にするなら、メール送信する時もマクロを使わなければ...

ThisOutlookSession の ItemSend イベントで送信メールに特定の識別子が
含まれていたらログを取る...

この仕組みなら、メール送信時に別のマクロをユーザーが実行する必要は
ないと思います。引数 Item から宛先・件名・本文や送信者などの情報が
取得できますのでログへの記載は自動化できます。

今苦労しているのは、

　・通常のメールと「管理番号付きメール」をどのように識別するか

です。一行目に管理番号があるかないかで判定するしかないかな...と思い
ますが、何か良いアイディアはありますか？

それから、どうせログを取るなら、

Number　　　　　管理番号
SendDateTime　　メール送信日時
To_Address　　　宛先メールアドレス
Subject 　　　　件名
CreateDateTime　メール作成日
Creater 　　　　作成者
IsSend　　　　　True 送信済み/ False 送信を保留中

といった内容まで取ってみてはどうですか？

KenKen_SP · Answer

こんにちは。KenKen_SP です。

> エクセルからも出来そうですが、OUTLOOKから実行できるか考えています。

もちろん OUTLOOK VBA からでも可能ですよ。また夜にでも簡単なサンプル
をアップしてみます。

KenKen_SP · Answer

こんにちは。

Excel VBA で Outlook を使ってメール送信してるのですよね？
この記事が参考になると思います。

Excelでお仕事！[テキストデータやファイル操作]
　・バイナリモードでの読み書き (自動発番管理サンプル)
　http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_070.html

既存の Excel VBA のメール送信部をカスタマイズして、Access で運用
するという手もあります。その場合は、オートナンバーのフィールド
(仮に ID）を用意しておき、

　　strBody = strBody & "本文"
　　strBody = strBody & "管理番号：YS06-"
　　strBody = strBody & Format$(RS![ID],"000") & "M"

の内容を Outlook で送信するとか。逆に面倒かな...

アウトルックでメール送信時に自動的に番号を付与したい

こんにちは、KenKen_SP です。

この回答への補足

ThisOutlookSession の ItemSend イベントだとセキュリティー警告がでて

この回答への補足

すみません。

こんにちは。

こんにちは。

この回答への補足

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング