（ タグ：オススメ ( 104 ) タグの人気記事 ＞ Z_￣∂
12345次へ >>>
（ [VBScript] TextBox ＞ Z_￣∂
どーもボキです。

RadioGroupBoxやMessgeDlgを応用したTextBox。

a0021757_12270939.png
↓
a0021757_12271868.png

利用時の注意
　ＯＮＣＬＩＣＫを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    "" ＯＮＣＬＩＣＫ=Form.Button.value="& vbOK     &">　" & _
        "<INPUT TYPE=BUTTON VALUE=""キャンセル"" ＯＮＣＬＩＣＫ=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

タグ：
みんなの【SE♂のノウハウ】をまとめ読み
▲ by yozda | 2018-09-24 12:27 | SE♂日誌 | Trackback | Comments(0)
（ [VBScript] MessageDlg ＞ Z_￣∂
どーもボキです。

MessageDlgの改良点

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

a0021757_12164198.png
↓
a0021757_12122540.png

利用時の注意
　ＯＮＣＬＩＣＫを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) & " ＯＮＣＬＩＣＫ=Form.Button.value=0>"
    For i = 1 To UBound(Items)
        html = html & "　<INPUT TYPE=BUTTON VALUE=" & Items(i) & " ＯＮＣＬＩＣＫ=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] メッセージダイアログを実現する


タグ：
みんなの【SE♂のノウハウ】をまとめ読み
▲ by yozda | 2018-09-24 12:18 | SE♂日誌 | Trackback | Comments(0)
（ [VBScript] RadioGropuBox ＞ Z_￣∂
どーもボキです。

RadioGroupBoxの改良版です。

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

a0021757_12004880.png
↓
a0021757_12122540.png

利用時の注意
　ＯＮＣＬＩＣＫを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 ＯＮＣＬＩＣＫ=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    "" ＯＮＣＬＩＣＫ=Form.Button.value="& vbOK     &">　" & _
        "<INPUT TYPE=BUTTON VALUE=""キャンセル"" ＯＮＣＬＩＣＫ=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] ラジオボタンダイアログを実現する その３


タグ：
みんなの【SE♂のノウハウ】をまとめ読み
▲ by yozda | 2018-09-24 12:05 | SE♂日誌 | Trackback | Comments(0)
（ [VBScript] ワイルドカードを指定したファイル名サーチ ＞ Z_￣∂
どーもボキです。

ニュースで英会話のバックアップでは、記事ごとに再生ボタンの表示高さ（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】をまとめ読み
▲ 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
' -------------------------------------------------------------------------------

タグ：
みんなの【VBScript】をまとめ読み
▲ 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
' -------------------------------------------------------------------------------'

タグ：
みんなの【VBScript】をまとめ読み
▲ by yozda | 2018-04-13 20:29 | プログラミング | Trackback(1) | Comments(0)
（ [VBScript] フォルダ内のCSVファイルをひとつのExcelファイルにまとめる ＞ Z_￣∂
どーもボキです。

フォルダ内にある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

タグ：
みんなの【VBScript】をまとめ読み
▲ 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 = "ｈｔｔｐ：／／ｙｏｚｄａ．ｅｘｂｌｏｇ．ｊｐ"
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] 全角文字を半角文字へ変換する

タグ：
みんなの【VBScript】をまとめ読み
▲ by yozda | 2017-08-18 20:40 | プログラミング | Trackback | Comments(0)
（ [VBScript] 全角英数＆記号を半角へ変換する ＞ Z_￣∂
どーもボキです。

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

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

以下のZenToHan関数で文字サイズを半角に統一するとよい。
a0021757_09255103.png
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


タグ：
みんなの【VBScript】をまとめ読み
▲ 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] ファイアーエムブレム エコーズ

タグ：
みんなの【レビュー】をまとめ読み
▲ by yozda | 2017-05-23 21:30 | ゲーム | Trackback | Comments(4)
12345次へ >>>

ファン申請

※ メッセージを入力してください