msoffice

HOME
office
msoffice
AccessとOutlookの便利な連携術

2020年7月8日 / 最終更新日時 : 2025年1月1日 officeの杜 msoffice

AccessとOutlookの便利な連携術

脱メールとは言え、企業の情シスが規制しているが為に業務改善を行いたくても、各種REST APIが利用できなくされていたり、また外部のウェブサービスを利用させてもらえず、そこで停滞したまま効率化されずにいる日本企業は非常に多いです。

しかし、メールは原始的なコミュニケーション手段であり、埋もれる、取りこぼす、調べるのに莫大な時間を要する、また個人宛なので過去の経緯などが次の人に引き継がれず、また活用するにしてもノイズが多く使いづらいです。そこでAccessと連携させる事で、必要なメール情報だけを取り込んで、データ化する事で、利便性が向上します。

1 今回使用するファイル類
2 リンクテーブルを利用する
- 2.1 手動でリンクテーブルにて接続
- 2.2 VBAで動的にリンクテーブルを作る
3 VBAからOutlookを操作する
4 関連リンク

今回使用するファイル類

Outlook連携Accessファイル

リンクテーブルを利用する

手動でリンクテーブルにて接続

あまり知られていない機能ですが、Accessは標準でOutlookの受信トレイなどにリンクテーブルを簡単に貼る事が可能です。受信トレイ以外にもリンクテーブルを貼る事はもちろん可能。共有メールボックスや連絡先などにも接続できたりするので、色々と応用が利くと思います。接続手順は以下の通り。

Accessメニューの外部データを開き、新しいデータソース⇒他のソースから⇒Outlookフォルダを選択
ダイアログが出るので、「リンクテーブルを作成してソースデータにリンクする」にチェックをいれて、次へ進む
どのフォルダにリンクするか？を選んで、次へをクリック。今回は受信トレイを選択。
リンクするテーブル名を設定して完了をクリックするとリンクテーブルとしてOutlookのフォルダが表示される
あとは、普通のテーブルと同様に中に表示されたデータを取り出しす事が可能。ただし、追加することはできません。

リンクしたテーブルを見てみるとかなり細かくデータが入ってることがわかります。いくつか気になる点としては

Microsoft365のExchange Serverを利用してる場合、メールアドレスがなく特殊な形式になってる（外部の人の場合はメールアドレスはしっかり入ってる）
本来あるはずの各メールのユニークなID（EntryIDやMessageID）などは無い。よって、そのメールに返信したかどうかの判定はメールタイトルなどから判断しなければならない（ぶら下がり先がわからない為）
本人宛やCC、TOなどはわかるが、BCCについては表示がない
添付ファイルなどはその有無はフラグでわかるが、データとしてはテーブルから取ることは出来ない
共有メールボックスの一部はリンクできないケースもある
メールボックスのメール数が多いとリンクテーブルの場合非常に動作が遅くなる。

図：受信トレイと直接接続してみた

図：Teamsの会話やタスクなども接続可能みたい

VBAで動的にリンクテーブルを作る

プログラムとして配布し利用してもらうにあたっては、上記の手動でリンクテーブル貼ってもらうというのは正直ちょっとスマートな方法ではありません。しかし、リンクテーブルは人によってリンク先のパスが異なる（Outlookの場合、C:Usersユーザ名AppDataLocalTempが接続先なので、ここがネックになる）

そこでVBAにて自動でワンクリックでリンクテーブルを貼れるようにしておくと良いでしょう。ODBCリンクテーブルと同じような要領で貼る事が可能です。

