タグ:オススメ ( 104 ) タグの人気記事 > Z_ ̄∂
[VBScript] TextBox > Z_ ̄∂
どーもボキです。

RadioGroupBoxやMessgeDlgを応用したTextBox。

a0021757_12270939.png

a0021757_12271868.png

利用時の注意
 ONCLICKをonlickと変換すること。

Option Explicit

msgbox TextBox("タイトル","キャプション","文字A" &vbTAB& ":" &vbCRLF & "文字B" &vbTAB& ":" & vbCRLF& "文字C" &vbTAB& ":")
'-----------------------------------------------------------------------------------------
' sTitle : タイトル
' sCaption : メッセージ
' sText : 表示するテキスト
Function TextBox(sTitle, sCaption, sText)
Const cRegName = "HKCU\Software\Microsoft\Internet Explorer\LinksExplorer\Docked"
Dim objWS,objIE,ieDoc
Dim i,s,r,ireg,html

' レジストリ修正 > エクスプローラバーを非表示
On Error Resume Next ' Dockedなし
Set objWS = CreateObject("WScript.Shell")
ireg = objWS.RegRead(cRegName)
objWS.RegWrite cRegName, 0, "REG_DWORD"
On Error GoTo 0 'エラー無視を解除

' IEを起動
Set objIE = WScript.CreateObject("InternetExplorer.Application")
objIE.Navigate "about:blank"

' タグ記述
html = "<BODY><TABLE ID=Tbl BORDER=0>" &_
"<TR><TD ALIGN=Left VALIGN=Top><SPAN>" & Replace(sCaption,vbCRLF,"<BR>") & "<BR><BR></SPAN>" & _
"<FORM NAME=Form>" & _
"<INPUT TYPE=HIDDEN NAME=Button VALUE=-1><textarea name=text rows=16 cols=64>"&sText&"</textarea>" & _
"<BR></TD></TR><TR><TD ALIGN=Center VALIGN=Bottom>"&_
"<INPUT TYPE=BUTTON VALUE="" OK "" ONCLICK=Form.Button.value="& vbOK &"> " & _
"<INPUT TYPE=BUTTON VALUE=""キャンセル"" ONCLICK=Form.Button.value="& vbCancel &">" & _
"</TD></TR></FORM></TABLE></BODY>"

' ↓↓共通↓↓
Set ieDoc = objIE.Document
ieDoc.Body.InnerHtml = html
ieDoc.Title = sTitle
objIE.ToolBar = False ' 上ツールバーを隠す(AddressBar,MenuBarも非表示となる)
objIE.StatusBar = False ' ステータスバーを隠す
ieDoc.Body.RuntimeStyle.OverflowX = "hidden" ' 横 スクロールバーを隠す
ieDoc.Body.RuntimeStyle.OverflowY = "hidden" ' 縦 〃
objIE.Width = ieDoc.All.Tbl.clientWidth +50 ' 幅 サイズ調整
objIE.Height = ieDoc.All.Tbl.clientHeight +70 ' 高 〃
objIE.Left = Int((ieDoc.parentWindow.screen.availwidth -objIE.Width )/2) ' 左 位置調整
objIE.Top = Int((ieDoc.parentWindow.screen.availheight-objIE.Height)/2) ' 上 〃
For i = 0 To objIE.Width
ieDoc.Title = ieDoc.Title +" " ' - Microsoft Internet Explorerを隠す
i = i +10
Next
ieDoc.Body.bgcolor = "ButtonFace" ' 色
objIE.Visible = True ' ウィンドウ表示
objIE.Resizable = False ' ウィンドウサイズ固定 ※表示前に実行すると縁にゴミ画像が残る
' ユーザ操作取得
On Error Resume Next ' エラー無視 ([×]終了対応)
r = -1
Do While r = -1
WScript.Sleep 100
r = CInt(ieDoc.Form.Button.value)
If objIE = Null Then Exit Do
Loop
objIE.Visible = False
' ↑↑共通↑↑

' 値取得
If r = vbOK Then
r = ieDoc.Form.text.value
Else
r = ""
End If

objIE.Quit
Set objIE = Nothing

' レジストリ修正 > エクスプローラバーを元設定に戻す
objWS.RegWrite cRegName, ireg, "REG_DWORD"

On Error GoTo 0 'エラー無視を解除
TextBox = r
End Function

[PR]
by yozda | 2018-09-24 12:27 | SE♂日誌 | Trackback | Comments(0)
[VBScript] MessageDlg > Z_ ̄∂
どーもボキです。

MessageDlgの改良点

改良点
 ・サイドバー表示が有効な場合、関数内にて一時的にそれを無効とし、終了時に有効に戻すようにした。
 ・GetResolution関数の利用を廃止。

a0021757_12164198.png

a0021757_12122540.png

利用時の注意
 ONCLICKをonlickと変換すること。

Option Explicit

MsgBox MessageDlg("タイトル","キャプション" &vbCRLF& "01234567890123456789012345678901234567890123456789","Button0,Button1,Button2")
'-----------------------------------------------------------------------------------------
' sTitle : タイトル
' sCaption : メッセージ
' Items : アイテムリスト
' Index : デフォルト選択するアイテムインデックス
Function MessageDlg(sTitle, sCaption, Items)
Const cRegName = "HKCU\Software\Microsoft\Internet Explorer\LinksExplorer\Docked"
Dim objWS,objIE,ieDoc
Dim i,s,r,ireg,html

' レジストリ修正 > エクスプローラバーを非表示
On Error Resume Next ' Dockedなし
Set objWS = CreateObject("WScript.Shell")
ireg = objWS.RegRead(cRegName)
objWS.RegWrite cRegName, 0, "REG_DWORD"
On Error GoTo 0 'エラー無視を解除

If Not IsArray(Items) Then Items = Split(Items,",")

' IEを起動
Set objIE = WScript.CreateObject("InternetExplorer.Application")
objIE.Navigate "about:blank"

' タグ記述
html = "<BODY><TABLE ID=Tbl BORDER=0 STYLE=font-size:10pt>" &_
"<TR><TD ALIGN=Left VALIGN=Top><SPAN>" & Replace(sCaption,vbCRLF,"<BR>") & "<BR><BR><SPAN>" & _
"<FORM NAME=Form>" & _
"<INPUT TYPE=HIDDEN NAME=Button VALUE=-1>" &_
"</TD></TR><TR><TD ALIGN=Center VALIGN=Center>"
' ボタン
html = html & "<INPUT TYPE=BUTTON VALUE=" & Items(0) & " ONCLICK=Form.Button.value=0>"
For i = 1 To UBound(Items)
html = html & " <INPUT TYPE=BUTTON VALUE=" & Items(i) & " ONCLICK=Form.Button.value=" & i & ">"
Next
html = html & "</TD></TR></FORM></TABLE></BODY>"

