'References required
'Microsoft HTML Object Library
'Microsoft Internet Controls
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Public Sub Convert_Japanese_Words()
With ThisWorkbook.ActiveSheet
Selection.Value = Convert_Word(ActiveCell.Text)
End With
End Sub
Public Function Convert_Word(word As String) As String
Dim URL As String
Dim IE As InternetExplorer
Dim HTMLdoc As HTMLDocument
Dim button As HTMLButtonElement
Dim textInput As HTMLTextAreaElement
Dim katakanaCheckbox As HTMLInputElement
Dim resultText As HTMLDivElement
Dim timeout As Date
URL = "https://www.jcinfo.net/ja/tools/kana"
Set IE = Get_IE_Window(URL)
If IE Is Nothing Then Set IE = Get_IE_Window("")
If IE Is Nothing Then
Set IE = New InternetExplorer
IE.Visible = True
IE.navigate URL
While IE.Busy: DoEvents: Sleep 20: Wend
Set HTMLdoc = IE.document
'Click cookies Consent button, if present
'<button class="fc-button fc-cta-consent fc-primary-button" role="button" aria-label="Consent" tabindex="0">
' <div class="fc-button-background"></div>
' <p class="fc-button-label">Consent</p>
'</button>
timeout = DateAdd("s", 5, Now)
On Error Resume Next
Do
Set button = HTMLdoc.querySelector("button.fc-button.fc-cta-consent.fc-primary-button")
DoEvents
Sleep 20
Loop While button Is Nothing And Now <= timeout
On Error GoTo 0
If Not button Is Nothing Then button.Click
End If
Set HTMLdoc = IE.document
'Put word in text area
'<textarea name="text" id="input_text" placeholder="?????????????" lang="ja" class="form-control">??????</textarea>
Set textInput = HTMLdoc.getElementById("input_text")
textInput.Value = word
'Ensure the 'Include katakana' checkbox is ticked
'<div class="custom-control custom-checkbox">
' <input id="is_katakana" class="custom-control-input" name="is_katakana" type="checkbox" value="1">
' <label class="custom-control-label" for="is_katakana" id="is_katakana">
' ????????
' </label>
'</div>
Set katakanaCheckbox = HTMLdoc.getElementById("is_katakana")
If Not katakanaCheckbox.Checked Then katakanaCheckbox.Click
'Click the 'Furigana conversion" button
'<button type="submit" class="btn btn-primary">??????</button>
Set button = HTMLdoc.querySelector("button.btn.btn-primary")
button.Click
While IE.Busy: DoEvents: Sleep 20: Wend
While HTMLdoc.readyState = "loading": DoEvents: Sleep 20: Wend
'Extract result from 3rd text box
'<div class="_result my-5 p-2" lang="ja">
' <div class="line">
' <span class="morpheme">?</span>
' <span class="morpheme">?</span>
' <span class="morpheme">?</span>
' <span class="morpheme">?</span>
' </div>
'</div>
Dim results As IHTMLDOMChildrenCollection
Do
Set results = HTMLdoc.querySelectorAll("div._result.my-5.p-2")
If HTMLdoc.querySelectorAll("div._result.my-5.p-2") = Error Then
Convert_Word = MsgBox Msg & Msg = "error"
End If
DoEvents
Sleep 20
Loop Until results.Length = 3
Convert_Word = results(2).innerText
End Function
Private Function Get_IE_Window(partialURLorName As String) As InternetExplorer
'Look for an IE browser window or tab already open at the (partial) URL or location name and, if found, return
'that browser as an InternetExplorer object. Otherwise return Nothing
Dim Shell As Object
Dim IE As InternetExplorer
Dim i As Variant 'Must be a Variant to index Shell.Windows.Item() array
Set Shell = CreateObject("Shell.Application")
i = 0
Set Get_IE_Window = Nothing
While i < Shell.Windows.Count And Get_IE_Window Is Nothing
Set IE = Shell.Windows.Item(i)
If Not IE Is Nothing Then
If IE.Name = "Internet Explorer" And InStr(IE.LocationURL, "file://") <> 1 Then
If InStr(1, IE.LocationURL, partialURLorName, vbTextCompare) > 0 Or InStr(1, IE.LocationName, partialURLorName, vbTextCompare) > 0 Then
Set Get_IE_Window = IE
End If
End If
End If
i = i + 1
Wend
End Function
