THB-260PFS タナカ エンジンブロアー整備 (2)

三日ほどガソリン漬けにしたキャブレターですが,念のため,いいか悪いかはわかりませんが,シリンジで強
制的にガソリンを送りこんでみました。結果,やっとガソリンを吸い上げるようになりました。

やはりどこかにつまりがあったのでしょうね。新しいキャブと交換済みなので,ガソリンを吸い上げるように
なった,もとももとのキャブは,補修部品として,保管しておきます。

THB-260PFS タナカ エンジンブロアー整備

久しぶりにエンジンブロアーを使おうとおもったら,プライマリポンプが破損,写真のようにして交換し
ました。


が,しかし,燃料を吸い上げてくれません。そこで,ダイヤフラム等も新品に交換しましたが,それでも
だめで,キャブレターを〇Zonで購入。walbro の WYJ タイプの互換機でしょうかね,交換しました。
今までついていたキャブレターは,できれば使いたいので,どこか詰まってるところがあるようですので
しばし,ガソリン漬けにしすることにしました。しばらくおいて,キャブクリーナーで再び洗浄して,再
度トライして見る予定です。

ウエアラブルカメラ(アクションカメラ) HX-A100 (2)

このカメラの欠点?は,設定や操作は,スマホからすることでしょうか。操作するにあたって,wifyで本体に
接続する必要がありますが,最初は,接続ができませんでした。もしかして,接続に必要なSSIDとパスワ
ードが変更されていたのかもしれません。そこで,本体のリセットをして,設定を初期値にもどしました。
何度かリセットして,やっと接続できましたが,操作をするとすぐ電源がきれてしまいます。キッと,主な
電源は,バッテリーからの供給なためなのでしょうかね。しばらく充電をしてやると,USBからの供給だ
けで,設定等できるようになりました。自身を撮影してみましたが,画質も結構いいようです。

ウエアラブルカメラ(アクションカメラ) HX-A100

ウエアラブルカメラ(アクションカメラ)がほしくなって,いろいろ検討してました。もちろん,人気の
ゴープロ等は買えないので前から気になっていたパナソニックの HX-A100 をヤフオクで購入しました。
すでに製造中止で,今日届いた物の製造は2013年となっていましたから11年も前のものですね。
不動品(充電できない)ということで,送料込みで3210円で購入しました。多分,バッテリーがだめでの
不動品だろうと言う予想のもと,あれこれやりました。結果,予想通りで,バッテリーに充電できないもの
の,動画・写真の撮影等,問題なくできました。バッテリーを交換の予定ですが,バッテリーは,3783円
と,本体より高くなりました。

バッテリー交換の手順をネットで検索しましたが,取り外し方が,DL した取説に載っていましたので,それ
ほど苦労しないで大丈夫のようです。

今年20回目の芝刈り。ならぬ,サッチとり。

成長が大分落ち着いてきたので,サッチ取りを始めました。専用のレーキで始まりましたがらちがあかないの
でサッチと利用にした芝刈り機でやります。刈った芝を受け止める袋は,すぐいっぱいになって,過剰負荷に
なってすぐしばかりが止まってしまうので袋をつけずサッチをかきだして,竹の熊手て集めています。体力を
使うので一度にはできないので,毎日少しずつやってます。一回やると,ゴミ袋いっぱいサッチがとれます。

条件付き書式を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 をつけて,(該当しない条件にする)この方が,いいかもですね。

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

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

久しぶりに楽天にアクセスするのに,検索でトップにきた 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 のアカウント内で作成
した「アプリパスワード」が必要なようです。