どーもボキです。 ニュースで英会話のバックアップでは、記事ごとに再生ボタンの表示高さ（Y座標）が異なり、 クリック位置の記録＆調整に苦労した。 mp3を上書き更新とすることで、サイズ≠０で録音の成功を判断させた。 このときファイル名が「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
どーもボキです。 [VBScript] ニュースで英会話をバックアップするを改良して、新番組である「 世界へ発信！英語術」に対応させた。 必要な準備は、前回の記事を参考に。 UWSCの設定 ＞ 指定ウィンドウ名を「 - 世界へ発信！英語術 - 」へ変更すること。  実行イメージ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
' -------------------------------------------------------------------------------
どーもボキです。 英語学習を始め、 ニュースで英会話の存在を知った。 サイト自体は2009年から存在したようだ。 日々最近のニュースが更新され、1分前後の短い文章がナチュラルスピードで読み上げられ、 センテンスごとの解説も用意されている。TOEICで500点以上を狙う人には最適なサイトと思う。 この ニュースで英会話が、この3月で終了した。 4月末にはサイトも閉鎖される。 こんなに充実したサイトなのにもったいない。 だからバックアップしよう。  スクリプトの実行イメージ
ニュースで英会話の音声はHLS配信（ストリーミング）なので、音声ファイルはダウンロードできない。 ならアナログで対応するしかない。そう、再生される音声を録音する、だ。 キーボード操作ならVBScriptで再現できるが、音声の再生にはマウス操作が必要。なので、以下のフリーソフトを用意する。 ・ Moo0 音声録音機（音声が流れている時間のみを録音するツール） ・ UWSC（マウス操作を記録＆再現するツール） Moo0 音声録音機 に必要な設定
※マイドキュメントに保存すること。VBScriptではマイドキュメントにある前提とした。 ・ 無音カット、上書き可にチェック これは、録音を音声再生～終了に同期させるため。上書き不要なファイルを作らせないため。 増幅は、PCによる。音割れするならば100%未満に、録音ボリュームが小さすぎるならば100％より大に。  ・ 設定 ＞ 無音カット - 「無音」認識のボリューム閾値 ＞ 1% これは、センテンス間で録音を止めさせないため。  ・ 設定 ＞ 無音カット - 停止するまでの無音の長さ ＞ 3.0sec
これは、終了部をしっかり残すため。上の設定だけでは終了時の音声が切れてしまうので、これも必要。  ・ 設定 ＞ キーボード・ショートカット ＞ [Ctrl+スペース]：録音開始/終了 これは、VBScriptから Moo0 音声録音機の録音をスタンバイさせるため。  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が立ち上がると自動でマウスクリックされるようになる。  以上で準備完了。以下のスクリプトを.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
' -------------------------------------------------------------------------------'
どーもボキです。 フォルダ内にあるCSVファイルをひとつのExcelファイルにまとめるスクリプト。 CSVファイルごとにシートを分けるようにしている。 エキサイトブログには.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.Ｏｐｅｎ(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
どーもボキです。 AdjustStringは ・半角カナ → 全角カナ ・全角記号 → 半角記号 ・全角英数 → 半角数字 と変換する関数。 半角カナは、濁点(゛)や半濁点(゜)が別の文字となる、つまり、次の文字まで読まないと文字を確定できない。 そのため、今回はひとつの関数内で変換元の文字管理と変換処理を行った。 全角と半角とで文字の並びが統一されていなかったため、Case文処理が必須だったものの、可能な限り定型処理化した。  SetScriptHost("cscript")
s = "どーもﾎﾞｷです"
dprintf " 前：" & s
dprintf " 後：" & AdjustString(s)
dprintf ""
s = "ｈｔｔｐ：／／ｙｏｚｄａ．ｅｘｂｌｏｇ．ｊｐ"
dprintf " 前：" & s
dprintf " 後：" & AdjustString(s)
dprintf ""
s = "２００４／０５～"
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("ｚ") ) 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] 全角文字を半角文字へ変換する
どーもボキです。 定型業務のツール支援するにも、文字バイトが統一されていないとそれすらままならない。 というか、たいていの人は文字バイトなど意識しない。 本当にわからないのだろう、言っても直らない。ツール側で吸収したほうが早い。 以下のZenToHan関数で文字サイズを半角に統一するとよい。  ZenToHan関数での変換事例SetScriptHost("cscript")
s = "ｙｏｚｄａ （ … ＞ Ｚ＿￣∂ "
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("ｚ") 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
どーもボキです。 ★★★★★ ノーマル＆クラシックでクリア。クリアまでのプレイ時間40h。 特別版に付属していたDLC「星の神殿」もフル活用。 1章は、DLCで部隊を鍛え上げまったく歯ごたえなし。 とはいえ、ファミコン時代にやり遂げたドゼー撃破は達成できず。 さすがに村人ループをやる気力はなく、ある程度強くなったところでストーリを進めた。 前々作の「覚醒」、前作の「if」に比べ、グラフィックは格段に進化した。 「if」から採用されたマップからの先頭シーンへのシームレスな突入はさらに進化。 キャラクタの頭身も上がり、戦闘シーンのリアル度が増した。 グラフィックは進化しているものの、ファミコンを忠実に再現したためか、 ファミコン時代の手抜きマップがそのまま再現されている。 少年時代のアルム＆セリカの関係など、ファミコン時代にはなかった（と思う）、 そこらのストーリー肉付けがあるものの、本筋はほぼ原作どおり（だったと思う）。 ているものの、仲間との支援会話はあっさり。 ファミコン時代には支援会話すらなかった（と思う）ので、そこは進化といえるか。 せっかくリメイクするなら、マップを作り直す。 キャラ間の支援会話をもっと充実させる、などあっても良かったのでは？ 最終ステージやクリア後は、アルムとセリカが一緒に行動することになるが、 この二人に支援会話がないのはもったいない。ラスボス前も「気をつけていきましょう」の一言のみ。 そんな主人公二人のあっさりな会話に対し、最終ステージのキャラごとの演出やBGMには萌えた。 特にこのリメイクはBGMに気合が入りまくっている。 以下は、最終ステージの「神よ、その黄昏よ」。 ファミコン版⇒3DS版と流れるので、そのリメイクの素晴らしさを聴いてほしい。 [3DS] ファイアーエムブレム エコーズ
おはヨーグルト。どーもボキです。  息子から借りていたソフト、ようやくクリアした。 当時３年生だった(今は６年生)が怒りながら、時にはキレて泣きながらプレイしてたゲームだ。 パッケージイラストからイメージできないだろうが、それくらい難しい。 他のゲームではダレ易いバトルシーンは、敵の攻撃に合わせた反撃・回避が必要で最後まで楽しく飽きる間がない。 ただ、巨大ボス戦でのジャイロ操作には慣れず、最後まで苦労した。 あとラスボスが強すぎて勝てないので、ここだけはイージーモードを利用。 フィールドは、細切れのマップ切り替え形式になっているため、あまり広くは感じない。 マリオとルイージのブラザーアクション(協力技)を駆使しての謎解きもなかなか面白い。ただし、迷うことはないかな。 ルイージが活躍する今作、なかなかオススメ。 クリアまでのプレイ、50時間。
 おはヨーグルト。どーもボキです。 リビングのメイン照明を変えた。 16畳（といっても、ダイニングやキッチンには別の照明あり）に対して、12畳仕様だったから明るさに少し不安があったものの、 付けてみると、明るすぎるくらい。 色味や明るさを調整できたり、ダウンライトにしてみたり（写真）、時間帯や気分で照明演出を変えられてかなり良い。 感心したのが留守番機能。 指定時間帯での点灯。そして、その時間幅を日常起き得るバラツキ分を自動調整してくれる。 なぜか、14畳〜のダウンライト付仕様はない。 ビックカメラで、¥36,801。オススメ。
こんばんワイン。どーもボキです。 youkuで見れますな。 
B'z Live動画 高解像度なもの
|
検索
カテゴリ
タグ
以前の記事
フォロー中のブログ
ブログジャンル
|