' ↓↓共通↓↓
Set ieDoc = objIE.Document
ieDoc.Body.InnerHtml = html
ieDoc.Title = sTitle
objIE.ToolBar = False ' 上ツールバーを隠す(AddressBar,MenuBarも非表示となる)
objIE.StatusBar = False ' ステータスバーを隠す
ieDoc.Body.RuntimeStyle.OverflowX = "hidden" ' 横 スクロールバーを隠す
ieDoc.Body.RuntimeStyle.OverflowY = "hidden" ' 縦 〃
objIE.Width = ieDoc.All.Tbl.clientWidth +50 ' 幅 サイズ調整
objIE.Height = ieDoc.All.Tbl.clientHeight +70 ' 高 〃
objIE.Left = Int((ieDoc.parentWindow.screen.availwidth -objIE.Width )/2) ' 左 位置調整
objIE.Top = Int((ieDoc.parentWindow.screen.availheight-objIE.Height)/2) ' 上 〃
For i = 0 To objIE.Width
ieDoc.Title = ieDoc.Title +" " ' - Microsoft Internet Explorerを隠す
i = i +10
Next
ieDoc.Body.bgcolor = "ButtonFace" ' 色
objIE.Visible = True ' ウィンドウ表示
objIE.Resizable = False ' ウィンドウサイズ固定 ※表示前に実行すると縁にゴミ画像が残る
' ユーザ操作取得
On Error Resume Next ' エラー無視 ([×]終了対応)
r = -1
Do While r = -1
WScript.Sleep 100
r = CInt(ieDoc.Form.Button.value)
If objIE = Null Then Exit Do
Loop
objIE.Visible = False
' ↑↑共通↑↑

objIE.Quit
Set objIE = Nothing

' レジストリ修正 > エクスプローラバーを元設定に戻す
objWS.RegWrite cRegName, ireg, "REG_DWORD"

On Error GoTo 0 'エラー無視を解除
MessageDlg = r
End Function


[VBScript] メッセージダイアログを実現する


[PR]
by yozda | 2018-09-24 12:18 | SE♂日誌 | Trackback | Comments(0)
[VBScript] RadioGropuBox > Z_ ̄∂
どーもボキです。

RadioGroupBoxの改良版です。

改良点
 ・サイドバー表示が有効な場合、関数内にて一時的にそれを無効とし、終了時に有効に戻すようにした。
 ・GetResolution関数の利用を廃止。

a0021757_12004880.png

a0021757_12122540.png

利用時の注意
 ONCLICKをonlickと変換すること。

Option Explicit

Const RadioGroupBox_MaxCount = 10
MsgBox RadioGroupBox("タイトル","キャプション" &vbCRLF&"01234567890123456789012345678901234567890123456789","アイテム0,アイテム1,アイテム2",1)
'-----------------------------------------------------------------------------------------
' sTitle : タイトル
' sCaption : メッセージ
' Items : アイテムリスト
' Index : デフォルト選択するアイテムインデックス
Function RadioGroupBox(sTitle, sCaption, Items, Index)
Const cRegName = "HKCU\Software\Microsoft\Internet Explorer\LinksExplorer\Docked"
Dim objWS,objIE,ieDoc
Dim i,s,r,ireg,html,bCmbBx

' レジストリ修正 > エクスプローラバーを非表示
On Error Resume Next ' Dockedなし
Set objWS = CreateObject("WScript.Shell")
ireg = objWS.RegRead(cRegName)
objWS.RegWrite cRegName, 0, "REG_DWORD"
On Error GoTo 0 'エラー無視を解除

If Not IsArray(Items) Then Items = Split(Items,",")

' IEを起動
Set objIE = WScript.CreateObject("InternetExplorer.Application")
objIE.Navigate "about:blank"

' タグ記述
html = "<BODY><TABLE ID=Tbl BORDER=0 STYLE=font-size:10pt>" &_
"<TR><TD ALIGN=Left VALIGN=Top><SPAN>" & Replace(sCaption,vbCRLF,"<BR>") & "<BR><BR></SPAN>" & _
"<FORM NAME=Form>" & _
"<INPUT TYPE=HIDDEN NAME=Button VALUE=-1>"
bCmbBx = UBound(Items) >= RadioGroupBox_MaxCount-1
If bCmbBx Then
' コンボボックス
html = html +"<SELECT NAME=ComboBox size=" & RadioGroupBox_MaxCount &" style=width:100%>"
For i = 0 To UBound(Items)
If i = Index Then s = " selected" Else s = ""
html = html +"<OPTION value=" & i & s & ">" & Items(i) &"</OPTION>"
Next
s = s+"</SELECT>"
Else
' ラジオボタン
html = html +"<INPUT NAME=Radio TYPE=HIDDEN VALUE="& Index & ">"
For i = 0 to UBound(Items)
If i = Index Then s = " checked" Else s = ""
html = html +" <INPUT TYPE=RADIO Name=RG ONCLICK=Radio.value=" & i & s & ">" & Items(i) &"</INPUT><BR>"
Next
End If
html = html +"<BR></TD></TR><TR><TD ALIGN=Center VALIGN=Bottom>"&_
"<INPUT TYPE=BUTTON VALUE="" OK "" ONCLICK=Form.Button.value="& vbOK &"> " & _
"<INPUT TYPE=BUTTON VALUE=""キャンセル"" ONCLICK=Form.Button.value="& vbCancel &">" & _
"</TD></TR></FORM></TABLE></BODY>"
' ↓↓共通↓↓
Set ieDoc = objIE.Document
ieDoc.Body.InnerHtml = html
ieDoc.Title = sTitle
objIE.ToolBar = False ' 上ツールバーを隠す(AddressBar,MenuBarも非表示となる)
objIE.StatusBar = False ' ステータスバーを隠す
ieDoc.Body.RuntimeStyle.OverflowX = "hidden" ' 横 スクロールバーを隠す
ieDoc.Body.RuntimeStyle.OverflowY = "hidden" ' 縦 〃
objIE.Width = ieDoc.All.Tbl.clientWidth +50 ' 幅 サイズ調整
objIE.Height = ieDoc.All.Tbl.clientHeight +70 ' 高 〃
objIE.Left = Int((ieDoc.parentWindow.screen.availwidth -objIE.Width )/2) ' 左 位置調整
objIE.Top = Int((ieDoc.parentWindow.screen.availheight-objIE.Height)/2) ' 上 〃
For i = 0 To objIE.Width
ieDoc.Title = ieDoc.Title +" " ' - Microsoft Internet Explorerを隠す
i = i +10
Next
ieDoc.Body.bgcolor = "ButtonFace" ' 色
objIE.Visible = True ' ウィンドウ表示
objIE.Resizable = False ' ウィンドウサイズ固定 ※表示前に実行すると縁にゴミ画像が残る
' ユーザ操作取得
On Error Resume Next ' エラー無視 ([×]終了対応)
r = -1
Do While r = -1
WScript.Sleep 100
r = CInt(ieDoc.Form.Button.value)
If objIE = Null Then Exit Do
Loop
objIE.Visible = False
' ↑↑共通↑↑