'Outlookの受信トレイと自動で接続する
Public Function getInboxFolder()
    'ログインユーザ名を取得する
    Dim WshNetworkObject As Object
    Set WshNetworkObject = CreateObject("WScript.Network")
    Dim userid As String
    userid = WshNetworkObject.username
    
    '接続先メールアカウント
    '共有メールボックスの場合はメールアドレスではなくアカウント名を利用する
    Dim mailman As String
    Set OL = CreateObject("Outlook.Application")
    Dim olNS As Outlook.NameSpace
    Dim olFol As Outlook.Folder
    
    Set olNS = OL.GetNamespace("MAPI")
    Set olFol = olNS.GetDefaultFolder(olFolderInbox)
    mailman = olNS.Accounts.Item(1).SmtpAddress 'デフォルトのメールアカウントを今回は使用

    'リンクテーブル用変数
    Dim db As DAO.Database
    Dim td As DAO.TableDef
    Set db = CurrentDb
    Set td = db.CreateTableDef("tblInbox")
    
    '接続文字列
    Dim inboxman As String
    inboxman = "Outlook 9.0;MAPILEVEL=" & mailman & "|;PROFILE=Outlook;TABLETYPE=0;TABLENAME=Inbox;COLSETVERSION=12.0;DATABASE=C:Users" & userid & "AppDataLocalTemp"

    '接続する
    td.Connect = inboxman
    td.SourceTableName = "受信トレイ"
    db.TableDefs.Append td
    Application.RefreshDatabaseWindow
    
    '終了処理
    db.Close
    Set db = Nothing
    Set td = Nothing
    Set WshNetworkObject = Nothing
    
End Function

本コードを使うには、参照設定にてMicrosoft Outlook 1x.0 Object Libraryを加えておく必要があります。
WScriptを利用してログインユーザ名を取得させています。
今回はtblInboxという名前でリンクテーブルを作成しています。
接続文字列がODBCとは違いちょっと特殊です。この時、ログインユーザ名を利用してパスを組み立て、また予めどのアカウントなのか区別するため、mailmanにメールアドレスを入れておく必要があります。
今回は受信トレイが対象なので、td.SouceTableNameには受信トレイを入れておきます。
デフォルトのその人のアカウント名を今回は自動で取得。olNS.Accounts.Item(1).SmtpAddressで実現していますが、複数アカウントがある場合にはItemの引数の番号を変更すれば良い。またはFor Eachで回して取得するのも良いでしょう。
起動時に自動でリンクテーブルを作り直すように、Autoexecマクロを利用して、リンクテーブル削除と組み直しを自動実行しておくと尚良いでしょう。

VBAからOutlookを操作する

VBAとOutlookの参照設定にて、リンクテーブルよりも多くのメール情報をレコードとして取得し格納する事が可能です。ただし、この方法でも「Message-ID」や「In-Reply-To」などの固有のIDや返信先のIDなどは取得が出来ない。EntryIDというIDが各メールに割り振られているものの、このIDは不変ではなく、フォルダを移動したりすると変更されてしまうので、扱いに注意が必要です。

通常のメールボックスメールを取得する

通常の自分自身のメールボックスのメールを取得します。受信フォルダ以下に作成したサブフォルダに対して取得を実行する事も可能です。この手法の場合、共有メールボックスのメールは取得できないので注意が必要です。

