OUTLOOKのイベントをエクセルVBAのトリガーにする。

OUTLOOK研修所から以前に問い合わせについての解答をいただきましたが,私の環境で,なかなか実現でき
ませんでした。実現できなかった原因は,そもそも,設定仕方等が,全く違っていたのです。それに,肝
心のこと忘れていました。イベントを受け取るにには,プロシージャが終了していては,いけないのです。
肝心要のこのことも抜けていました。それで,copilotにしつこく聞いたり,google先生をたよったりして,
本日やっと実現できました。

まず,OUTLOOKのイベントをつかむには,

Public WithEvents mySentItems As Outlook.Items

を書く必要がありますが,このコードは,クラスモジュールに書かなければいけにようです。同時に,
OUTLOOK研究所でおしえてもらった,サブルーチン等も,クラスモジュールに置く必要があるようで,標
準モジュール等に置くと,エラーになります。また,クラスモジュールにおいたサブルーチンを呼ぶには
手続きがいるようで,これも抜けていたようです。下記がClassモジュールにおいたものの全文です。

Option Explicit

Public myOutlookApp As Outlook.Application
Public mySentFolder As Outlook.Folder
Public WithEvents mySentItems As Outlook.Items

Private Sub Class_Initialize()
    Set myOutlookApp = Nothing    'objoutlookの初期値これがないとGetObjectに失敗するとobjoutlookはemptyのまま
    
    On Error Resume Next
        Set myOutlookApp = GetObject(, "Outlook.Application")     '起動済みのOutlookをクラス名を指定して取得
    On Error GoTo 0

    If myOutlookApp Is Nothing Then                               'objoutlookがNothingなら
        Set myOutlookApp = CreateObject("Outlook.Application")    'Outlookを起動
    End If

    Dim oNS As Namespace
    Set oNS = myOutlookApp.GetNamespace("MAPI")
    Set mySentFolder = oNS.GetDefaultFolder(olFolderSentMail)
    Set mySentItems = mySentFolder.Items

End Sub
Public Sub AddTrackInfo(ByVal objMail As MailItem, iRow As Integer, iCol As Integer)
     Dim olkApp As Outlook.Application
     Dim fldSentMail As Folder
     Dim strTrackInfo As String
     Dim propTrack As UserProperty

     ' 送信済みアイテム フォルダーを取得
     Set fldSentMail = objMail.Application.Session.GetDefaultFolder(olFolderSentMail)

     ' mySentItems が設定されていなければ送信済みアイテム フォルダーの Items を設定
     If mySentItems Is Nothing Then
         Set mySentItems = fldSentMail.Items
     End If


     ' メールに送信後の保存先フォルダーを設定

     Set objMail.SaveSentMessageFolder = fldSentMail


     ' 送信状況を追跡するためのプロパティを設定
     Set propTrack = objMail.UserProperties.Add("TrackInfo", olText, True)

     ' 送信日時を保存するセルの行番号と列番号を設定
     propTrack.Value = iRow & "," & iCol
     
End Sub


' 送信済みアイテム フォルダーにアイテムが追加されたときに実行されるイベント
Public Sub mySentItems_ItemAdd(ByVal Item As Object)
     Dim objMail As MailItem
     Dim propTrack As UserProperty
     Set objMail = Item
     ' 送信状況を追跡するプロパティの確認
     Set propTrack = objMail.UserProperties.Find("TrackInfo")

     ' プロパティが存在したら
     If Not propTrack Is Nothing Then
         Dim arrRC As Variant
         ' 送信日時を保存するセルの行番号と列番号を取得
         arrRC = Split(propTrack.Value, ",")
         ' 取得した行、列のセルに送信日時を保存
         Sheet1.Cells(CInt(arrRC(0)), CInt(arrRC(1))).Value = objMail.SentOn
     End If
End Sub

これを実行するには,標準モジュール等から,このクラスモジュールのサブルーチンを下記のようにして
呼び出します。VBAを終了しないよううに,最後にユーザーフォームを表示してます。

