2028中学受験(女子)

2028年 中学受験を目指す女子のパパのブログです。

中学受験、学校所要時間ツール(コード公開)

先日のブログ

girl.chugakujuken-challenge.work

に書いていた、

偏差値表、地図またはリストから学校名をクリック

最寄り駅から学校までの所要時間、および登校時刻を抽出

目的地と到着時刻をYahoo乗換に転送して検索し、学校までの合計所要時間を表示

乗換時間をゆっくりにしたり、登校時刻にオフセット(何分前)を指定して再検索

ですが、Generative AIであるCodeiumでのコード開発と公開はしないことにしました。

期待されてた方(居ないと思いますが・・・)には申し訳ございません。

なぜかというと、以下のように思ったからです。

Codeiumにコード生成させるため、コメントを送信する

コードが生成される→デバッグする→コメントを追加して洗練させていく

コードや生成プロセスのログがCodeium側に残る

ブログでコードを紹介すると、Codeium側の機械学習でこのブログにヒットする可能性が出る

Codeiumがこのブログにたどり着くと、Codeiumアカウント情報と紐づけできる

Codeium自身、あるいはCodeium利用者が”名寄せ”によって私にたどり着ける

という可能性を考えました。考えすぎかもしれませんが、まだちょっと怖いですね。

 

そのようなわけで生成AIではなく、私が手を加えたごくありふれたコードで公開します。

美しさは・・・ありません😓

 

VBAのコマンドボタンクリック関数にコピーするコードは以下の通りです。

'--------------------------------------------------------------------------------------

    '一括検索モードかどうかを判断
    Dim mode, brows As String
    mode = Range("e2").Value

    Dim rcnt, init, cur As Long
    Dim actrow, actcol As Integer
    Dim org, sch, dst, via, desttime, offset, prep, hr, min, transit As String
    
    If mode = "有効" Then
        rcnt = Cells(Rows.Count, 1).End(xlUp).Row
        init = 5
        Range("a5").Activate
        Range("f2").Value = "無効"
    Else
        If ActiveCell.Columns.Count <> 1 Or ActiveCell.Rows.Count <> 1 Then
            MsgBox "セルは1つだけ選択して下さい(複数セルは選択できません)", vbExclamation, "エラー"
        End If
        actrow = ActiveCell.Row     'MsgBox actrow, vbOKOnly, ""
        actcol = ActiveCell.Column  'MsgBox actcol, vbOKOnly, ""
        If actrow < 5 Or actcol <> 1 Then
            MsgBox "学校名が書かれているセルを選択してから計算実行して下さい", vbExclamation, "学校選択エラー"
            Exit Sub
        End If
        rcnt = actrow
        init = actrow
    End If

    brows = Range("f2").Value
    If brows = "有効" Then
        MsgBox "Yahoo乗換検索結果(ブラウザ画面)は、" & vbCrLf & "毎回手動で閉じて下さい", vbExclamation, "ブラウザは自動で閉じません"
    End If

    '与えられた条件(駅名、乗換設定など)を抽出する
    org = Range("a2").Value
    If org = "" Then
        MsgBox "出発地が指定されていません", vbExclamation, "エラー"
        Exit Sub
    End If
    
    transit = Range("b2").Value
    Dim traval As String
    Select Case True
        Case transit Like "急いで"
            traval = "1"
        Case transit Like "少し急いで"
            traval = "2"
        Case transit Like "少しゆっくり"
            traval = "3"
        Case transit Like "ゆっくり"
            traval = "4"
    End Select

    prep = Range("d2").Value
    If prep = "" Then
        prep = "0"
    Else
        If Val(prep) > 60 Then
            MsgBox "自宅から最寄り駅までの指定可能時間は0~60分までです", vbExclamation, "自宅~最寄り駅エラー"
            Exit Sub
        End If
    End If
    
    offset = Range("c2").Value
    If offset = "" Then
        offset = "0"
    Else
        If Val(offset) > 60 Then
            MsgBox "到着時刻を早める指定は0~60分までです", vbExclamation, "到着時刻オフセットエラー"
            Exit Sub
        End If
    End If

