SeleniumVBAでGoogle和英訳

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function SetForegroundWindow Lib "user32" ( _
        ByVal hwnd As LongPtr) As Long
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function SetForegroundWindow Lib "user32" ( _
        ByVal hwnd As Long) As Long
#End If

Sub Honyaku()                   '20250321更新
                                '570文字など日本語が半数以下の場合は和文以外と見なされ、和訳のままになってしまう
                                '未だ同じ文章が出るのと、フリーズで動かなくなる場合あり０４０２
                                
    Dim driver As SeleniumVBA.WebDriver
    Dim mngr As SeleniumVBA.WebDriverManager
    Dim keys As SeleniumVBA.WebKeyboard
    Dim keySeq As String
    Dim rlt As String
    Dim timer As Long
    '英訳の場合true
    Dim flag As Boolean: flag = False
    
    Set driver = SeleniumVBA.New_WebDriver
    Set keys = SeleniumVBA.New_WebKeyboard
    Set mngr = SeleniumVBA.New_WebDriverManager
 
   'WebDriverを自動更新するWebDriverManagerクラスを使用する
    mngr.AlignChromeDriverWithBrowser
    
    Dim transrng As Range, rng As Range
     On Error Resume Next
      Set transrng = Application.InputBox("和訳したいセルを選択してください", , , , , , , 8)
      If transrng Is Nothing Then Exit Sub
     On Error GoTo 0
      
    'Edgeを選択してブラウザを開く
    driver.StartEdge
   
    Dim caps As WebCapabilities, invisible As Boolean
    ' invisibleをなくしてもいいように見えるがなくすと画面で出てきてしまう
    driver.OpenBrowser caps, invisible = True
      
    'Google翻訳を開く
    driver.NavigateTo "https://translate.google.com"  '左は英訳　"https://translate.google.com"
    driver.Wait 500
    
    
    
    '訳したい文字列の右に空欄が無ければ訳の欄を作る場合は’を削除
    'If Not IsEmpty(transrng.Offset(, 1)) Then
        transrng.Offset(, 1).Insert xlShiftToRight
    'End If

    Call BringWorkbookToFront
    
    Dim x As Long
    x = 0
    '翻訳文が自動判定され誤判定されるのを回避
    driver.FindElement(By.ID, "i12").Click
    
    For Each rng In transrng
        x = x + 1
    '空欄の場合-を入力
        If Replace(rng.Value, " ", "", , , vbTextCompare) = "" Then
            rng.Offset(, 1) = "-"
        Else
    
    '改行を削除し訳したい文字列を入力する
        If InStr(rng.Value, vbLf) <> 0 Then
            keySeq = Replace(rng.Value, vbLf, "")
        Else
            keySeq = rng.Value
        End If
        
        'ブラウザにおけるデフォルトの自動検出は和英混合文の場合翻訳ミスが起きるため、
        'ブラウザ上での訳文を英語に設定する
        
        
        
       '文を日本語か判断して英訳ならTrue
        If isJapaneseText(keySeq) Then
            flag = True
            driver.FindElement(By.ID, "i16").Click
        End If
     
    driver.FindElement(By.className, "er8xn").SendKeys keySeq
    
    'JSでやるとDOM直接操作で早く、複雑な操作可能だが、'がある場合誤判定などある為避ける
    'Dim script As String
    'script = "document.getElementsByClassName('er8xn')[0].value = '" & keySeq & "';"
    'driver.ExecuteScript script
    'driver.FindElement(By.className, "er8xn").SendKeys keys.EnterKey
    
    '一文字でも約800は必要
    driver.Wait 1000
    
        'MsgBox driver.FindElement(By.className, "HwtZe").GetText