Public Function Mail_Sousin()
        ▼
		詳細設定略
        ▲ 
           
                Dim clsSample1 As Class1 'Class1型のオブジェクト変数を宣言 「Class1」はクラスモジュール名
                Set clsSample1 = New Class1
    
                Call clsSample1.AddTrackInfo(objItem, 4, 9) 'objItemは,送信するメール本体4,9はRange(4,9)で
                               送信日時を記録すすセル
                           
                If jidou_sousin_flag = False Then
                    objItem.Display  '送信画面を表示
                End If
                If jidou_sousin_flag = True Then
                    objItem.Send    '自動で送信
                End If

              UserForm1.Show

               Set olkApp = Nothing
               Set objItem = Nothing
               Set acctToSend = Nothing

End Function
クラスモジュールのサブルーチンを呼ぶには,インスタンス?を下記のように作成しないとだめみたいでした。

                Dim clsSample1 As Class1 'Class1型のオブジェクト変数を宣言 「Class1」はクラスモジュール名
                Set clsSample1 = New Class1
    
                Call clsSample1.AddTrackInfo(objItem, 4, 9)

なお,一番参考になったのは,外国の掲示板でした。

これからは,google先生 よりも AI か

今日初めて,マイクロソフトのPC付属の cipilot に質問してみました。
質問は,

VBAエクセルで,アクティブセルの背景の色を変えるコードは。条件付き書式では」

で,下記のような解答でした。

 Private Sub ApplyConditionalFormatting()
     Dim ws As Worksheet
     Dim rng As Range
     
     ' シートと範囲を設定
     Set ws = ThisWorkbook.Sheets("Sheet1") ' シート名を適切に変更してください
     Set rng = ws.Range("A1:A100") ' 範囲を適切に変更してください
     
     ' 既存の条件付き書式をクリア
     rng.FormatConditions.Delete
     
     ' 新しい条件付き書式を追加
     With rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=ROW()=CELL(""row"")")
         .Interior.Color = RGB(255, 255, 0) ' 背景色を黄色に設定
     End With
 End Sub

google先生よりも,具体的で,この解答,ほぼあってます。

VBA 他シートへ関数の書き込み

開いているBook 間では,VBA の プロシャージャの書き込みもできるようです。

下記のプロシャージャでは,新しく開いたエクセルのファイルに,macro.txt に書かれた関数を書き込みます。

Private Sub CommandButton3_Click()
    'OPENしたBOOKのSHEET1に ”macro.txt” のプロしィージャを書き込む
    Dim wb As Workbook
    
    fTyp = "Excelファイル(*.xlsm),*.xlsm,Excelファイル(*.xlsx),*.xlsx,Excelファイル(*.xls),*.xls"
    prompt = "Excelファイルを選択してください"
    fPath = Application.GetOpenFilename(fTyp, , prompt)
    
    Set wb = Workbooks.Open(fPath, UpdateLinks:=Ture, ReadOnly:=Ture)
    
    With wb.VBProject.VBComponents("Sheet1").CodeModule
        .AddFromFile "C:\Users\mabo-2021\Desktop\****\*****\*****\*****\macro.txt"
    End With
    
End Sub

macro.txtという下記の内容のファイルを同じフォルダーにおいてきます。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Application.ScreenUpdating = True
End Sub

VBA 他シートへの条件付き書式の書き込み