'指定アカウントのOutlook受信トレイ内のメールをテーブルに取得する (日付の最大値以上のものだけを取得)
Public Function getOutlookMail()
    Dim result As Variant
    
    result = MsgBox("Outlookから最新のデータを取得しますか？？件数が多いと相当の時間が掛かります。", vbYesNo + vbDefaultButton2 + vbExclamation)
    If result = vbYes Then
        'そのまま次の処理へ移動する
    Else
        MsgBox "処理がキャンセルされました。"
        Exit Function
    End If

    'Outlook用変数
    Dim objOutlook As Outlook.Application
    Dim olNS As Outlook.NameSpace
    Set objOutlook = New Outlook.Application
    Set olNS = objOutlook.GetNamespace("MAPI")

    'アカウント名を取得する
    Dim mailman As String
    mailman = olNS.Accounts.Item(1).SmtpAddress
    
    '受信トレイを取得する
    Set myInbox = olNS.GetDefaultFolder(olFolderInbox)
    
    'サブフォルダを指定したい場合は以下のコードを追加し、subfolderでItems.CountをForで回す
    'Dim subfolder
    'Set subfolder = myInbox.Folders.Item("サブフォルダ名")

    'DB接続用
    Dim db As DAO.Database
    Set db = CurrentDb()
    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset("受信トレイ", dbOpenDynaset)
    
    '受信トレイのレコードのsenddateの最大日付を取得する
    Dim maxdate As Variant
    maxdate = DMax("senddate", "受信トレイ")
    
    If IsNull(maxdate) Then
        maxdate = 0
    End If
    
    '受信トレイ内を探索
    Dim i As Long
    Dim tempdate As Variant
    Dim diffman As Variant
    
    For i = 1 To myInbox.Items.Count
        '受信日付を取得する
        tempdate = myInbox.Items(i).ReceivedTime
        
        'DMaxの値によって条件分岐
        If maxdate = 0 Then
            '特に何もしない
        Else
            '受信日付を取得する
            
            'DMaxの値とsenddateの値を比較
            '差分を取る
            diffman = DateDiff("s", maxdate, tempdate)
            
            '最大日付のレコードより過去のデータはスキップする
            If diffman <= 0 Then
                GoTo Continue
            End If
        
        End If
    
        'レコードを追加する
        With rs
            .AddNew
            
            '受信データを書き込む
            On Error Resume Next
            !EntryID = myInbox.Items(i).EntryID
            !senddate = tempdate
            !Subject = myInbox.Items(i).Subject
            !Body = myInbox.Items(i).Body
            !Sender = myInbox.Items(i).Sender
            !CC = myInbox.Items(i).CC
            !To = myInbox.Items(i).To
            .Update
        End With
Continue:
    Next i
    
    '終了処理
    MsgBox "取込が完了しました。"
    
    db.Close
    Set db = Nothing
    Set rs = Nothing

End Function

6000通のメールでおよそ5分ほど掛かります。
リンクテーブルではないので、受信後データの表示や処理は高速に行えます。
日付時刻を見て現在取得済みメールの最大値より大きい値（つまり未来のメール）だけを取得して追加するようにしてあります。DMaxで最大値を取得し、DateDiffの秒での比較で0よりプラスの値がそれになります。
各メールのItemのプロパティは様々なものが用意されています。こちらのページのPropertiesがそれに該当します。
稀にSenderに値のないものがあってコードが止まるケースの為に、on error resume nextを入れてあります。
指定のメールアドレスの取得はmailman変数に格納し、.Session.CreateRecipientにてセットする
共有メールボックスからのメール取得は出来ません
.GetDefaultFolderの第二引数では、olFolderInboxを指定すると受信トレイになります。こちらにいろいろなフォルダの指定用の値が一覧で表示されています。
受信トレイ以下に作成したサブフォルダを対象にしたい場合にはsubfolderをFolders.Itemにて指定し、それをループで回せばOK
今回のコードは使ってるOutlookでのデフォルトアカウントが１個だけの場合です。

Outlookに複数のアカウントがある場合には以下のようなアカウントの特定とGetDefaultFolderの指定はアカウントをループして特定してセットすると良いです。以下のようなコードに置き換えます。このとき指定のメアドに自分の２つ目のメアドを入れて判定させます。

'複数アカウントがある場合の処理
Dim oAccount As Account
With objOutlook
    For Each oAccount In olNS.Accounts
        If oAccount = "指定のメアド" Then
            Set myInbox = acc.DeliveryStore.GetDefaultFolder(olFolderInbox)
        End If
    Next
End With

また、手動でアカウントと指定のフォルダ内を取得したい場合には以下のような決め打ちも可能です。指定アカウントの受信フォルダ以下に作成した指定のフォルダ内を走査します。

For Each itms1 In olNS.Folders("アカウント名").Folders("受信トレイ").Folders("フォルダ名").Items

・・・・ここにデータを取得する処理を記述する・・・・

Next

共有メールボックスメールを取得する