' 値取得
If r = vbOK Then
If bCmbBx Then
r = ieDoc.Form.ComboBox.selectedIndex
Else
r = CInt(ieDoc.Form.Radio.value) ' 取得データは文字のため
End If
Else
r = -1
End If

objIE.Quit
Set objIE = Nothing

' レジストリ修正 > エクスプローラバーを元設定に戻す
objWS.RegWrite cRegName, ireg, "REG_DWORD"

On Error GoTo 0 'エラー無視を解除
RadioGroupBox = r
End Function


[VBScript] ラジオボタンダイアログを実現する その3


[PR]
by yozda | 2018-09-24 12:05 | SE♂日誌 | Trackback | Comments(0)
[VBScript] ワイルドカードを指定したファイル名サーチ > Z_ ̄∂
どーもボキです。

ニュースで英会話のバックアップでは、記事ごとに再生ボタンの表示高さ(Y座標)が異なり、
クリック位置の記録&調整に苦労した。

mp3を上書き更新とすることで、サイズ≠0で録音の成功を判断させた。

このときファイル名が「yymmdd_記事タイトル」となるため「記事タイトル」を固定できない。

FileExistsや、GetFileは、ファイル名をそのものを指定しければならず、記事タイトルを把握しないかぎり利用できない。

そのため、ワイルドカードを指定できるCopyFileやMoveFileを応用したファイル名取得関数「SearchFile」を作成した。
重複しない名前のフォルダへMoveし、そのMove先のファイル名を取得するようにしている。なお、戻り値は最後に見つかったファイル名としている。

' 指定したファイル名が存在するか調べる(ワイルドカードOK)
' 戻り値:見つかったファイル名
Function SearchFile(DirectoryPath, FileName)
Dim objFS,f,r,dpth

r = ""
Set objFS = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
dpth = DirectoryPath & Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
objFS.CreateFolder(dpth) ' 重複しないフォルダを作成
objFS.MoveFile DirectoryPath & FileName, dpth &"\"
For Each f In objFS.GetFolder(dpth).Files
r = f.Name
Next
objFS.MoveFile dpth &"
\"& FileName, DirectoryPath
objFS.DeleteFolder dpth
On Error GoTo 0

SearchFile = r
End Function

[PR]
by yozda | 2018-04-15 09:30 | プログラミング | Trackback | Comments(0)
[VBScript] 世界へ発信!英語術をバックアップする > Z_ ̄∂
どーもボキです。

[VBScript] ニュースで英会話をバックアップするを改良して、新番組である「世界へ発信!英語術」に対応させた。

必要な準備は、前回の記事を参考に。
UWSCの設定 > 指定ウィンドウ名を「 - 世界へ発信!英語術 - 」へ変更すること。

a0021757_11121905.png
実行イメージ

SetScriptHost("CScript")

Set objWS = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")

' 18.04.01~実行日までをループさせる
y0 = 2018
y1 = Year(Now)

If y1 = y0 Then
m0 = 4
m1 = Month(Now)
Else
m0 = 1
m1 = 12
End If

d0 = 1
If m0 = m1 Then
d1 = Day(Now)
Else
d1 = 31
End If

Arr_url = Array("s", "k", "w")
Arr_key = Array("_センテンス", "_キーワード", "_ボキャブラリー")

DPath = objWS.SpecialFolders("MyDocuments") &"\"
For yyyy = y0 To y1
For mm = m0 To m1
If Len(mm) = 1 Then mm = "
0" & mm
For dd = d0 To d1: Do
If Len(dd) = 1 Then dd = "
0" & dd