他シートに記載してあるデータを転記する必要がありました。特定の列を転記するので,転記す
る列を強調するにはどうしようかと考えていました。
メインとなっているBookから,転記するシートを開く,転記する列を選ぶ,転記する,との一連
の動作は,一通りできるようになってますが,よりわかりやすくするのに,転記する列を強調し
たくなり,その方法をいろいろかんがえていました。転記するBookに条件付き書式を手動で設定
すれば,事足りるのですが,手動では,あまりにも芸がないので,VBAから,できないか,思案し
ていました。
VBAからVBAに書き込むようかなとあれこれあさっていましたが,条件付き書式は,ブックを開いて
さえいれば,メインのBookから,他のBookに条件付き書式の書き込みができるようなので,実際に
実行してみました。
メインのVBAに

 '読み込んだファイル名でブックを開く
    Set wb = Workbooks.Open(fPath, UpdateLinks:=Ture, ReadOnly:=Ture)
    Set Taisyou_Sheet = wb.Worksheets("受付名簿")
    
    '対象シートに条件付き書式を設定
    Taisyou_Sheet.Cells.FormatConditions.Delete
    Range(Taisyou_Sheet.Cells(4, 2), Taisyou_Sheet.Cells(101, 14)).FormatConditions.Add(Type:=xlExpression, Formula1:="=CELL(""COL"")=COLUMN()").Interior.Color = rgbPowderBlue

のように書き込むことで,条件付き書式の設定ができたようです。
ただ,これだけでは,だめで,

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
 Application.ScreenUpdating = True
End Sub

を該当シートに書き込む必要があるので,やはり,VBAからVBAを操作する必要がありますね。

条件付き書式をVBAで設定 エクセル VBA アクティブセルの強調

アクティブセル(選択されているセル)を強調するのに,シートの条件付き書式の設定で次のようにしてまし
た。

  リボンホーム

  設定する範囲の選択

  「条件付き書式」をクリック

  「新しいルール」をクリック

  「数式を使用して,書式設定すセルを決定」をクリック

  「次の数式を満たす場合に値を書式設定」のところに次の数式を入れる

  =AND(CELL(“ROW”)=ROW(), cell(“COL”)=COLUMN())

  「書式設定」クリック→→「塗りつぶし」→→「色を選択」

  VBAの開発画面で,該当するシートに

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Application.ScreenUpdating = True
End Sub

  を記入。

こうすることで,選択したセル(カーソルのあるセル)に設定した色をつけるいことができます。
この条件付き書式を VBA でも設定できることは,前から知っていましたが,やってみることに。
ある諸兄のHPを参考に,

Range("B6:G15").FormatConditions.Add(Type:=xlExpression, Formula1:="=$G6>=85").Interior.Color = rgbPowderBlue

のようにして,Formula1:= 以下に条件式を書けばいいと,記載がありました。そこで,

Range("B6:G15").FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(CELL("ROW")=ROW(), cell("COL")=COLUMN())").Interior.Color = rgbPowderBlue

のように,先ほどのシートで使った数式をいれてみました。しかし,これがことごとくエラーになります。
エラー解消すべくいろいろやってみましたがだめでしたので,困ったときのHPということで,あれこれ検索
して,ヒントになる HP を発見。 ここのHPの条件式の書き方が参考になりました。
ここでは,

 'ハイライトしたい場所を Formula1:= の右側に "" で囲んで入力してください
       Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=CELL(""ROW"")=ROW()"

のよう記述がありました。

CELL(“ROW”)→→CELL(“”ROW””)

そういえば,VBA で出たエラーを見ると,「区切りがどおうのこうの・・・・」というものだったようで
す。区切りが判別できないエラーだったんですね。”ROW”をさらにダブルクオーテーションで囲うことで
エラーが回避できました。

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    Application.ScreenUpdating = True
    Worksheets("送信表").Cells.FormatConditions.Delete
    Range(Worksheets("送信表").Cells(1, 2), Worksheets("送信表").Cells(101, 10)).FormatConditions.Add(Type:=xlExpression, Formula1:="=AND(CELL(""ROW"")=ROW(), CELL(""COL"")=COLUMN())").Interior.Color = rgbPowderBlue
    
End Sub

これをWROKBOOKに書き込むことで,送信表のシートで選択セルの強調ができるようになりました。