'指定アカウントのOutlook受信トレイ内のメールをテーブルに取得する（日付の最大値以上のものだけを取得）
Public Function getShareOutlookMail()
    Dim result As Variant
    
    result = MsgBox("Outlookから最新のデータを取得しますか？？件数が多いと相当の時間が掛かります。", vbYesNo + vbDefaultButton2 + vbExclamation)
    If result = vbYes Then
        'そのまま次の処理へ移動する
    Else
        MsgBox "処理がキャンセルされました。"
        Exit Function
    End If

    'outlook用変数
    Dim objOutlook As Object
    Dim myInbox
    Dim acc As Object
    Set objOutlook = GetObject(, "Outlook.Application")
    Dim olNS As Outlook.NameSpace
    Set olNS = objOutlook.GetNamespace("MAPI")
    
    'アカウント名を取得する
    Dim mailman As String
    mailman = "ここに共有メールボックスのメアドを入れる"

    '指定のアカウントのNamespaceを取得
    With objOutlook
        Set acc = .Session.CreateRecipient(mailman)
        acc.Resolve
        
        If acc.Resolved Then
            '受信トレイを指定
            Set myInbox = .Session.GetSharedDefaultFolder(acc, olFolderInbox)
        End If
    End With

    
    'DB接続用
    Dim db As DAO.Database
    Set db = CurrentDb()
    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset("受信トレイ", dbOpenDynaset)
    
    '受信トレイのレコードのsenddateの最大日付を取得する
    Dim maxdate As Variant
    maxdate = DMax("senddate", "受信トレイ")
    
    If IsNull(maxdate) Then
        maxdate = 0
    End If
    
    '受信トレイ内を探索
    Dim i As Long
    Dim tempdate As Variant
    Dim diffman As Variant
    
    For i = 1 To myInbox.Items.Count
        '受信日付を取得する
        tempdate = myInbox.Items(i).ReceivedTime
        
        'DMaxの値によって条件分岐
        If maxdate = 0 Then
            '特に何もしない
        Else
            '受信日付を取得する
            
            'DMaxの値とsenddateの値を比較
            '差分を取る
            diffman = DateDiff("s", maxdate, tempdate)
            
            '最大日付のレコードより過去のデータはスキップする
            If diffman <= 0 Then
                GoTo Continue
            End If
        
        End If
    
        'レコードを追加する
        With rs
            .AddNew
            
            '受信データを書き込む
            On Error Resume Next
            !EntryID = myInbox.Items(i).EntryID
            !senddate = tempdate
            !Subject = myInbox.Items(i).Subject
            !Body = myInbox.Items(i).Body
            !Sender = myInbox.Items(i).Sender
            !CC = myInbox.Items(i).CC
            !To = myInbox.Items(i).To
            .Update
        End With
Continue:
    Next i
    
    '終了処理
    MsgBox "取込が完了しました。"
    
    db.Close
    Set db = Nothing
    Set rs = Nothing


End Function

指定のメールアドレスの取得はmailman変数に格納し、.Session.CreateRecipientにてセットする
共有メールボックスからのメール取得では、.Session.GetSharedDefaultFolderを使って取得します。
.Session.GetSharedDefaultFolderの第二引数では、olFolderInboxを指定すると受信トレイになります。こちらにいろいろなフォルダの指定用の値が一覧で表示されています。ただし、olFolderSentMailなどの送信済みトレイなどの指定が出来ません。
日付時刻を見て現在取得済みメールの最大値より大きい値（つまり未来のメール）だけを取得して追加するようにしてあります。DMaxで最大値を取得し、DateDiffの秒での比較で0よりプラスの値がそれになります。
各メールのItemのプロパティは様々なものが用意されています。こちらのページのPropertiesがそれに該当します。
稀にSenderに値のないものがあってコードが止まるケースの為に、on error resume nextを入れてあります。
こちらの手法は共有メールボックスも扱えますが、取得の速度がかなり遅いので時間を要します。

共有メールボックスで送信済みトレイデータを取得する

前項の方法では、受信トレイデータは取れても、例えば送信済みトレイを取る事ができません。.GetSharedDefaultFolderの引数にolFolderSentMailを指定することが出来ないためです。そこで、一旦受信トレイを取得し、その親に移動、そこから送信済みトレイと辿る事で取得することが可能になります。