'文字多いと上の設問の日本語がそのまま来ることあり、
'検索対象の一個前の文章と一致している場合はさらに待つ必要あり


        On Error Resume Next
        rlt = driver.FindElement(By.className, "HwtZe").GetText
            Do While rlt = ""
                'driver.Wait 100
                rlt = driver.FindElement(By.className, "HwtZe").GetText
            Loop
          '  timer = 0
            If Not flag Then
                timer = 0
                Do Until isJapaneseText(rlt) = True Or timer >= 5
                    rlt = driver.FindElement(By.className, "HwtZe").GetText
                    driver.Wait 1000
                    timer = timer + 1
                Loop
            End If
            
'           MsgBox "訳文: " & rlt & vbCr & _
'            "前回の翻訳文: " & rng.Offset(-1).Value & vbCr & _
'            "前回翻訳: " & rng.Offset(-1, 1).Value

            
            'If rlt = rng.Offset(-1, 1).Value Then MsgBox "訳文が前回と同じ"
            'If rlt = rlt = rng.Offset(-1).Value Then MsgBox "訳対象文が転記されている"
            
            If x >= 2 Then
                timer = 0
                'ラグにより、前回の翻訳と同じまま、前回の翻訳対象分が適されること回避
                If rlt = rng.Offset(-1, 1).Value Or rlt = rng.Offset(-1).Value Then
                    Do While rlt = rng.Offset(-1, 1) Or rlt = rng.Offset(-1).Value
                        rlt = driver.FindElement(By.className, "HwtZe").GetText
                        driver.Wait 2000
                        timer = timer + 1
                        If timer >= 5 Then
                            Exit Do
                        End If
                    Loop
                End If
            End If
            
            
        On Error GoTo 0
        
        rng.Offset(, 1) = rlt
        rng.Offset(, 1).WrapText = False
        'rng.Offset(, 1).WrapText = True
         
        
        If InStr(rng.Offset(, 1).Value, vbCrLf) <> 0 Then
            rng.Offset(, 1) = Replace(rng.Offset(, 1), vbCrLf, "")
        End If
        
        If flag Then
            flag = False
            driver.FindElement(By.ID, "i15").Click
        End If
        'JSで入力していない事で訳文が残ったままになる為、削除する
        driver.ExecuteScript "document.getElementsByClassName('er8xn')[0].value = '';"
    End If
    
Next
    
    MsgBox "完了しました"
    
    
End Sub


Sub BringWorkbookToFront()
    Dim hwnd As LongPtr
    Dim wb As Workbook

    ' 対象のワークブック
    Set wb = ActiveWorkbook

    ' ウィンドウハンドルを取得
    hwnd = FindWindow("XLMAIN", Application.caption)
    If hwnd = 0 Then
        MsgBox "ウィンドウハンドルが見つかりません。", vbCritical
        Exit Sub
    End If

    ' ワークブックを最前面に移動
    SetForegroundWindow hwnd
End Sub

Option Explicit

Function isJapaneseText(inputText As String) As Boolean

    ' 日本語の文字をカウントする
    Dim japaneseCount As Integer
    japaneseCount = CountJapaneseCharacters(inputText)
    
    ' 文字列全体の長さを取得
    Dim totalLength As Integer
    totalLength = Len(inputText)
    
    ' 日本語の文字が50%以上を占めているか確認
    If totalLength > 0 And (japaneseCount / totalLength) >= 0.5 Then
        isJapaneseText = True
    Else
        isJapaneseText = False
    End If
End Function

' 日本語の文字をカウントする関数
Function CountJapaneseCharacters(inputText As String) As Integer

    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    ' ひらがな、全角カタカナ、半角カタカナ、日本語の漢字、句読点（。、）を含める
    regex.Pattern = "[\u3040-\u309F\u30A0-\u30FF\uFF61-\uFF9F\u4E00-\u9FFF々〆?、。]"
    regex.IgnoreCase = True
    regex.Global = True
    
    ' 一致する文字をカウントして返す
    Dim matches As Object
    Set matches = regex.execute(inputText)
    CountJapaneseCharacters = matches.Count
End Function