r = -1
On Error Resume Next
r = Weekday(yyyy &"
/" & mm & "/" & dd)
On Error GoTo 0
If (r < vbMonday) Or (r > vbFriday) Then Exit Do

' 保存フォルダ作成
DPath_Save = DPath & Right(yyyy,2) & mm &"
\"
If Not objFS.FolderExists(DPath_Save) Then objFS.CreateFolder(DPath_Save)

' 保存済みmp3のサイズチェック
yymmdd = Right(yyyy,2) & mm & dd
fname = SearchFile(DPath_Save, yymmdd & "
*.mp3")
If fname <> "
" Then
Set fmp3 = objFS.GetFile(DPath_Save & fname)
If fmp3.Size <> 0 Then Exit Do ' 保存済み
End If

' 本文テキスト&音声を録音
fname = ProcURL("
http://www.nhk.or.jp/snsenglish/news/n"& yymmdd &".html", DPath_Save, "")
If fname = "
" Then Exit Do ' 放送なし or アンコール放送

' 残りのテキストを保存
For i = 0 To UBound(Arr_url)
fname = SearchFile(DPath_Save, yymmdd & "
*" & Arr_key(i) & "*")
If fname = "
" Then
ProcURL "
http://www.nhk.or.jp/snsenglish/elearning/" & Arr_url(i) & yymmdd &".html", DPath_Save, fname & Arr_key(i)
End If
Next
Loop Until 1: Next
Next
Next
'===============================================================================
' URLを開く
' 戻り値:(番組が存在した場合)YYMMDD_タイトル
Function ProcURL(URL, FolderPath, PostFix)
Dim objWS: Set objWS = CreateObject("
WScript.Shell")
Dim i,s,key,fname,yymmdd,objIE,ieDoc

i = InStr(URL, "
.html")
yymmdd = Mid(URL, i-6,6) ' yymmddを取得

Do
Set objIE = CreateObject("
InternetExplorer.Application")
objIE.Navigate URL
Do While objIE.Busy: WScript.Sleep 1000: Loop ' ページ読み込み完了待ち

Set ieDoc = objIE.Document
s = ieDoc.Title
i = InStr(s,"
- 世界へ発信!英語術 - NHK") -1
If (i < 0) Or (InStr(s,"
アンコール放送") > 0) then Exit Do ' ⇒ 終了

fname = yymmdd &"
_"& Left(s,i)
If PostFix = "
" Then
dprintf fname

' VoiceRecorderの設定変更
rpth = "
HKCU\Software\Moo0\Moo0 VoiceRecorder\SaveData\MainWindow\CreationPath\"
key = rpth & "
FolderPath"
i = objWS.RegWrite(key, FolderPath, "
REG_SZ") ' 保存フォルダパス
key = rpth & "
FileName"
i = objWS.RegWrite(key, fname, "
REG_SZ") ' 保存ファイル名

' VoiceRecorder起動
objWS.Run "
"""& objWS.SpecialFolders("MyDocuments") &"\AudioRecorder 1.46\VoiceRecorder.exe"""
WScript.Sleep 1000
objWS.SendKeys "
^ " ' Rec Start
Do
objIE.Visible = True ' 再生(UWSC)
WScript.Sleep 10000
objIE.Visible = False
r = CreateObject("
WScript.Shell").PopUp("finish?",80,"now recording...",vbYesNo)
Loop Until (r = vbYes) Or (r = -1)
TerminateProcess("
VoiceRecorder.exe")
End If
' URLをmhtファイルで保存
On Error Resume Next
Set objCDO = CreateObject("
CDO.Message")
objCDO.CreateMHTMLBody(URL)
objCDO.BodyPart.GetStream.SaveToFile FolderPath & fname & PostFix & "
.mht", 2
Set objCDO = Nothing

Loop Until 1

objIE.Quit
Set objIE = Nothing

ProcURL = fname
End Function
'-------------------------------------------------------------------------------
' 指定したファイル名が存在するか調べる(ワイルドカードOK)
' 戻り値:見つかったファイル名
Function SearchFile(DirectoryPath, FileName)
Dim objFS,f,r,dpth

r = "
"
Set objFS = CreateObject("
Scripting.FileSystemObject")
On Error Resume Next
dpth = DirectoryPath & Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
objFS.CreateFolder(dpth) ' 重複しないフォルダを作成
objFS.MoveFile DirectoryPath & FileName, dpth &"
\"
For Each f In objFS.GetFolder(dpth).Files
r = f.Name
Next
objFS.MoveFile dpth &"
\"& FileName, DirectoryPath
objFS.DeleteFolder dpth
On Error GoTo 0

SearchFile = r
End Function
' -------------------------------------------------------------------------------
' 指定した名前のプロセスを強制終了する
Sub TerminateProcess(ProcessName)
Dim objProcList,objProcess

Set objProcList = GetObject("
winmgmts:").InstancesOf("win32_process")
For Each objProcess In objProcList
If LCase(objProcess.Name) = LCase(ProcessName) Then
objProcess.Terminate
End If
Next
End Sub
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
Dim i,s

If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & "
""" & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &"
""" & WScript.Arguments.Item(i) & """" ' 引数
Next
End If
CreateObject("
WScript.Shell").Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
' デバッグ ※ここだけ抜粋してもOK
Dim objDbg
' クラス
Class TDebug
Dim FCScript

' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "
cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine NOW & "
[END]"
WScript.StdIn.ReadLine
End Sub

' CScriptホストかどうか
Public Property Get CScript
CScript = FCScript
End Property

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

s = v
ityp = VarType(v)
If ityp = vbBoolean Then
s = CStr(v)
ElseIf VarType(v) >= vbArray Then
s = "
"
For i = 0 to UBound(v)
s = s & "
dprintf(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then
Set objDbg = New TDebug
objDbg.dprintf(NOW & "
" & WScript.ScriptFullName)
End If
objDbg.dprintf(v)
End Sub
' -------------------------------------------------------------------------------

[PR]
by yozda | 2018-04-14 11:10 | プログラミング | Trackback | Comments(0)
[VBScript] ニュースで英会話をバックアップする > Z_ ̄∂
どーもボキです。

英語学習を始め、ニュースで英会話の存在を知った。
サイト自体は2009年から存在したようだ。

日々最近のニュースが更新され、1分前後の短い文章がナチュラルスピードで読み上げられ、
センテンスごとの解説も用意されている。TOEICで500点以上を狙う人には最適なサイトと思う。

このニュースで英会話が、この3月で終了した。4月末にはサイトも閉鎖される。
こんなに充実したサイトなのにもったいない。

だからバックアップしよう。
a0021757_10065277.png
スクリプトの実行イメージ


ニュースで英会話の音声はHLS配信(ストリーミング)なので、音声ファイルはダウンロードできない。
ならアナログで対応するしかない。そう、再生される音声を録音する、だ。

キーボード操作ならVBScriptで再現できるが、音声の再生にはマウス操作が必要。なので、以下のフリーソフトを用意する。

 ・Moo0 音声録音機(音声が流れている時間のみを録音するツール)
 ・UWSC(マウス操作を記録&再現するツール)


Moo0 音声録音機 に必要な設定
 ※マイドキュメントに保存すること。VBScriptではマイドキュメントにある前提とした。

 ・無音カット、上書き可にチェック
  これは、録音を音声再生~終了に同期させるため。上書き不要なファイルを作らせないため。
  増幅は、PCによる。音割れするならば100%未満に、録音ボリュームが小さすぎるならば100%より大に。
a0021757_19523648.png

 ・設定 > 無音カット - 「無音」認識のボリューム閾値 > 1%
  これは、センテンス間で録音を止めさせないため。
a0021757_19523714.png

 ・設定 > 無音カット - 停止するまでの無音の長さ > 3.0sec
  これは、終了部をしっかり残すため。上の設定だけでは終了時の音声が切れてしまうので、これも必要。
a0021757_19523665.png

 ・設定 > キーボード・ショートカット > [Ctrl+スペース]:録音開始/終了
  これは、VBScriptからMoo0 音声録音機の録音をスタンバイさせるため。
a0021757_19523603.png

UWSC に必要な設定
 ※UWSCは起動させておく。

 ・ニュースで英会話のサイトにて、音声再生させるマウス位置とクリック操作を記録する。
   Alt+F3で記録開始、Alt+F2で記録停止、記録した操作に名前を付けて保存する。

 ※操作記録ファイル(.UWS)で必要となるコマンドはBTN()のみ。いったん記録したファイルをテキストエディタで編集するとよい。
  以下はマウス左クリック、1040はマウスのX座標、 610~700はY座標、100は実行時の待ち時間[ms]。
  以下は、x=1040、y=610~700を10刻みでクリックしていく。実行PCによるので適宜修正を。

BTN(LEFT,CLICK,1040,610,100)
BTN(LEFT,CLICK,1040,620,100)
BTN(LEFT,CLICK,1040,630,100)
BTN(LEFT,CLICK,1040,640,100)
BTN(LEFT,CLICK,1040,650,100)
BTN(LEFT,CLICK,1040,660,100)
BTN(LEFT,CLICK,1040,670,100)
BTN(LEFT,CLICK,1040,680,100)
BTN(LEFT,CLICK,1040,690,100)
BTN(LEFT,CLICK,1040,700,100)


 ・設定 > スケジュールを設定する にて、上のイベントファイルを選択、指定ウィンドウが現れた時 をチェックし、「- ニュースで英会話 -」を指定。
  これで、ニュースで英会話のWebが立ち上がると自動でマウスクリックされるようになる。
a0021757_19523628.png

以上で準備完了。以下のスクリプトを.vbsファイルととて保存し実行する。
正常に動作すれば、マイドキュメントに[yymm」フォルダを作り、そのなかに日々のニュースを「yymmdd_タイトル」で保存していく。

SetScriptHost("CScript")

Set objWS = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")

DPath = objWS.SpecialFolders("MyDocuments") &"\"
For yyyy = 2009 To 2018
m0 = 1
m1 = 12
For mm = m0 To m1
If Len(mm) = 1 Then mm = "
0" & mm
For dd = 1 To 31: Do
If Len(dd) = 1 Then dd = "
0" & dd

r = -1
On Error Resume Next
r = Weekday(yyyy &"
/" & mm & "/" & dd)
On Error GoTo 0
If (r < vbMonday) Or (r > vbFriday) Then Exit Do

' 保存フォルダ作成
DPath_Save = DPath & Right(yyyy,2) & mm &"
\"
If Not objFS.FolderExists(DPath_Save) Then objFS.CreateFolder(DPath_Save)

yyyymmdd = yyyy & mm & dd
' 保存済みmp3のサイズチェック
If yyyymmdd >= "
20150401" Then
fname = SearchFile(DPath_Save, Right(yyyymmdd,6) & "
*.mp3")
If fname <> "
" Then
Set fmp3 = objFS.GetFile(DPath_Save & fname)
If fmp3.Size <> 0 Then Exit Do ' 保存済み
End If
End If

fname = ProcURL("
https://cgi2.nhk.or.jp/e-news/news/index.cgi?ymd=" & yyyymmdd, DPath_Save, "")
If fname = "
" Then Exit Do ' 放送なし or アンコール放送

ProcURL "
https://cgi2.nhk.or.jp/e-news/elearning/explain.cgi?ymd=" & yyyymmdd & "&type=news", DPath_Save, fname & "_センテンス"
ProcURL "
https://cgi2.nhk.or.jp/e-news/elearning/explain.cgi?ymd=" & yyyymmdd & "&type=keyword", DPath_Save, fname & "_キーワード"
ProcURL "
https://cgi2.nhk.or.jp/e-news/news/words.cgi?ymd=" & yyyymmdd, DPath_Save, fname & "_ボキャブラリー"
Loop Until 1: Next
Next
Next
'===============================================================================
' URLを開く
' 戻り値:(番組が存在した場合)YYMMDD_タイトル
Function ProcURL(URL, FolderPath, FileName)
Dim objWS: Set objWS = CreateObject("
WScript.Shell")
Dim i,s,key,fname,yymmdd,objIE,ieDoc

i = InStr(URL, "
ymd")
yymmdd = Mid(URL, i+6,6) ' yymmddを取得

Do
Set objIE = CreateObject("
InternetExplorer.Application")
objIE.Navigate URL
Do While objIE.Busy: WScript.Sleep 1000: Loop ' ページ読み込み完了待ち

Set ieDoc = objIE.Document
s = ieDoc.Title
i = InStr(s,"
- ニュースで英会話 - NHK") -1
If (i < 0) Or (InStr(s,"
アンコール放送") > 0) then Exit Do ' ⇒ 終了

If FileName = "
" Then
FileName = yymmdd &"
_"& Left(s,i)
dprintf FileName

If yymmdd >= "
150401" Then
' VoiceRecorderの設定変更
rpth = "
HKCU\Software\Moo0\Moo0 VoiceRecorder\SaveData\MainWindow\CreationPath\"
key = rpth & "
FolderPath"
i = objWS.RegWrite(key, FolderPath, "
REG_SZ") ' 保存フォルダパス
key = rpth & "
FileName"
i = objWS.RegWrite(key, FileName, "
REG_SZ") ' 保存ファイル名

' VoiceRecorder起動
objWS.Run "
"""& objWS.SpecialFolders("MyDocuments") &"\AudioRecorder 1.46\VoiceRecorder.exe"""
WScript.Sleep 1000
objWS.SendKeys "
^ " ' Rec Start
Do
objIE.Visible = True ' 再生(UWSC)
WScript.Sleep 10000
objIE.Visible = False
r = CreateObject("
WScript.Shell").PopUp("finish?",80,"now recording...",vbYesNo)
Loop Until (r = vbYes) Or (r = -1)
TerminateProcess("
VoiceRecorder.exe")
End If
End If
' URLをmhtファイルで保存
On Error Resume Next
Set objCDO = CreateObject("
CDO.Message")
objCDO.CreateMHTMLBody(URL)
objCDO.BodyPart.GetStream.SaveToFile FolderPath & FileName & "
.mht", 2
Set objCDO = Nothing

Loop Until 1

objIE.Quit
Set objIE = Nothing

ProcURL = FileName
End Function
'-------------------------------------------------------------------------------
' 指定したファイル名が存在するか調べる(ワイルドカードOK)
' 戻り値:見つかったファイル名
Function SearchFile(DirectoryPath, FileName)
Dim objFS,f,r,dpth

r = "
"
Set objFS = CreateObject("
Scripting.FileSystemObject")
On Error Resume Next
dpth = DirectoryPath & Year(Now) & Month(Now) & Day(Now) & Hour(Now) & Minute(Now) & Second(Now)
objFS.CreateFolder(dpth) ' 重複しないフォルダを作成
objFS.MoveFile DirectoryPath & FileName, dpth &"
\"
For Each f In objFS.GetFolder(dpth).Files
r = f.Name
Next
objFS.MoveFile dpth &"
\"& FileName, DirectoryPath
objFS.DeleteFolder dpth
On Error GoTo 0

SearchFile = r
End Function
' -------------------------------------------------------------------------------
' 指定した名前のプロセスを強制終了する
Sub TerminateProcess(ProcessName)
Dim objProcList,objProcess

Set objProcList = GetObject("
winmgmts:").InstancesOf("win32_process")
For Each objProcess In objProcList
If LCase(objProcess.Name) = LCase(ProcessName) Then
objProcess.Terminate
End If
Next
End Sub
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
Dim i,s

If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & "
""" & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &"
""" & WScript.Arguments.Item(i) & """" ' 引数
Next
End If
CreateObject("
WScript.Shell").Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
' デバッグ ※ここだけ抜粋してもOK
Dim objDbg
' クラス
Class TDebug
Dim FCScript

' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "
cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine NOW & "
[END]"
WScript.StdIn.ReadLine
End Sub

' CScriptホストかどうか
Public Property Get CScript
CScript = FCScript
End Property

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

s = v
ityp = VarType(v)
If ityp = vbBoolean Then
s = CStr(v)
ElseIf VarType(v) >= vbArray Then
s = "
"
For i = 0 to UBound(v)
s = s & "
dprintf(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then
Set objDbg = New TDebug
objDbg.dprintf(NOW & "
" & WScript.ScriptFullName)
End If
objDbg.dprintf(v)
End Sub
' -------------------------------------------------------------------------------'

[PR]
by yozda | 2018-04-13 20:29 | プログラミング | Trackback(1) | Comments(0)
[VBScript] フォルダ内のCSVファイルをひとつのExcelファイルにまとめる > Z_ ̄∂
どーもボキです。

フォルダ内にあるCSVファイルをひとつのExcelファイルにまとめるスクリプト。
CSVファイルごとにシートを分けるようにしている。

エキサイトブログには.openが記述できなかったので全角で記述した。
全角のOPENを半角へ変えること。

使い方は簡単、CSVファイルを保存したフォルダをVBSファイルにドロップするだけ。
フォルダ名.xlsx(拡張しは、実行PCのExcelバージョンによる)が作成される。

なお、CSVファイル名をそのままシート名にするため、
CSVファイル名が半角 31 文字 or 全角は 15 文字を超えていた場合、エラーとなる。
Set objWS = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")

' 引数なし
If WScript.Arguments.Count = 0 Then WScript.Quit

SetScriptHost("CScript") ' ドロップだとWScriptとなるためCScriptで再起動

For i = 0 To WScript.Arguments.Count -1: Do
s = WScript.Arguments.Item(i)

If objFS.FolderExists(s) Then
ProcFolder(s)
End If
Loop Until 1: Next

r = CreateObject("WScript.Shell").PopUp("処理が終了しました。",3,cTitle,64)
'================================================================================'
Function ProcFolder(DPath)
Dim i,r,s,b_init,objFolder,objExcel,xlBook,xlSheet

dprintf(DPath)
Set objExcel = CreateObject("Excel.Application")
objExcel.Application.DisplayAlerts = False ' 警告OFF
'objExcel.Application.Visible = True ' Excel非表示
objExcel.Workbooks.Add ' ブックの新規作成

' フォルダ内のファイル分ループ
b_init = True
Set objFolder = objFS.GetFolder(DPath)
For Each File In objFolder.Files: Do
If InStr(LCase(File.Path), LCase(".csv")) = 0 Then Exit Do ' .csv以外は処理しない

dprintf(vbTab & File.Name)
Set xlBook = objExcel.Workbooks.Open(File.Path) ' ファイルを開く
Set xlSheet = xlBook.Worksheets(1) ' シートを格納

s = objFS.GetFileName(File.Path) ' ファイル名
xlSheet.Name = Left(s, InStrRev(s,".")-1) ' ファイルタイトルをシート名
r = xlSheet.Move(,objExcel.Workbooks(1).Sheets( objExcel.Workbooks(1).Sheets.Count )) ' 最後に追加

If b_init Then
' 新規作成で生成されるSheet1~3を削除(Excelバージョンによる)
While objExcel.Workbooks(1).Sheets.Count > 1
objExcel.WorkBooks(1).Sheets(1).Delete
WEnd
b_init = False
End If

'objExcel.Workbooks(1).WorkSheets(1).Select ' 先頭シートを最前面へ
Loop Until 1: Next

' 解析結果を保存
objExcel.Workbooks(1).SaveAs(objFolder.Path)
objExcel.Quit

Set objExcel = Nothing ' オブジェクト開放 ※これをしないとExcelプロセスが残る
End Function
' -------------------------------------------------------------------------------
' デバッグ ※ここだけ抜粋してもOK
Dim objDbg
' クラス
Class TDebug
Dim FCScript
' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine WScript.ScriptFullName & " [END]"
WScript.StdIn.ReadLine
End Sub

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

s = v
ityp = VarType(v)
If ityp = vbBoolean Then
s = CStr(v)
ElseIf VarType(v) >= vbArray Then
s = ""
For i = 0 to UBound(v)
s = s & "dprintf(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then Set objDbg = New TDebug
objDbg.dprintf(v)
End Sub
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & " """ & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &" """ & WScript.Arguments.Item(i) & """"
Next
End If
CreateObject("WScript.Shell").Run s
WScript.Quit
End Sub

[PR]
by yozda | 2017-11-23 14:23 | プログラミング | Trackback | Comments(0)
[VBScript] 半角カナを全角へ、全角記号&英数は半角へ変換する関数 > Z_ ̄∂
どーもボキです。

AdjustStringは
 ・半角カナ → 全角カナ
 ・全角記号 → 半角記号
 ・全角英数 → 半角数字
と変換する関数。

半角カナは、濁点(゛)や半濁点(゜)が別の文字となる、つまり、次の文字まで読まないと文字を確定できない。
そのため、今回はひとつの関数内で変換元の文字管理と変換処理を行った。

全角と半角とで文字の並びが統一されていなかったため、Case文処理が必須だったものの、可能な限り定型処理化した。
a0021757_12555734.gif
SetScriptHost("cscript")

s = "どーもボキです"
dprintf " 前:" & s
dprintf " 後:" & AdjustString(s)
dprintf ""

s = "http://yozda.exblog.jp"
dprintf " 前:" & s
dprintf " 後:" & AdjustString(s)
dprintf ""

s = "2004/05~"
dprintf " 前:" & s
dprintf " 後:" & AdjustString(s)
dprintf ""

' ===============================================================================
' 全角→半角
Function AdjustString(iStr)
Dim i,a1,a0,r,s,s0,s1

i = 1
r = ""
Do While i <= Len(iStr)
a1 = 1
a0 = 0
s0 = ""
s = Mid(iStr, i, 1)
r = s
If ( Asc(s) >= Asc("。") ) And ( Asc(s) <= Asc("゚") ) Then
' 半角カナ → 全角
Select Case s
Case "。" r = "。"
Case "ヲ" r = "ヲ"
Case "ッ" r = "ッ"
Case "ー" r = "ー"
Case Else
If Asc(s) >= Asc("゙") Then
s0="゙": s1="゛": a1=1
ElseIf Asc(s) >= Asc("ワ") Then
s0="ワ": s1="ワ": a1=4
ElseIf Asc(s) >= Asc("ラ") Then
s0="ラ": s1="ラ": a1=1
ElseIf Asc(s) >= Asc("ヤ") Then
s0="ヤ": s1="ヤ": a1=2
ElseIf Asc(s) >= Asc("ム") Then
s0="ム": s1="ム": a1=1
ElseIf Asc(s) >= Asc("マ") Then
s0="マ": s1="マ": a1=1
ElseIf Asc(s) >= Asc("ハ") Then
s0="ハ": s1="ハ": a1=3
If Mid(iStr, i+1, 1) = "゙" Then a0=1
If Mid(iStr, i+1, 1) = "゚" Then a0=2
ElseIf Asc(s) >= Asc("ナ") Then
s0="ナ": s1="ナ": a1=1
ElseIf Asc(s) >= Asc("ツ") Then
s0="ツ": s1="ツ": a1=2
If Mid(iStr, i+1, 1) = "゙" Then a0=1
ElseIf Asc(s) >= Asc("タ") Then
s0="タ": s1="タ": a1=2
If Mid(iStr, i+1, 1) = "゙" Then a0=1
ElseIf Asc(s) >= Asc("カ") Then
s0="カ": s1="カ": a1=2
If Mid(iStr, i+1, 1) = "゙" Then a0=1
ElseIf Asc(s) >= Asc("ア") Then
s0="ア": s1="ア": a1=2
ElseIf Asc(s) >= Asc("ャ") Then
s0="ャ": s1="ャ": a1=2
ElseIf Asc(s) >= Asc("ァ") Then
s0="ァ": s1="ァ": a1=2
ElseIf Asc(s) >= Asc("、") Then
s0="、": s1="、": a1=4
ElseIf Asc(s) >= Asc("「") Then
s0="「": s1="「": a1=1
End If
End Select
ElseIf ( Asc(s) >= Asc(" ") ) And ( Asc(s) <= Asc("z") ) Then
' 全角記号&英数 → 半角
Select Case s
Case " " r=" "
Case "," r=","
Case "." r="."
Case ":" r=":"
Case ";" r=";"
Case "?" r="?"
Case "!" r="!"
Case "^" r="^"
Case "_" r="_"
'Case "ー" r="-" ' 全角文字で利用するため半角変換しない
Case "―" r="-"
Case "‐" r="-"
Case "/" r="/"
Case "\" r="\"
'Case "
" r="~" ' 全角文字で利用するため半角変換しない
Case "
" r="|"
Case "
" r="'"
Case "”" r=""""
Case "(" r="("
Case ")" r=")"
Case "[" r="["
Case "]" r="]"
Case "{" r="{"
Case "}" r="}"
'Case "「" r="「" ' 全角文字で利用するため半角変換しない
'Case "」" r="」" ' 全角文字で利用するため半角変換しない
Case "+" r="+"
Case "-" r="-"
Case "=" r="="
Case "<" r="<"
Case ">" r=">"
Case "′" r="'"
Case "″" r=""""
Case "¥" r="\"
Case "
" r="$"
Case "
" r="%"
Case "
" r="#"
Case "
" r="&"
Case "
" r="*"
Case "
" r="@"
Case Else
If Asc(s) >= Asc("
") Then
s0="
": s1="a"
ElseIf Asc(s) >= Asc("
") Then
s0="
": s1="A"
ElseIf Asc(s) >= Asc("
") Then
s0="
": s1="0"
End If
End Select
End If
If s0 <> "
" Then r=Chr( (Asc(s) -Asc(s0))*a1 +Asc(s1) +a0) ' 変換処理
AdjustString = AdjustString & r

i = i +1 +Abs(CInt(a0 > 0))
Loop
End Function
' ===============================================================================
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
Dim i,s

If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & "
""" & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &"
""" & WScript.Arguments.Item(i) & """" ' 引数
Next
End If
CreateObject("
WScript.Shell").Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
' デバッグ
Dim objDbg
' クラス
Class TDebug
Dim FCScript

' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "
cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine NOW & "
[END]"
WScript.StdIn.ReadLine
End Sub

' CScriptホストかどうか
Public Property Get CScript
CScript = FCScript
End Property

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

s = v
ityp = VarType(v)
If ityp = vbBoolean Then
s = CStr(v)
ElseIf VarType(v) >= vbArray Then
s = "
"
For i = 0 to UBound(v)
s = s & "
dprintf(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then
Set objDbg = New TDebug
objDbg.dprintf(NOW & "
" & WScript.ScriptFullName)
End If
objDbg.dprintf(v)
End Sub
' -------------------------------------------------------------------------------
[VBScript] 全角文字を半角文字へ変換する

[PR]
by yozda | 2017-08-18 20:40 | プログラミング | Trackback(1) | Comments(0)
[VBScript] 全角英数&記号を半角へ変換する > Z_ ̄∂
どーもボキです。

定型業務のツール支援するにも、文字バイトが統一されていないとそれすらままならない。

というか、たいていの人は文字バイトなど意識しない。
本当にわからないのだろう、言っても直らない。ツール側で吸収したほうが早い。

以下のZenToHan関数で文字サイズを半角に統一するとよい。
a0021757_09255103.png
ZenToHan関数での変換事例

SetScriptHost("cscript")

s = "yozda ( … > Z_ ̄∂ "
dprintf " 前:" & s
dprintf " 後:" & ZenToHan(s)

' ===============================================================================
' 全角→半角
Function ZenToHan(iStr)
Dim i,r

r = ""
For i = 1 To Len(iStr)
r = r & ZenToHan_func(Mid(iStr, i, 1))
Next
ZenToHan = r
end function
' 関数
Function ZenToHan_func(iStr)
Dim r
r = iStr
ZenToHan_func = r
If Asc(r) < Asc(" ") Then Exit Function
If Asc(r) > Asc("z") Then Exit Function

Select Case r
Case " " r = " "
Case "," r = ","
Case "." r = "."
Case ":" r = ":"
Case ";" r = ";"
Case "?" r = "?"
Case "!" r = "!"
Case "^" r = "^"
Case "_" r = "_"
Case "ー" r = "-"
Case "―" r = "-"
Case "‐" r = "-"
Case "/" r = "/"
Case "~" r = "~"
Case "|" r = "|"
Case "’" r = "'"
Case "”" r = """"
Case "(" r = "("
Case ")" r = ")"
Case "[" r = "["
Case "]" r = "]"
Case "{" r = "{"
Case "}" r = "}"
Case "+" r = "+"
Case "-" r = "-"
Case "=" r = "="
Case "<" r = "<"
Case ">" r = ">"
Case "′" r = "'"
Case "″" r = """"
Case "¥" r = "\"
Case "
" r = "$"
Case "
" r = "%"
Case "
" r = "#"
Case "
" r = "&"
Case "
" r = "*"
Case "
" r = "@"
Case Else
If Asc(r) >= Asc("
") Then
r = Chr(Asc(r) -Asc("
") +Asc("a"))
ElseIf Asc(r) >= Asc("
") Then
r = Chr(Asc(r) -Asc("
") +Asc("A"))
ElseIf Asc(r) >= Asc("
") Then
r = Chr(Asc(r) -Asc("
") +Asc("0"))
End If
End Select
ZenToHan_func = r
End Function
' ===============================================================================
' 実行ホストを切り替える
Sub SetScriptHost(HostName)
Dim i,s

If InStr(LCase(WSCript.FullName), LCase(HostName)) <> 0 Then Exit Sub

s = HostName & "
""" & WScript.ScriptFullName & """"
If WScript.Arguments.Count > 0 Then
For i = 0 To WScript.Arguments.Count -1
s = s &"
""" & WScript.Arguments.Item(i) & """" ' 引数
Next
End If
CreateObject("
WScript.Shell").Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
' デバッグ ※ここだけ抜粋してもOK
Dim objDbg
' クラス
Class TDebug
Dim FCScript

' 初期化処理
Private Sub Class_Initialize()
FCScript = InStr(LCase(WSCript.FullName), "
cscript") > 0
End Sub

' 終了処理
Private Sub Class_Terminate()
If Not FCScript Then Exit Sub

WScript.StdOut.WriteLine NOW & "
[END]"
WScript.StdIn.ReadLine
End Sub

' CScriptホストかどうか
Public Property Get CScript
CScript = FCScript
End Property

' デバッグメッセージ処理
Public Sub dprintf(v)
Dim i,s,ityp
If Not FCScript Then Exit Sub

s = v
ityp = VarType(v)
If ityp = vbBoolean Then
s = CStr(v)
ElseIf VarType(v) >= vbArray Then
s = "
"
For i = 0 to UBound(v)
s = s & "
dprintf(" &i& ")=" & v(i) & vbCRLF
Next
End If
WScript.Echo s
End Sub
End Class
' 関数
Sub dprintf(v)
If VarType(objDbg) = vbEmpty Then
Set objDbg = New TDebug
objDbg.dprintf(NOW & "
" & WScript.ScriptFullName)
End If
objDbg.dprintf(v)
End Sub



[PR]
by yozda | 2017-08-16 22:11 | プログラミング | Trackback | Comments(0)
[3DS] ファイアーエムブレム エコーズ > Z_ ̄∂
どーもボキです。

★★★★★

a0021757_06534981.jpg
ノーマル&クラシックでクリア。クリアまでのプレイ時間40h。
特別版に付属していたDLC「星の神殿」もフル活用。

1章は、DLCで部隊を鍛え上げまったく歯ごたえなし。
とはいえ、ファミコン時代にやり遂げたドゼー撃破は達成できず。
さすがに村人ループをやる気力はなく、ある程度強くなったところでストーリを進めた。

前々作の「覚醒」、前作の「if」に比べ、グラフィックは格段に進化した。
「if」から採用されたマップからの先頭シーンへのシームレスな突入はさらに進化。
キャラクタの頭身も上がり、戦闘シーンのリアル度が増した。

グラフィックは進化しているものの、ファミコンを忠実に再現したためか、
ファミコン時代の手抜きマップがそのまま再現されている。

少年時代のアルム&セリカの関係など、ファミコン時代にはなかった(と思う)、
そこらのストーリー肉付けがあるものの、本筋はほぼ原作どおり(だったと思う)。

ているものの、仲間との支援会話はあっさり。
ファミコン時代には支援会話すらなかった(と思う)ので、そこは進化といえるか。

せっかくリメイクするなら、マップを作り直す。
キャラ間の支援会話をもっと充実させる、などあっても良かったのでは?

最終ステージやクリア後は、アルムとセリカが一緒に行動することになるが、
この二人に支援会話がないのはもったいない。ラスボス前も「気をつけていきましょう」の一言のみ。

そんな主人公二人のあっさりな会話に対し、最終ステージのキャラごとの演出やBGMには萌えた。
特にこのリメイクはBGMに気合が入りまくっている。

以下は、最終ステージの「神よ、その黄昏よ」。
ファミコン版⇒3DS版と流れるので、そのリメイクの素晴らしさを聴いてほしい。
[3DS] ファイアーエムブレム エコーズ

[PR]
by yozda | 2017-05-23 21:30 | ゲーム | Trackback | Comments(4)