'指定アカウントのOutlook送信済みトレイ内のメールをテーブルに取得する（日付の最大値以上のものだけを取得）
Public Function getOutlookMail()
    Dim result As Variant
    
    result = MsgBox("Outlookから最新のデータを取得しますか？？件数が多いと相当の時間が掛かります。", vbYesNo + vbDefaultButton2 + vbExclamation)
    If result = vbYes Then
        'そのまま次の処理へ移動する
    Else
        MsgBox "処理がキャンセルされました。"
        Exit Function
    End If

    'outlook用変数
    Dim objOutlook As Object
    Dim myInbox
    Dim acc As Object
    Set objOutlook = GetObject(, "Outlook.Application")

    'Namespaceを取得する
    Dim olNS As Outlook.NameSpace
    Set olNS = objOutlook.GetNamespace("MAPI")
    
    'アカウント名を取得する
    Dim mailman As String
    mailman = IniRead("USER", "OUTLOOK", "")
    
    '指定のアカウントのNamespaceを取得
    With objOutlook
        Set acc = .Session.CreateRecipient(mailman)
        acc.Resolve
        
        If acc.Resolved Then
            Set myInbox = olNS.GetSharedDefaultFolder(acc,olFolderInbox).Parent.Folders("送信済みアイテム")
        End If
    End With
    
    'DB接続用
    Dim db As DAO.Database
    Set db = CurrentDb()
    Dim rs As DAO.Recordset
    Set rs = db.OpenRecordset("送信済みトレイ", dbOpenDynaset)
    
    '受信トレイのレコードのsenddateの最大日付を取得する
    maxdate = DMax("senddate", "送信済みトレイ")
    
    If IsNull(maxdate) Then
        maxdate = 0
    End If
    
    '送信済みトレイ内を探索
    For i = 1 To myInbox.Items.Count
        '受信日付を取得する
        tempdate = myInbox.Items(i).ReceivedTime
        
        'DMaxの値によって条件分岐
        If maxdate = 0 Then
            '特に何もしない
        Else
            '受信日付を取得する
            
            'DMaxの値とsenddateの値を比較
            '差分を取る
            diffman = DateDiff("s", maxdate, tempdate)
            
            '最大日付のレコードより過去のデータはスキップする
            If diffman <= 0 Then
                GoTo Continue2
            End If
        
        End If
    
        'レコードを追加する
        With rs
            .AddNew
            
            '受信データを書き込む
            !entryid = myInbox.Items(i).entryid
            !senddate = tempdate
            !subject = myInbox.Items(i).subject
            !body = myInbox.Items(i).body
            !sender = myInbox.Items(i).sender
            !cc = myInbox.Items(i).cc
            !to = myInbox.Items(i).to
            .Update
        End With
Continue2:
    Next i
    
    '終了処理
    MsgBox "取込が完了しました。"
    
    db.Close
    Set db = Nothing
    Set rs = Nothing
End Function

前回のコードに加えて、objOutlook.GetNamespace("MAPI")にてNamespaceを取得しておく
取得したNamespaceに対して、olNS.GetSharedDefaultFolder(acc,olFolderInbox).Parent.Folders("送信済みアイテム")にて受信トレイ⇒親フォルダ⇒送信済みアイテムと辿ってフォルダを取得させる
あとはこれまでと同じようにループで一個ずつ取り出す。
この方法だと、どこかにぶら下がっているわけではないフォルダの中身も正確に取り出すことが可能です。

共有メールボックスにてメールを新規送信

通常のメールボックスでももちろんメールを送信できますが、共有メールボックスアカウントを使ってのメール送信はやや面倒です。別途メール作成用のフォームなどは用意しておく必要性があります。

