Option Explicit
Const vbWq = """"
Const defType = 64
Const pTitle = "Translated"
Const strUrl = "https://translate.google.co.jp/?q="
Const strTagID = "result_box"
Const strLogFile = "Translated.log"
Dim vbWCrLf
vbWCrLf = vbCrLf & vbCrLf
Dim My, MySh, Parameters, xmlHTTP, Fs, objSMTP, objMx
Public objIE
Set My = WScript
With My
Set Parameters = .Arguments
If Parameters.Count <= 0 Then
Parameters = Array(InputBox ( _
"TrenslateStrings" & vbWCrLf & "英訳したい文字列>e" & vbCrLf & " or" &_
vbCrLf & "String you want to Japanese translation>j", pTitle))
If Parameters(0) = "" Then
.Quit
End If
End If
Set MySh = .CreateObject("WScript.Shell")
Set xmlHTTP = .CreateObject("Msxml2.ServerxmlHTTP.6.0")
Set Fs = .CreateObject("Scripting.FileSystemObject")
Set objMx = .CreateObject("MSXML2.xmlHTTP")
Set objIE = .CreateObject("InternetExplorer.Application")
End With
Public sRoot, UserProf, fnDocuments
UserProf = MySh.ExpandEnvironmentStrings("%UserProfile%")
fnDocuments = Fs.BuildPath(UserProf, "Documents")
Dim flgTr, strFlg, strSource, encSource, encURL, strResult
On Error Resume Next
flgTr = Array("","")
strFlg = Right(Trim(Parameters(0)), 2)
If LCase(strFlg) =">j" Then
flgTr = Array("#en/ja/", strFlg)
ElseIf LCase(strFlg) = ">e" Then
flgTr = Array("#ja/en/", strFlg)
End If
If flgTr(0) = "" Then
flgTr(0) = 16
strResult = "Nothing - FlagKeys"
Else
strSource = Replace(Parameters(0), flgTr(1), "")
If LCase(flgTr(1)) = ">e" Then
encSource = sEncoder(strSource, "shift_jis", "utf-8")
Else
encSource = Replace(LCase(strSource), " ", "%20")
End If
encURL = strUrl & encSource & flgTr(0) & encSource
If nSightLoader(encURL, strTagID, strResult) Then
flgTr(0) = 64
Else
flgTr(0) = 16
strResult = "Can't Connect - GoogleTranslate"
End If
End If
strResult = Replace(strResult,"<span class=" & vbWq & "hps" & vbWq & ">","")
strResult = Replace(strResult,"<span class=" & vbWq & "atn" & vbWq & ">","")
strResult = Replace(strResult,"<span class=" & vbWq & "hps atn" & vbWq & ">","")
strResult = Replace(strResult,"<span>","")
strResult = Replace(strResult,"</span>","")
ClipSet strResult
sLog strLogFile, strResult
MyQuit
Function sLog(fnLog, trStrings)
Dim tgtLog, objTxt
If InStr(fnLog, "\") <=0 Then
tgtLog = Fs.BuildPath(fnDocuments, fnLog)
End If
Set objTxt = Fs.OpenTextFile(tgtLog, 8, True)
My.Sleep 200
objTxt.Write CStr(Now()) & vbTab & trStrings & vbCrLf
objTxt.Close
Set objTxt = Nothing
End Function
Function ClipSet(strTarget)
Dim exClips
exClips = "cmd /c " & vbWq & "echo " & strTarget & "| clip" & vbWq
MySh.Run exClips, 0, False
My.Sleep 300
End Function
Function MyQuit()
Set objIE = Nothing
Set objMx = Nothing
Set xmlHTTP = Nothing
Set Fs = Nothing
Set MySh = Nothing
My.Quit
End Function
Function uWaitS(strTargetURL, nWaitMinute)
Dim iResult
uWaitS = (VarType(strTargetURL) = 8)
If uWaitS Then
Dim wTime, qTime
If VarType(nWaitMinute) <> 2 Then
nWaitMinute = 30
End If
wTime = 5000
qTime = Now() + TimeSerial(0, nWaitMinute, 0)
iResult = True
Do Until URLExist(strTargetURL)
My.Sleep wTime
If Now() > qTime Then
iResult = False
Exit Do
End If
Loop
uWaitS = iResult
End If
End Function
Function URLExist(TargetURL)
On Error Resume Next
Dim exMx
Set exMx = objMx
With exMx
.open "GET", TargetURL, False
.send
My.Sleep 600
If .Status = 12007 Then
URLExist = False
Else
URLExist = True
End If
End With
Set exMx = Nothing
End Function
Function nSightLoader(strURL, strID, Result)
If uWaitS(strURL, 15) Then
With objIE
.Width = 800
.Height = 600
.Left = 0
.Top = 0
.Visible = False
.Navigate strURL
Do Until .Busy = False
My.Sleep 250
Loop
.Refresh
Do Until .Busy = False
My.Sleep 250
Loop
WIth .Document
If strID = "" Then
Result = .Body.InnerText
Else
Result = .getElementById(strID).InnerHTML
End If
End With
.Quit
End With
nSightLoader = True
Else
nSightLoader = False
End If
End Function
Function sEncoder(Source, strFrom, strTo)
Dim objFrom, objTo, iResult
If strFrom = "" Then
strFrom = "shift_jis"
End If
If strTo = "" Then
strTo = "utf-8"
End If
Set objFrom = My.CreateObject("ADODB.Stream")
Set objTo = My.CreateObject("ADODB.Stream")
With objTo
.Open
.Charset = strTo
End With
With objFrom
.Open
.Charset = strFrom
.WriteText Source
.Position = 0
.CopyTo objTo
.Close
End With
Set objFrom = nothing
With objTo
.Position = 0
iResult = .ReadText
.Close
End With
Set objTo = nothing
sEncoder = iResult
iResult = ""
End Function |
■ 日本語を英訳する。
[タグ]-[タグ機能を有効にする] と
[Command/CommandW(コマンド実行)] - [タグを有効にする] が 全て True になっていないと機能しない。
ぶっちゃけ、上画像3つと同じ設定になっているのが望ましい。
0 件のコメント:
コメントを投稿
注: コメントを投稿できるのは、このブログのメンバーだけです。