'ループ処理

    For cur = init To rcnt
    
        actrow = ActiveCell.Row
        actcol = ActiveCell.Column
        
        sch = ActiveCell.Value      'MsgBox sch, vbOKOnly, ""
        If sch = "" Then
            MsgBox "学校名が空欄のセルを選択しています", vbExclamation, "学校選択エラー"
            Exit Sub
        End If
        dst = Cells(actrow, actcol + 1).Value       'MsgBox dst, vbOKOnly, ""
        
        desttime = Cells(actrow, actcol + 5).Text   'MsgBox desttime, vbOKOnly, ""
        
        Dim tt As Variant
        tt = Split(desttime, ":")
        hr = tt(0)
        min = tt(1)
        
        Dim nhr, nmin, noff As Integer
        nmin = Val(min)
        noff = Val(offset)
        If nmin < noff Then
            nmin = nmin + 60 - noff
            min = CStr(nmin)
            nhr = Val(hr)
            nhr = nhr - 1
            hr = CStr(nhr)
        End If
        
        Dim dig1, dig2 As String
        If Len(hr) > 2 Or Len(hr) < 1 Then
            MsgBox "到着時刻の時間指定(時)が不適切です", vbExclamation, "到着時刻の値エラー"
        End If
        If Len(min) > 2 Or Len(min) < 1 Then
            MsgBox "到着時刻の時間指定(分)が不適切です", vbExclamation, "到着時刻の値エラー"
        End If
        If Len(hr) = 1 Then
            hr = "0" & hr
        End If
        If Len(min) = 1 Then
            dig1 = "0"
            dig2 = min
        Else
            dig1 = Left(min, 1)
            dig2 = Right(min, 1)
        End If
'       MsgBox desttime & vbCrLf & hr & "時" & dig1 & dig2 & "分", vbOKOnly, ""
        
'       Chromeを起動する
        Dim drv1 As New Selenium.WebDriver
        drv1.Start "Chrome"
        
        '検索の日付は2023年7月18日に固定。平日(火曜日)だから
        Dim head, mid1, tail As String
        head = "https://transit.yahoo.co.jp/search/result?from="
        mid1 = "&fromgid=&togid=&flatlon=&tlatlon=&via=&viacode=&y=2023&m=07&d=18&hh="
        tail = "&type=4&ticket=ic&expkind=1&userpass=1&ws=" & traval & "&s=0&al=0&shin=0&ex=0&hb=0&lb=1&sr=0"
        
        'Yahoo乗換案内を実行する
        drv1.Get head & org & "&to=" & dst & mid1 & hr & "&m1=" & dig1 & "&m2=" & dig2 & tail
        
        
        Dim restime, leavetime, xpat, commute, alertchk As String
        restime = drv1.FindElementByCss("#rsltlst > li:nth-child(1) > dl > dd > ul > li.time").Text
'        MsgBox drv1.FindElementByCss("#rsltlst > li:nth-child(1) > dl > dd > ul > li.time").Text
        Dim retInStr As Long
        retInStr = InStr(1, restime, "]")   'Yahoo乗換で遅延が発生している場合、[!]が文字列に追加されるため
        If retInStr > 0 Then
'            MsgBox restime, 0, "Original"
            restime = mid(restime, retInStr + 1)
'            MsgBox restime, 0, "Modified"
        End If
        
        xpat = "//*[@id=" & Chr(34) & "route01" & Chr(34) & "]/dl/dd[2]/ul/li[2]/p/a"
        drv1.Wait 100
        drv1.FindElementByXPath(xpat).Click
        drv1.Wait 500   'クリック後にYahoo乗換上のJAVAスクリプト処理が完了するのを待つため
        
        drv1.FindElementByCss("#route01 > dl > dd.option > div.detail.commuterPass > dl > dt > form > select").AsSelect.SelectByValue ("HighSchool,0")
        
        drv1.Wait 500   'クリック後にYahoo乗換上のリストボックス選択が完了するのを待つため
        commute = drv1.FindElementByCss("#route01 > dl > dd.option > div.detail.commuterPass > dl > dd > ul > li:nth-child(3) > span").Text
        drv1.Wait 500
    
        If brows = "有効" Then
            Dim res
            While res <> vbYes
                res = MsgBox("ブラウザを閉じましたか?" & vbCrLf & "(あるいは、ブラウザを閉じていいいですか?" _
                             , vbQuestion + vbYesNo, "ブラウザ終了確認")
            Wend
        End If
        
        drv1.Quit
            
        Dim resvar As Variant
        resvar = Split(restime, "→")
        leavetime = resvar(0)
        Dim ltime, tmpt As Date
        ltime = TimeValue(leavetime & ":00")
        tmpt = DateAdd("n", -1 * Val(prep), ltime)
        leavetime = CDate(tmpt)
        leavetime = Format(leavetime, "hh:mm")
        Cells(actrow, actcol + 6).Value = leavetime
        Cells(actrow, actcol + 7).Value = commute
    '    MsgBox "出発時刻は" & leavetime & "です", 0
    '    MsgBox "6か月定期券代(通学)は" & commute & "です", 0
        
        Cells(actrow + 1, actcol).Activate
    
    Next

    Range("a5").Activate
    ThisWorkbook.Save