Private Sub コマンド25_Click()
    '通常の変数の宣言
    Dim result As Variant

    '処理実行の確認
    result = MsgBox("上記の内容で、メールを送信しますか？。", vbYesNo + vbDefaultButton2 + vbCritical, "新規メールの送信")
    
    If result = vbYes Then
    Else
        '処理のキャンセル
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If

    'Outlook用変数
    Dim olkApp, objItem, acctToSend
    Dim oAccount As Outlook.Account
    Set olkApp = CreateObject("Outlook.Application")

    'メールアイテムを作成
    Set objItem = olkApp.CreateItem(0)

    '宛先、件名、本文を指定
    'メアドはカンマはセミコロンに置き換えておく
    With objItem
        .to = Replace(Me.tomail.value, ",", ";")
        .cc = Replace(Me.ccmail.value, ",", ";")
        .subject = Me.subject.value
        .body = Me.body.value
    End With

    '送信アカウントを取得
    Dim mailacc As String
    mailacc = "ここに共有メールボックスのメアドを入れる"

    ' 送信アカウントを指定
    'Session.Accounts.Item()だと()に番号をいれなければならない。アカウント名だとNG
    objItem.SentOnBehalfOfName = mailacc

    'メールを送信
    objItem.send
    
    '終了処理
    MsgBox "メール送信されました。"
    Set olkApp = Nothing
    Set objItem = Nothing
    Set acctToSend = Nothing
    
    'ダイアログを閉じる
    DoCmd.Close acForm, "新規メール作成", acSaveNo

End Sub

CreateItem(0)にて新規のメール作成になります。
toやccは、複数宛先がある場合、旧式のカンマを入れてしまった場合に備えて、セミコロンにリプレースしています。
送信するアカウントはデフォルトだと自分のアカウントを使ってしまうので、SentOnBehalfOfNameを使って送信アカウントを指定します。

図：新規メール作成用のサンプルフォームの事例

共有メールボックスにてメールを返信する

返信の場合は新規作成よりもさらにちょっと複雑です。あまりネットにも資料がないのですが、基本はreplyメソッドを使ってメールを作ることになります。

Private Sub コマンド25_Click()
    '通常の変数の宣言
    Dim result As Variant

    '処理実行の確認
    result = MsgBox("上記の内容で、メールを返信しますか？。", vbYesNo + vbDefaultButton2 + vbCritical, "新規メールの送信")
    
    If result = vbYes Then
    Else
        '処理のキャンセル
        MsgBox "処理はキャンセルされました。"
        Exit Sub
    End If

    'Outlook用変数
    Dim olkApp, objItem, acctToSend
    Dim oAccount As Outlook.Account
    Set olkApp = GetObject(, "Outlook.Application")
    Set olNS = olkApp.GetNamespace("MAPI")
    Dim Mail, NewMail, acc
    
    '送信アカウントを取得
    Dim mailman As String
    mailacc = "ここに共有メールボックスのメアドを入れる"
    
    '指定のアカウントの受信トレイを取得し対象とする
    With olkApp
        Set acc = .Session.CreateRecipient(mailacc)
        acc.Resolve
        
        If acc.Resolved Then
            'olFolderSentMailで送信済みフォルダ
            Set myInbox = .Session.GetSharedDefaultFolder(acc, olFolderInbox)
        End If
    End With

    'mailにentryidをセットする
    Set Mail = olNS.GetItemFromID(Me.entryid.value)
    Set NewMail = Mail.Reply
    
    'HTML Bodyにするために改行コードを<br>に変更
    Dim bodyman As String
    bodyman = Replace(Me.body.value, vbCrLf, "<br>")
    
    '受信メール側bodyも置き換えておく
    Dim bodyman2 As String
    bodyman2 = Replace(Me.body2.value, vbCrLf, "<br>")
    
    '宛先、件名、本文を指定
    With NewMail
        .to = Replace(Me.tomail.value, ",", ";")
        .cc = Replace(Me.ccmail.value, ",", ";")
        .subject = Me.subject.value
        .HTMLBody = bodyman & "<br><hr><br>" & bodyman2
        .BodyFormat = olFormatHTML  'HTML形式で送信
        .SentOnBehalfOfName = mailacc ' 送信アカウントを指定
    End With

    'メールを送信
    NewMail.send
    
    '終了処理
    MsgBox "メールが返信されました。"
    Set olkApp = Nothing
    Set Mail = Nothing
    Set NewMail = Nothing
    
    'ダイアログを閉じる
    DoCmd.Close acForm, "返信メール作成", acSaveNo