ちなみに,行だけを強調するには,
「=AND(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」→→「=CELL(“”ROW””)=ROW()」

また,列だけを強調するには,
「=AND(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」→→「=CELL(“”COL””)=COLUMN()」

行も列も強調するには,
「=AND(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」
    
「=OR(CELL(“”ROW””)=ROW(), CELL(“”COL””)=COLUMN())」

のようにすればいいようです。

エクセル VBA Rangeの落とし穴

仕事関連のお手伝いで,使うエクセルVBAをいじってます。久しぶりに,ドツボにはまりました。ある方のHP
を参考にした(丸ぱくり)サーチのプロシャージャでのことです。

Public Function Search(ByVal Rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean) As Range
'   引数:
'       Rng:検索範囲 (例) ActiveSheet.Range ("A1:Z500")
'       KeyWord:検索する値 (例) "リンゴ",10,7.85
'       Whole:完全一致→True 部分一致→False (例)True
'   戻り値
'       Rangeオブジェクト 見つからなかった場合は「Nothing」

'   検索範囲内の「KeyWord」を検索する関数です。
'   検索範囲を一つずつ判定し、最初に一致したセル範囲を返します。
'   完全一致と部分一致対応できます。
'   非表示のセルも検索かけます
'   検索結果はセル範囲一つだけです。複数の場合が良ければ「search_List」関数を使ってください
'   https://www.hokkyokun.com/vba-search-vs-findmethod/
    Dim r As Range    
    '完全一致
    If Whole Then
        For Each r In Rng
            If r.Value = keyWord Then
                Set Search = r
                Exit Function
            End If
        Next
        
    '部分一致
    Else
        For Each r In Rng
            If InStr(r.Value, keyWord) > 0 Then
                Set Search = r
                Exit Function
            End If
        Next
    End If  
    '見つからなかった時の処理
    '適宜変更してもらって構いません    
    Set Search = Range("XFD1048576")    'Range(1048576,16384)を返す--最終セル
End Function

この関数を呼び出すのに,次のようなサブルーチンを使いました。

Private Sub CommandButton7_Click()
    Dim Hani, kensakukekka As Range
    Set Hani = Range(Worksheets("マスター").Cells(2, 5), Worksheets("マスター").Cells(96, 5))
    MsgBox Worksheets("マスター").Cells(2, 5) & Worksheets("マスター").Cells(96, 5)
    kensakukekka = Search(Hani, "リンゴ", True)
    MsgBox kensakukekka     
End Sub

このサブルーチンはうまくいきました。しかし,

 MsgBox kensakukekka

の部分を,

 MsgBox kensakukekka & kensakukekka.Row

にするとエラーになるのです。考えられる,修正を加えましたが,エラーは,直りませんでした。
下記加えた,kensakukekka.Row は,検索結果の入っている,行番号を返すはずなのですが,エラーになり
ます。訳が分かりませんでしたので,お助け掲示板かなと思っていたのですが,ふと気がつきました。
気がつくまで,半日無駄にしました。原因は,分かってみると,簡単なのですが,呼び出しのサブルーチン
に使っていた,

kensakukekka = Search(Hani, "リンゴ", True)

が違っていたのです。Range の設定には, Set をつけてやる必要があったのです。

Set kensakukekka = Search(Hani, "リンゴ", True)

のように,Set を入れると無事思った動作になりました。 Range を扱う時は,Set を入れることを失念
したための大ポカでした。
半分?動いたので,大丈夫と思っていたのが大間違いでしたが,たちが悪いですね。エラーなら全部エラー
になればいいのになんて思いました。

エクセルーVBAー「何もしない」命令

仕事のお手伝いで使うVBAのプロシャージャの修正をしています。
変更があったときになるべく修正をしなくていいようなものを模索しています。また,同時に,後で見たとき
に何をやってるのか分かるような視認生を有効にできるように心がけていますが,両立させるのは,結構手間
がかかります。

今まで,先行受付については,期間については,手動で加減していましたが,期間についても,プロシャージ
ャに入れることにしました。
下記のようなものを考えました。

 If DateValue(sousin) < DateValue("2030/01/22") Then             'ハワイ支部会員先行受付
          If syubetu = "会員" And InStr(sibu, "ハワイ") > 0 Then
                  '何もしない
           Else
                 objmailItem.Move objFolder_kikangai
           End If
  End If

このように書いていました。必要なのは,先行受付の期間では,該当しないメールを期間外のホルダーに移動
するのですが,先行受付に該当するメールには,何もしなくて,それ以外を期間外ホルダーに移すと考えた方
がわかりやすいです。(最も,私にとってはです・・・・。)
if の部分では,なにもしなくて,else で該当しないメールの処理をする,という記述ですが,この方法だ
と,処理が増えていくことを考えると下記のように NOT を使う記述がいいとのことでした。

If DateValue(sousin) < DateValue("2030/01/22") Then             'ハワイ支部会員先行受付
          If Not(syubetu = "会員" And InStr(sibu, "ハワイ") > 0) Then
                objmailItem.Move objFolder_kikangai
          End If
End If

該当する条件を考えて,それに NOT をつけて,(該当しない条件にする)この方が,いいかもですね。

CDOによるメール送信ーエクセル VBA IPロック

CDOを使うと,エクセルVBAから,OUTLOOK等を経由しなくてもメールが送れるということを知りました。
そこで,下記のサイトを参考(コピペ)にして,トライしてみることにしました。

下記のコピペのプロシャージャyの必要な部分を自分の環境に合わせてやってみましたが,メールが送れま
せんでした。CDOそのものが使えないのかとも思いましたが,2024年現在お使いの方いるということで設
の定間違いだろうと検討をつけてあれこれやりました。

VBAを使ってスクレイピングの結果をメール送信する(さくらのレンタルサーバー使用)

Function SendSakuraMail(kenmei As String, mozi As String, address As String) As Boolean

    Dim objCDO As New CDO.Message

    On Error GoTo Errlabel    'エラー処理

    With objCDO

        With .Configuration.Fields
            .Item(cdoSMTPServer) = "****.sakura.ne.jp"
            .Item(cdoSendUsingMethod) = cdoSendUsingPort
            .Item(cdoSMTPServerPort) = 587                          '送信サーバーのポート番号
            .Item(cdoSMTPConnectionTimeout) = 15                    'タイムアウト
            .Item(cdoSMTPAuthenticate) = cdoBasic                   'SMTP認証
            .Item(cdoSMTPUseSSL) = False                            'SSL
            .Item(cdoSendUserName) = "--------@****.sakura.ne.jp"
            .Item(cdoSendPassword) = "?????????????????"
            .Item(cdoLanguageCode) = CdoCharset.cdoShift_JIS        '文字セット指定
            .Update '設定を更新
        End With
        With .Fields
            '重要度、通常は以下のどちらかで良いでしょう
            .Item("urn:schemas:mailheader:X-Priority") = 1
            .Item("urn:schemas:mailheader:X-MsMail-Priority") = "High"
            .Update '設定を更新
        End With
        .MDNRequested = False                   '開封確認
        .MimeFormatted = True                   'MIMEを使って書式設定
        .From = "------------@-----------.jp"
        .To = address                           '関数の引数で受け取った送信先
        .CC = ""
        .Subject = kenmei                       '関数の引数で受け取った件名
        .TextBody = mozi                        '関数の引数で受け取ったメール本文
        .Send                                   '送信
    End With
    Set objCDO = Nothing
    SendSakuraMail = True
    Exit Function
Errlabel:
  SendSakuraMail = False      '何かしらのエラーの場合はfasleをreturanする

End Function

結果,無事,メールを送ることができました。
原因は,送信メールアドレスのドメインを,初期のものにしていませんでした。

     誤 *********.jp——-取得独自ドメイン
     正 ***.sakura.ne.jp—初期ドメイン

といっても,無事送れたのは,1回だけです。頭を悩ましましたが,1時間後にまた送信成功。
おかしいなと思い,あれこれ検索してみると,下記のような記事を見つけました。

特定の時間に一定時間メールの送受信ができない

この記事の中に,

さくらのレンタルサーバではセキュリティ対策により、パスワード認証を続けて失敗した、
あるいはその他、攻撃とみなされるようなアクセスがあった場合に、接続元のグローバル
IPアドレスから以下のプロトコルでのサーバへの接続を一定時間制限させていただくことが
あります。

というような記述がありました。その症状として,

・毎週、休暇明けの月曜日8:00~9:00にメールの送受信ができない。
・断続的に1時間程度メールの送受信ができない時間が発生する。

ということで,これに当てはまるのかなと納得いたしました。

結論として,何度も間違た設定で接続したので,IP ロックがかかってしまったと,考えるのがいいようです。

===追記===
サクラのレンタルサーバーでの動作確認をする過程で,gmail.yahoo のメールでも試しました
が,どちらもだめでした。yahoo については,すでに,二段階認証になっていたので,だめかなと思
ってました。gmail については,わずかな期待もっていましたが,gmail については,
「安全性の低いアプリ」からの接続は,順次廃止されるようで,gmail のアカウント内で作成
した「アプリパスワード」が必要なようです。

エクセル VBA メール送信の記録をエクセルに保存

お仕事のお手伝いの関係で,VBAをいじってます。エクセルを使って,催しの受付記録のおてつだいです。
いままでは,何のチェックもなく送信終了すれば,送信済 の記入をエクセルにしてました。ただ,これだ
と,途中で送信をやめたり,そうしんできずに送信トレイに残ってて,送信済の記録みなってしまいます。
自分だけは解決できそうにないので,OUTLOOK研究所に投稿をしてみました。結果,ちょっと時間
がかかったようですが,すばらしい回答をいただきました。その方法は,送信済みのメールが,送信済み
トレイに移動するときに,発生するイベントを利用するというものでした。クリックイベントとかは,普通
に使ってましたが,OUTLOOKのイベントについては,分かりませんでした。早速,自分の環境にて,
試してみました。見事に動きました。

Dim WithEvents mySentItems As Items

Public Sub AddTrackInfo(ByVal objMail As MailItem, iRow As Integer, iCol As Integer)
     Dim olkApp As Outlook.Application
     Dim fldSentMail As Folder
     Dim strTrackInfo As String
     Dim propTrack As UserProperty
     
     ' 送信済みアイテム フォルダーを取得
     Set fldSentMail = objMail.Application.Session.GetDefaultFolder(olFolderSentMail)
     
     ' mySentItems が設定されていなければ送信済みアイテム フォルダーの Items を設定
     If mySentItems Is Nothing Then
         Set mySentItems = fldSentMail.Items
     End If
     
     ' メールに送信後の保存先フォルダーを設定
     Set objMail.SaveSentMessageFolder = fldSentMail
     
     ' 送信状況を追跡するためのプロパティを設定
     Set propTrack = objMail.UserProperties.Add("TrackInfo", olText, True)
     
     ' 送信日時を保存するセルの行番号と列番号を設定
     propTrack.Value = iRow & "," & iCol

End Sub

' 送信済みアイテム フォルダーにアイテムが追加されたときに実行されるイベント
Public Sub mySentItems_ItemAdd(ByVal Item As Object)
     Dim objMail As MailItem
     Dim propTrack As UserProperty
     Set objMail = Item
     ' 送信状況を追跡するプロパティの確認
     Set propTrack = objMail.UserProperties.Find("TrackInfo")
     ' プロパティが存在したら
     If Not propTrack Is Nothing Then
         Dim arrRC As Variant
         ' 送信日時を保存するセルの行番号と列番号を取得
         MsgBox propTrack.Value
         arrRC = Split(propTrack.Value, ",")
         ' 取得した行、列のセルに送信日時を保存
         Sheet1.Cells(CInt(arrRC(0)), CInt(arrRC(1))).Value = objMail.SentOn
     End If
End Sub

メールを送信する前に,送信するメールitem,記録する列番号,行番号をいれて,

AddTrackInfo(メールitem,記録する列番号,記録する行番号)

を呼び出します。そうすると,送信するメールのプロパティに記録する 列・行 の番号が付加されて
送信済みフォルダーに移動されます。そうすると,送信済みイベントが発生し,メールのプロパティ
から,行・列番号が付加されていると,エクセルに記録されることになるようです。
と,おおまかな,手順は理解しましたが,細かいところで,理解が進んでないので,目下,プロシャージャ
の解析中です。

エクセルVBAーーーSPLIT編(Split)メールから項目の抜き出し(2)

具体的な手順として,メール文面の空白・改行を除いて,buffer 等の変数に入れるのは同じです。

buffer="————————————————————▼送信内容————————————————————お名前=佐藤太郎ご所属=自宅ご所属先電話=00000000000メールアドレス=xxxyyy@dummy.com申し込み種別=会員所属支部=ロサンゼルス県登録番号=00999会員番号=10000999————————————————————送信日時:2024/09/28(Sat) 19:22:00"

次に,必要のない頭とお尻の部分を次のようにして除きます。

buffer1="------------------------------------------------------------送信日時"
buffer = Mid(Honbun, InStr(Honbun, "お名前=")) '「お名前=」以前の項目を消す
buffer = Left(buffer, InStr(buffer, buffer1) - 1) 'buffer1の部分を消去

 ’ buffer1に当てはまる部分を消去

これで,buffer の中身は,

buffer="お名前=佐藤太郎ご所属=自宅ご所属先電話=00000000000メールアドレス=xxxyyy@dummy.com申し込み種別=会員所属支部=ロサンゼルス県登録番号=00999会員番号=10000999"

になります。これをさらに,「=」を区切りで,split で分割して,配列にいれます。

preArray = Split(buffer, "=")

こうすると,preArray の配列に次のように格納されます。項目の値は架空のものです。

preArray(0)="お名前"
preArray(1)="佐藤太郎ご所属"
preArray(2)="自宅ご所属先電話"
preArray(3)="00000000000メールアドレス"
preArray(4)="xxxyyy@dummy.com申し込み種別"
preArray(5)="会員所属支部"
preArray(6)="ロサンゼルス県登録番号"
preArray(7)="00999会員番号"
preArray(8)="10000999"

この格納の様子を見ると,目的の項目の値,例えば「お名前」はpreArray(0)に入ってますが,その値は「お
名前」の入ってる次の配列(preArray(1))に格納されています。つまり項目の値を見るには,配列の
引数+1にすればいいことになります。そこで,あらかじめ予想される項目を入れた配列をもとに,preArray 
の配列のどこに項目があるか検索します。項目の順番を催しによって変更する可能性があるからです。

koumokuArray = Array("お名前", "ご所属", "電話", "メールアドレス", "申し込み種別", "所属支部", "登録番号", "会員番号", "住所", "郵便番号", "参加資格")
For j = LBound(koumokuArray) To UBound(koumokuArray)
 If InStr(preArray(i), koumokuArray(j)) > 0 Then
  nukidasi = preArray(i + 1) '目的の項目の値は +1の配列に格納されている
  koumoku = koumokuArray(j)
  Exit For '見つかった時ループを抜ける
 End If
Next j

検索して該当する引数が見つかったら,引数+1して,項目の値を取得して,一時変数 nukidasi に格納し
ます。同時に検索した項目も,koumoku に格納します。ただ,まだ,nukidasi には,

佐藤太郎ご所属

のように,次番の項目も一緒に格納されいているので,

 For k = LBound(koumokuArray) To UBound(koumokuArray) '余分な項目を除く
  nukidasi = Replace(nukidasi, koumokuArray(k), "")
 Next k

のようにして,該当する項目を削除します。その後,koumoku に応じた外部変数に Select Case にて
記憶します。それぞれのケースでは,「県」「支部」「都」を除く処理や,文字長を制限する処理もしてあり
ます。

Select Case koumoku
  Case "お名前"
    simei = nukidasi
  Case "ご所属"
    syozoku = nukidasi
     If Len(syozoku) > 20 Then
       syozoku = Mid(syozoku, 1, 20)
     End If
  Case "電話"
    denwa = nukidasi
  Case "メールアドレス"
     adoresu = nukidasi
  Case "申し込み種別"
     syubetu = nukidasi
  Case "所属支部"
     sibu = nukidasi
     sibu = Replace(sibu, "支部", "")
     sibu = Replace(sibu, "県", "")
     If sibu <> "京都" Then
      sibu = Replace(sibu, "都", "")
     End If
  Case "登録番号"
    bangou = nukidasi
  Case "会員番号"
    kaiin_bangou = nukidasi
  Case "郵便番号"
    yubin = nukidas
  Case "住所"
    jyuusyo = nukidasi
  Case "参加資格"
    sanka_sikaku = nukidasi
End Select

以上が処理の流れですが,これをサブとして呼び出せるようにしてあります。以下が全文です。


Private Sub mail_koumoku_nukidasi(Honbun As String)
    Dim preArray As Variant
    Dim koumokuArray() As Variant
    Dim buffer, buffer1, nukidasi,koumoku As String
    Dim i, j, k As Integer
    
    '最終項目の後の文字
    buffer1 = "------------------------------------------------------------送信日時"
    '予想される項目
    koumokuArray = Array("お名前", "ご所属", "電話", "メールアドレス", "申し込み種別", "所属支部", "登録番号", "会員番号", "住所", "郵便番号", "参加資格")
  
    '本文前処理
    buffer = Mid(Honbun, InStr(Honbun, "お名前="))              '「お名前=」以前の項目を消す
    buffer = Left(buffer, InStr(buffer, buffer1) - 1)           '最終項目以下を消す
    buffer = Replace(buffer, "ご所属先電話", "電話")            '「ご所属」と「ご所属先電話」検索で区別が付かないので,置き換え
    
    preArray = Split(buffer, "=")                              '"="を区切りで分割
     
    For i = LBound(preArray) To UBound(preArray) - 1
       For j = LBound(koumokuArray) To UBound(koumokuArray)
        If InStr(preArray(i), koumokuArray(j)) > 0 Then
                    nukidasi = preArray(i + 1)                    '目的の項目は +1の配列に格納されている
                    koumoku = koumokuArray(j)          '項目の保持
                    Exit For                                      '見つかった時ループを抜ける
           Exit For
        End If
       Next j
       
       For k = LBound(koumokuArray) To UBound(koumokuArray)        '余分な項目を除く
            nukidasi = Replace(nukidasi, koumokuArray(k), "")
       Next k
        '項目に応じた変数に格納する
        Select Case koumoku
            Case "お名前"
                simei = nukidasi
            Case "ご所属"
                syozoku = nukidasi
                If Len(syozoku) > 20 Then
                    syozoku = Mid(syozoku, 1, 20)
                End If
            Case "電話"
                denwa = nukidasi
            Case "メールアドレス"
                adoresu = nukidasi
            Case "申し込み種別"
                syubetu = nukidasi
            Case "所属支部"
                sibu = nukidasi
                sibu = Replace(sibu, "支部", "")
                sibu = Replace(sibu, "県", "")
                If sibu <> "京都" Then
                    sibu = Replace(sibu, "都", "")
                End If
            Case "登録番号"
                bangou = nukidasi
            Case "会員番号"
                kaiin_bangou = nukidasi
            Case "郵便番号"
                yubin = nukidas
            Case "住所"
                jyuusyo = nukidasi
            Case "参加資格"
                sanka_sikaku = nukidasi
        End Select
        
    Next i
    
End Sub

自分なりに作成しましたが,きっと,もっとうまい方法があるんでしょうね。