エクセルー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 をつけて,(該当しない条件にする)この方が,いいかもですね。

楽天市場ーーお気に入り店ーーー偽サイト(危険)

久しぶりに,アルミ板を購入しようと思い,楽天市場の「秘密基地」を検索。残念ながら,削除されてしまっ
たようです。ついでに,登録済みのお気に入り店を見てみると,結構削除されているお店があります。楽天か
から撤退したのか,それとも倒産したのかは分かりませんが,時とともに当たり前ですが変化するんですね。

久しぶりに楽天にアクセスするのに,検索でトップにきた URL をクリックしたら,

の画面にでくわしました。
消しても消しても出てくる,しつこいサイトです。初めての方は面食らうでしょうね。このHPを消すには,
ブラウザを停止するしかないので,慌てず,

 Ctrl+Alt+Delte

で,タスクマネージャをたち上げ,該当するブラウザを右クリック,出てくる画面で「停止」をクリックして
ブラウザを停止してしまえばOKです。引っかかる方いるんでしょうね。年のために,ウイルススキャンを
をして終了ですね。このサイトは,表示されているURLと実際のURLがちがうようです,ここをクリック
すると,下記にジャンプさせられるようです。間違っても,下記のURLにアクセスしないでくださいね。

https://app8kkk06.z13.web.core.windows.net/werrx01USAHTML/index.html?bcda=(0101)-20298-84253&gclid=CjwKCAjw6c63BhAiEiwAF0EH1Ba0MvwIQKA9k6_cjoRx1_m6Reut0B7BtLAa3GJD8JJDOUMzBQhj_hoCc6AQAvD_BwE&id=5

明らかに楽天のアイコンとは違うアイコンが表示されるので,要注意ですね。
下記の写真の上の「楽天」が偽物で,表示は,正式な楽天の URL ですが,楽天の上にマウスをのせると
全く違うURLがしめされるのですが。

注意喚起が必要ですね。

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 のアカウント内で作成
した「アプリパスワード」が必要なようです。

マキタ(Makita) 充電式スプリット草刈機 MUX18DZ+A-53089 +A-71744

芝刈りをするのに,必要な道具をそろえましたが,今年は,思い切って,マキタのマキタ(Makita) 充電式スプ
リット草刈機を使い始めました。
一式を買うのではなく,表題の三つの型番のものを,安いところさがして,別々に購入しました。

この刈り払い機は,全体を刈るのではなく,際刈りに使ってます。あれこれ,試しましたが,これが一番いい
ようです。ただ,先端には,山善 草刈機用 替え刃 マジカルカッター MC-200 をつけています。これは,前に
使ってた日立工機(差し込み式ナイロンコード)の同型のものの後釜です。

https://www.amazon.co.jp/gp/product/B00WQBK1TQ/ref=ppx_yo_dt_b_asin_title_o05_s00?ie=UTF8&psc=1

下に円盤のないナイロンコードだと,切りすぎる心配がありますが,円盤がついているので,ある程度加減が
できます。この刈り払い機を使うに当たって,純正のバッテリーと充電器,サードパーティーの電池を充電器
をそろえました。

純正のバッテリー一個では,心許なかったのでの購入ですが,さすが,純正のものをそろえられませんでし
た。サードパーティのものは,純正の1/4程度で購入できます。ただ,サードバーティーのものは,刈り
払い機には,無理無理つけるようになるので,アダプターも購入しました。

マキタ(Makita) バッテリアダプタBAP18E A-72067

サードパーティーのものは,純正のものより,厚みがあるので,次の写真の赤の矢印の幅がぎりぎりで,無理
矢理押し込むようになるためです。

ちなみにサードパーティのバッテリーは,評判のいい,waitley のものですが,純正の充電器は,急速充
なので,充電器も併せて購入した訳です。

バッテリーの刈り払い機は,その目的が際刈りなので,長い時間使うわけではないので,充電さえしておけ
ば,エンジンのものと違ってお手軽に使えます。

エクセル 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,記録する列番号,記録する行番号)

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

芝刈りーー今年第19回目

少し間があきましたが,今年19回目の芝刈りです。今日は,始まったののおそかったので,暗くなってきた
ので途中で終わりにしました。また明日続きです。
撮影では,自動で,フラッシュがたかれました。ピントも合っていませんね。遠くが暗く見えます。

ある資格更新ーーー手数料

本日,ある資格の資格更新の手続きをしました。高いのでびっくり。

更新手数料   19,800円
振り込み手数料    203円
証明写真費用   1,000円
返信用葉書切手     85円
書類送付費用     490円
合計      21,578円