End Sub

予め、メールの受信用テーブルに受信時に対象のメールの「entryID」を取得しておく必要があります。
共有メールボックスの受信トレイを取得しておく必要があるため、Session.GetSharedDefaultFolderで取得させておきます。
GetItemFromIDとentryIDにて返信対象となるメールを取得しておきます。それにたいして、Replyを行う
今回はHTMLメールを送るために、返信元メール本文やフォーム上の内容の改行コードを<br>に置換させています。
あとは通常の送信と同じように組み立ててsendするだけ

図：自分が作った返信用フォーム

作っておいた署名を取得する

OutlookメールをVBAで送る場合、署名が自動では入りません。Outlookに自分で設定済みの署名を取得し、メール本文に付け足したいケースはままあると思います。この署名ですが

Outlookの新規メール作成⇒挿入⇒署名(▼クリック）⇒署名とすると出てくる
複数の署名を作っておくことが可能です。
作った署名は署名の名前.txtという形で、各ユーザのC:Usersユーザ名AppDataRoamingMicrosoftSignaturesのディレクトリに、署名名で作ったtxtという形でファイルとして保存されています。

これをVBAで取るならば事前に、Windows Script Host Object Modelを参照設定に入れて於いてユーザ名を自動取得させ、所定のディレクトリにアクセスさせましょう。

Public Function readsign()
	'FileSystemObject用変数
	Dim fso As Object, buf As String
	Set fso = CreateObject("Scripting.FileSystemObject")
	
	'ログインユーザ名を取得する
	Dim WshNetworkObject As IWshRuntimeLibrary.WshNetwork
	Set WshNetworkObject = New IWshRuntimeLibrary.WshNetwork
	dim loginuser as string
	loginuser = WshNetworkObject.UserName
	
	'署名ファイルのパスを構築する
	dim filepath as string
	dim signname as string
	singname = "署名"
	filepath = "C:Users" & loginuser & "AppDataRoamingMicrosoftSignatures" & singname & ".txt"
	
	'署名ファイルの中身を取得して返す
	With fso.GetFile(filepath).OpenAsTextStream(1, -2)
		buf = .ReadAll
		.Close
	End With
	
	'終了処理
	Set fso = Nothing
	
	'署名データを返す
	readsign = buf
End Function

ログインユーザ名を取得し、signnameに署名の名前を入れておく。
パスを構築して、fsoにてtxtファイルの中身を取得し、返すだけの関数です

図：署名ファイルはtxtファイルで保存されている

AccessとOutlookの便利な連携術

今回使用するファイル類

リンクテーブルを利用する

手動でリンクテーブルにて接続

VBAで動的にリンクテーブルを作る

VBAからOutlookを操作する

通常のメールボックスメールを取得する

共有メールボックスメールを取得する

共有メールボックスで送信済みトレイデータを取得する

共有メールボックスにてメールを新規送信

共有メールボックスにてメールを返信する

作っておいた署名を取得する

関連リンク

コメントを残すコメントをキャンセル

Access VBAでExcel・CSVデータをインポートする

スマートフォンで素敵な車載動画を作成する

今回使用するファイル類

リンクテーブルを利用する

手動でリンクテーブルにて接続

VBAで動的にリンクテーブルを作る

VBAからOutlookを操作する

通常のメールボックスメールを取得する

共有メールボックスメールを取得する

共有メールボックスで送信済みトレイデータを取得する

共有メールボックスにてメールを新規送信

共有メールボックスにてメールを返信する

作っておいた署名を取得する

関連リンク

コメントを残す コメントをキャンセル

Access VBAでExcel・CSVデータをインポートする

スマートフォンで素敵な車載動画を作成する

コメントを残すコメントをキャンセル