前回、なろう小説を対象に自動読上げマクロを作成しましたが、今回はカクヨムも対象に改造しました。
前回作成したマクロを下記の通り改良しました。（赤字部分）
================================
Dim gEndFlg As Boolean
'本機能を利用するには棒読みちゃんがインストールされている必要があります
Sub m_読上げ開始()
Dim ie As Object
Dim oCs As Object
Dim oCs1 As Object
Dim lRow As Integer
Dim lTimer As String
Dim lNextFlg As Boolean
'初期処理
If Range("B1").Value = "" Then
MsgBox "棒読みちゃんURLを設定してください"
GoTo p_end
End If
If Range("B3").Value = "" And Range("B4").Value = "" Then
MsgBox "開始ＵＲＬか前回ＵＲＬどちらか一方あるいは両方を設定してください"
GoTo p_end
End If
If Range("B5").Value = "" And ActiveSheet.CheckBoxes("chk1").Value = xlOn Then
MsgBox "次回URLが設定されている必要があります。"
GoTo p_end
End If
gEndFlg = False
'棒読みちゃん起動確認
rtn = Shell(Range("B1").Value, vbNormalNoFocus)
lSt = Now()
lEdt = DateAdd("s", 10, Now())
Do While lSt > Now()
DoEvents
Loop
'URL表示
ThisWorkbook.Activate
If Range("B3").Value <> "" Then url = Range("B3").Value
If Range("B4").Value <> "" Then
url = Range("B4").Value
Range("B3").Value = url
End If
If ActiveSheet.CheckBoxes("chk1").Value = xlOn Then
url = Range("B5").Value
Range("B3").Value = url
End If
Set ie = CreateObject("internetexplorer.application")
ie.Visible = True
ie.navigate url
Do While ie.busy And ie.readyState <> 4
DoEvents
Loop
'繰返し
lCnt = Range("B6").Value
If lCnt = "" Then lCnt = 99999
For i = 1 To lCnt
If url Like "*kakuyomu*" Then
'メイン処理
GoSub p_exec2
Else
'メイン処理
GoSub p_exec
End If
If lNextFlg = False Then Exit For
Next
Range("B5").Value = ie.locationurl
Application.CutCopyMode = False
ie.Quit
p_end:
Set ie = Nothing
Set oCs = Nothing
Set oCs1 = Nothing
Exit Sub
'-------------------------------------------------------------------------
p_exec:
・・・
割愛
・・・
'-------------------------------------------------------------------------
p_exec2:
'メイン処理
On Error Resume Next
ie.document.Charset = "shift_jis"
lRow = 20 '本文設定開始行
oWs.Range("B4").Value = ie.locationurl
'初期処理
lMaxRow = oWs.Cells(65000, "A").End(xlUp).Row
If lMaxRow < lRow Then lMaxRow = lRow
oWs.Range("A" & lRow & ":" & "A" & lMaxRow).ClearContents
'サブタイトル取得
For Each oCs1 In ie.document.getElementsByclassName("widget-episodeTitle js-vertical-composition-item")
oWs.Cells(lRow, 1).Value = oCs1.outerText & "……"
oWs.Cells(lRow, 1).Activate
lEdt = DateAdd("s", 15, Now())
Do While lEdt > Now()
DoEvents
Loop
oWs.Cells(lRow, 1).Copy
lRow = lRow + 1
Exit For
Next
'本文取得
Set oCsl = ie.document.getElementsByclassName("widget-episodeBody js-episode-body")
ltxt = oCsl.Item.outerText
ltxt = Replace(ltxt, vbLf, "｜")
ltxt = Replace(ltxt, vbCr, "｜")
ltxt = Replace(ltxt, vbCrLf, "｜")
larr = Split(ltxt, "｜")
For Each oAl In larr
If gEndFlg = True Then lNextFlg = False: Return
If oAl <> "" Then
oAl = oAl & "……"
lTimer = "00:00:" & (Len(oAl) / 3.9) \ 2
oWs.Cells(lRow, 1).Value = oAl
oWs.Cells(lRow, 1).Copy
lRow = lRow + 1
lSt = Now()
Do While lTime < lSt + TimeValue(lTimer)
lTime = Now()
DoEvents
Loop
End If
Next
'「次のエピソード」取得
lNextFlg = False
For Each oTg In ie.document.GetElementsByTagname("A")
If oTg.outerText Like "*" & "次のエピソード" & "*" Then
lNextFlg = True
oTg.Click
lEdt = DateAdd("s", 20, Now())
Do While ie.busy Or ie.readyState <> 4
DoEvents
If lEdt < Now() Then Exit Do
Loop
Exit For
End If
Next
On Error GoTo 0
Return
End Sub
================================
その２のp_execをコピーしてほぼ流用できました。
ClassNameが違うくらいの差でしかありません。
～なろう小説自動読み上げマクロシリーズ～
その１ 概略
その２ マクロ
その３ カクヨムに対応 ←本ページ
その４ 自動スクロールに対応
その５ 連続実行