資格は5年間有効ですが,きっと,また,値上がりしているんでしょうね。
    

エクセル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

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

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

お仕事お手伝いの関係で,引き続きVBAをいじってます。

ある催しの受付処理をするのにHPのスクリプトから送られてくるメールを半自動で処理しています。処理に
は,エクセルのVBAを使ってます。次のようなメールが送られてきます。

〓このメールは自動送信でお送りしています。
以下のとおりフォームメールより送信がありました。
————————————————————
▼送信内容
————————————————————
お名前 = 佐藤太郎
ご所属 = 自宅
ご所属先電話 = 00000000000
メールアドレス = xxxyyy@dummy.com
申し込み種別 = 会員
所属支部 = ロサンゼルス県
登録番号 = 00999
会員番号 = 10000999
————————————————————
送信日時 : 2024/09/28(Sat) 19:22:00

このメールから,VBAで,お名前等に該当する佐藤太郎等を切り出し,エクセルの一覧表にしていました。
各項目を取り出しをするのに,次のようにしていました。

simei = Mid(Honbun, InStr(Honbun, "お名前=") + 4, InStr(Honbun, "ご所属=") - InStr(Honbun, "お名前=") - 4)

前処理で,空白と改行を除いたメール文面を Honbun に文字列として取り込み,該当する項目と次の項目
ではさむようにして目的のものをとりだしてました。
送られてくるメールの項目の順番や項目が同じならいいのですが,今回のように,項目の順番が変わってし
まうと,VBAのプロシャージャの方も変更しなくてはいけません。
そこで,メールの項目・順番が変わってもも,プロシャージャを変更しなくてもいいようにできないかとあ
れこれ,なやんでました。
昨日あれこれ悩んで,検索して,たどりついて解決にむすびついた,Split を使ってできそうなアルゴリズ
ム(そんな大それたものではないのですが・・・),手順をおもいつきましたので,備忘録がてら,まとめ
ておきたいと思います。

エクセルVBA-エラー処理

プログラムを作り始めて何年になるでしょうかね。就職して,2年目からですから,結構な年月になります。
当時は,PCのはじめで,やりたいことのほとんどは,BASIC と呼ばれる言語で,自作しないといけませんでし
た。そのうち,MS-DOS上で動くマルチプランやらwindoesで動くロータス123等がでてきました。確か,
ロータス123は,当時68000円か78000円ぐらいしたと記憶していました。おまけに,123は,
プロテクトがかけられていて,バックアップができませんでした。その後,コピーツール等がでてきて,バッ
クアップはできるようになりました。
それにしても,高かったです。ただ,自分でもプログラムを作ってましたので,それが作成されるまでの労力
を考えると,決して高くないと思ってました。素人の自分が作るプログラムと,その高いプログラムはどこが
ちがうのでしょうか。もちろん完成度もあるのですが,素人とプロでは,エラー処理が格段に違います。プロ
は,考えるすべてのエラー処理をしていますが,素人の私が作るものは,動けばいい,というレベルのもので
す。
ただ,作るにあたっては,最低限の処理が必要になります。たとえは今,仕事のお手伝い関係で自作している
エクセルvbaのサーチのプロシャージャ(プログラム)でも,目的の項目がサーチできなかった時は,どうす
るかの処理ぐらいは必要になってきます。
そんな訳でエラーの時に,

XFD1048576

を返すものを作りました。この数字はなにかというと,
エクセルの表の最右列・最下段のセルということで,一番端っこのセルの番地を表す数字です。なぜ,この
この数字を使ったのかと言うと,昔BASICでプログラムをくんでいた時のなごりで,エラー処理に普段
出てこない,9999とか言う数字を使った名残です。(確か何年構えに2000年問題ということで,
話題になりましたね。これも。エラー処理に1999という数字を使っていて,ためですね)
ところが,デバックしているときにまたまた,はまりました。わざとエラーを起こしても,XFDが返って
こないのです。返ってくるのは,16384という数字が返ってきてしまいます。あれこれやりましたが,
肝心なこと忘れてました。使ったのは,Column というプロパティですが,当たり前ですが,このプロパテ
ィは,数字を返すものでした。ネット検索で,

Split(Columns(列番号).Address, “$”)(2)

のようにやって,やっと目的のXFDが返ってきました。長かったです。

下記がXFD1048576を返す,関数です,といってもぱくりです。

Public Function Search(ByVal rng As Range, ByVal keyWord As Variant, ByVal Whole As Boolean)
   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")←←エラー処理です。
            
End Function

デバックに使ったプロシャージャです。

MsgBox Split(Columns(Search(rng, "******", True).Column).Address, "$")(2)