パソコンを使い始めるときに、
ネットがおかしくないかチェックするために
インターネットの回線速度を毎回調べています。
自動的にできると良いと思い、
サイトAの方法
（BNRスピードテストの画像読み込み版をVBAのIEオブジェクトで読み取る）
を使っていましたが、
JavaScript版のほうが速度が大きめに出るので
（よい値が出た方が気分が良いので）
これの値を読み取れないか、方法を探しました。
サイトBのようにGNU Wgetというダウンローダーを利用する方法
もあるようですが、これは別途試すとして、
BNRスピードテストの結果が取得したい。
Seleniumも試しましたが、いまひとつ動作がおかしい。
使い方が悪いのかもしれませんが、すっきりしません。
仕方がないので、以下のような手順でごまかす（お茶を濁す）ことにしました。
１．BNRスピードテストを起動するマクロ（WEB起動）
２．マニュアルでスピードテストをする
３．画面のテキストを全選択し全コピー（Ctrl+A, Ctrl+C）
４．テキストデータから測定結果を抜き出すマクロ(WEBデータ取得)
これならあたしにでも作れます。
マクロは以下です（下のほう）。
マクロ「WEBデータ取得」では、
クリップボードの内容を取得して
正規表現で対象部分を抜き出して
返すようにしています。
この方法は、やり方としては全自動ではないので格好悪いですが
WEBからデータをとりあえず取得したい場合に汎用的に使えます。
BNRスピードテスト
サイトA（BNRスピードテストの画像読み込み版をVBAのIEオブジェクトで読み取る）
サイトB（速度測定用ツールwgetを使う）
Seleniumの使用例
Public Sub WEB起動()
Dim wsh As IWshRuntimeLibrary.WshShell
Set wsh = New IWshRuntimeLibrary.WshShell
wsh.Run "https://www.musen-lan.com/speed/", 3
Set wsh = Nothing
End Sub
Public Sub WEBデータ取得()
Const Title = "測定日時,ダウンロード(Mbps),測定日時,アップロード(Mbps)"
'タイトルを書く（書き直す）
Dim buff As Variant
buff = Split(Title, ",")
Cells(1, 1).Resize(1, UBound(buff) - LBound(buff) + 1) = buff
'最下行に今回のデータを追加する
Dim cl As Range
Set cl = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
'測定結果を取得してシートに書き込む
Dim result As Variant
result = GetDataTransferSpeed
cl.Resize(1, UBound(result) - LBound(result) + 1) = result
Set cl = Nothing
End Sub
Private Function GetDataTransferSpeed() As Variant
Const PatTitle = "BNRスピードテスト \([^\)]+\)"
Const PatDate = "測定日時： ([0-9年月日]+)\S+\s+([0-9時分秒]+)"
Const PatSpd = "データ転送速度：\s([0-9\.]+)Mbps"
Dim deltaFI As Variant
deltaFI = Array(90, 250) 'タイトルからの検出位置の差。これ以内で探す。
'Webのテキストを取得する
Dim buff As Variant
buff = getClipboardText()
If buff = vbNullString Then
MsgBox "結果をクリップボードにコピーしておいてください。", vbExclamation
Exit Function
End If
'テキストからパターンに合う部分を抜き出す
Dim re As New RegExp, mchsTitle As MatchCollection
Dim mchsDate As MatchCollection, mchsSpd As MatchCollection
With re
.Global = True
.Pattern = PatTitle
Set mchsTitle = .Execute(buff)
.Pattern = PatDate
Set mchsDate = .Execute(buff)
.Pattern = PatSpd
Set mchsSpd = .Execute(buff)
End With
'抜き出したデータを位置関係からダウンロードとアップロードに区別する
Dim fiTitle(0 To 1) As Variant
Dim DwUp(0 To 1) As Variant
Dim DtTm(0 To 1) As Date
Dim Spd(0 To 1) As Double
'ダウンロードとアップロードの2か所だけが見つかる前提
Dim i As Long, j As Long
For i = 0 To mchsTitle.Count - 1 'データの基準になる位置を取得
DwUp(i) = mchsTitle(i)
fiTitle(i) = mchsTitle(i).FirstIndex
Next
For i = 0 To mchsTitle.Count - 1
For j = 0 To mchsDate.Count - 1 '測定日時を取得
If fiTitle(i) + deltaFI(0) > mchsDate(j).FirstIndex And _
mchsDate(j).FirstIndex > fiTitle(i) Then
DtTm(i) = CDate(mchsDate(j).submatches(0) & " " & mchsDate(j).submatches(1))
Exit For
End If
Next
For j = 0 To mchsSpd.Count - 1 'データ転送速度を取得
If fiTitle(i) + deltaFI(1) > mchsSpd(j).FirstIndex And _
mchsSpd(j).FirstIndex > fiTitle(i) Then
Spd(i) = CDbl(mchsSpd(j).submatches(0))
Exit For
End If
Next
Next
Dim result(0 To 3) As Variant
For i = 0 To 1
result(2 * i + 0) = DtTm(i)
result(2 * i + 1) = Spd(i)
Next
' Dim result(0 To 1, 0 To 2) As Variant
' For i = 0 To 1
' result(i, 0) = DwUp(i)
' result(i, 1) = DtTm(i)
' result(i, 2) = Spd(i)
' Next
GetDataTransferSpeed = result
Set re = Nothing
Set mchsTitle = Nothing
Set mchsDate = Nothing
Set mchsSpd = Nothing
End Function
Function getClipboardText() As Variant
Dim objCB As MSForms.DataObject
Set objCB = New MSForms.DataObject
Dim ClipBoardFormats As Variant, cbf As Variant
ClipBoardFormats = Application.ClipBoardFormats
Dim res As Variant
res = vbNullString
For Each cbf In ClipBoardFormats
If cbf = xlClipboardFormatText Then
With objCB
.GetFromClipboard ''クリップボードからDataObjectにデータを取得する
res = .GetText ''DataObjectのデータを変数に取得する
Exit For
End With
End If
Next
getClipboardText = res
Set objCB = Nothing
End Function