タグ:VBScript ( 55 ) タグの人気記事
[VBScript] Leeyesを自動ページめくりに対応させる。
どーもボキです。

Leeyes(見開き画像ビューア)は自動ページめくりに対応していない。
ページめくり操作は、矢印キーで指示できるので、VBScriptでボタン押下を再現してやればいい。

対応しているアプリもあるかもしれないが、調べてはいない。
SetScriptHost("CScript")    ' CScriptで実行

sec=3 ' sec

Set objWS = WScript.CreateObject("WScript.Shell")
cnt=0
While True
cnt = cnt +1
WScript.Sleep sec*1000 ' msec指定
objWS.SendKeys "{DOWN}" ' 保存するボタンを押下
WScript.StdOut.WriteLine cnt*sec
Wend
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
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] ブラウザでのダウンロードダイアログ操作を自動化する。
[PR]
by yozda | 2017-04-09 11:53 | プログラミング | Trackback | Comments(0)
[VBScript] ブラウザでのダウンロードダイアログ操作を自動化する。
こんにチワワ。どーもボキです。

a0021757_1545294.png
Firefoxでは、ZIPファイルなどのリンクをクリックすると、
「***を開く」というタイトルのダイアログが表示されるため、ダウンロードはユーザ操作が必要。
(IEでは、「ファイルのダウンロード」。Chromeではダイアログが表示されることなくダウンロードが始まる)

そのユーザ操作を自動化するスクリプト。
1.「***を開く」というタイトルのウィンドウがある場合は、それを最前面に移動する。
2.Alt+Sで、「ファイルを保存する」を選択する。
3.Enterで、ダイアログを閉じる。

実行状態がわかるように、CScriptで実行させている。
実行ホストの切り替えには、[VBScript] 引数を引き継いだ上で、指定したホストで実行するを使った
SetScriptHost("CScript")    ' CScriptで実行

Set objWS = WScript.CreateObject("WScript.Shell")
While True
If objWS.AppActivate("を開く") Then
WScript.StdOut.WriteLine "実行"
WScript.Sleep 500
objWS.SendKeys "%(S)" ' 保存するボタンにフォーカス
WScript.Sleep 500
objWS.SendKeys "{ENTER}" ' 保存するボタンを押下
End If
WScript.Sleep 1000
Wend
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
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 | 2016-06-25 15:46 | プログラミング | Trackback(1) | Comments(0)
[VBScript] 管理者昇格してスクリプトを実行する 【改良版】
こんにちわわ。どーもボキです。

ExecRunas関数内でWScript.Quitすれば、前回バージョンのような判定処理は不要になるね。

実行部
' 管理者権限でVBSを実行する
ExecRunas

' ~管理者権限で実行したいソース~


実装部
'--------------------------------------------------------------------------------------------------------
'OSのバージョンを取得する
Const osWinNT = 4.0
Const osWin2k = 5.0
Const osWinXP = 5.1
Const osVista = 6.0
Const osWin7 = 6.1
Const osWin8 = 6.2
Function GetOSVersion
Dim objWMI, osInfo, os

Set objWMI = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set osInfo = objWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem")
For Each os in osInfo
GetOSVersion = CDbl(Left(os.Version, 3))
Next
End Function
'--------------------------------------------------------------------------------------------------------
' 管理者に昇格して実行する
Function ExecRunas
Const cKey = "/ExecRunas"
Dim s

' ExecRunas実行チェック'
If WScript.Arguments.Count > 0 Then
If WScript.Arguments.item(0) = cKey Then Exit Function
End If

' OSバージョンチェック'
If GetOSVersion < osVista Then Exit Function

' 引数を生成'
s = ""
For i = 0 To WScript.Arguments.Count -1
s = s & " """ & WScript.Arguments.item(i) & """"
Next

' Runas実行'
CreateObject("Shell.Application").ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """" & " " &cKey& " " & s, "", "runas", 1

' VBS実行を終了'
WScript.Quit
End Function
'--------------------------------------------------------------------------------------------------------

[VBScript] 管理者昇格してスクリプトを実行する
[PR]
by yozda | 2015-12-20 15:37 | プログラミング | Trackback | Comments(0)
[VBScript] 更新日時を元にファイルをリネームする
こんばんワイン。どーもボキです。

iPhoneに限った話ではないが、デバイスの保存画像ファイルをすべて吸い上げると、
ファイル名がリセットされ、また同じ名前でファイルが作られる。

同じ名前のファイルが存在する場合、同じフォルダに保存できず不便なため、
ファイルの更新日時情報からファイル名を変更するスクリプトを作成した。

使い方は、以下の実行プログラムをメモ帳にペーストし、vbsファイルとして保存、実行するだけ。
図のようにフォルダ選択ダイアログが表示される。

なお、VBSファイルへのフォルダ/ファイルドロップでも処理可能。
a0021757_13225160.gif
実行プログラム
'==============================================================================='
Set objWS = CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")

If WScript.Arguments.Count = 0 Then
If Not SelectDirectory("処理するフォルダを選択",0,dpth) Then WSCript.Quit

objWS.Run "CScript """ & WScript.ScriptFullName & """ """ & dpth & """"
WScript.Quit ' 引数を渡し再起動
Else
SetScriptHost("CScript") ' ドロップだとWScriptとなるためCScriptで再起動

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

If objFS.FileExists(s) Then
ProcFile(s)
Else
SearchFile(s)
End If
Loop Until 1: Next
End If

r = objWS.PopUp("処理が終了しました。",3,"終了メッセージ",64)
'================================================================================

' -------------------------------------------------------------------------------
' フォルダ内のファイル検索
Sub SearchFile(DPath)
Set Folder = objFS.GetFolder(DPath)

' フォルダ内のフォルダ
For Each SubFolder In Folder.SubFolders: Do
SearchFile(SubFolder.Path)
Loop Until 1: Next

' フォルダ内のファイル
For Each File In Folder.Files: Do
ProcFile(File.Path)
Loop Until 1: Next
End Sub
' -------------------------------------------------------------------------------'
' ファイル処理本体
Function ProcFile(FPath)
Dim i,s,ttl,ext,dpth,dnam,fnam0,fnam,fpth
ProcFile = False
'If LCase(Right(FPath, Len(FPath) -InStrRev(FPath,"."))) <> "csv" Then Exit Function

dpth = objFS.GetParentFolderName(FPath) &"\"
'dnam = objFS.GetFileName(objFS.GetParentFolderName(FPath))
fnam0 = objFS.GetFileName(FPath)

s = objFS.GetFile(FPath).DateLastModified
'If Len(s)=18 Then s = Replace(s, "
", " 0") ' h→hh
ttl = Mid(s,3,2) & Mid(s,6,2) & Mid(s,9,2) ' yymmdd
ext = Right(FPath, Len(FPath) -InStrRev(FPath,"
.") +1) ' 拡張子

fnam = ttl & ext
fpth = dpth & fnam
If objFS.FileExists(fpth) Then
i = 1
fnam = ttl &"
_"& IntToStr0(i,1) & ext
fpth = dpth & fnam
While objFS.FileExists(fpth)
i = i+1
fnam = ttl &"
_"& IntToStr0(i,1) & ext
fpth = dpth & fnam
Wend
End If
dprintf(fnam0 &"
"& fnam)
objFS.GetFile(FPath).Name = fnam

ProcFile = True
End Function
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
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
'-------------------------------------------------------------------------------
' フォルダ選択ダイアログ
Function SelectDirectory(sCaption, sInitDir, sSelectDir)
Dim objFS,objSA,dpth

SelectDirectory = False
Set objFS = CreateObject("
Scripting.FileSystemObject")
Set objSA = CreateObject("
Shell.Application")

Set objFolder = objSA.BrowseForFolder(0, sCaption, 0, sInitDir)
If objFolder Is Nothing Then Exit Function ' キャンセル

If objFolder.Items.Item Is Nothing Then
dpth = CreateObject("
WScript.Shell").SpecialFolders("Desktop") &"\" ' デスクトップ
Else
dpth = objFolder.Items.Item.Path &"
\"
End If
If Not objFS.FolderExists(dpth) Then Exit Function '指定異常 (ゴミ箱とか)

sSelectDir = dpth
SelectDirectory = True
End Function
'-------------------------------------------------------------------------------
' 0付き文字に変換
Function IntToStr0(Value, Digits)
Dim i,cnt,s

s = CStr(Value)
cnt = Digits - Len(s)
For i = 0 To cnt
s = "
0" & s
Next
IntToStr0 = s
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 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 | 2014-12-13 17:46 | プログラミング | Trackback | Comments(0)
[VBScript] 指定時間経過後にPCをスタンバイにする
こんばんワイン。どーもボキです。

PCをスタンバイにするで紹介したもの使った。
Excel未インストールの場合には、SendKeyを利用するようにしている。

何かしらの処理(○○な動画ダウンロード・変換など)で一定時間後にPCを切りたいときなどに利用できそう。
a0021757_23433621.gif
s = InputBox("hh:mm形式","指定時間後にスタンバイ","00:10")
If s = "" Then WScript.Quit

t = CDate(s) + Time
While CDate(t) > Time
WScript.Sleep(10000)
Wend

Set objWS = CreateObject("WScript.Shell")
r = objWS.PopUp("スタンバイにします。",3,"確認",vbOKCancel)
If r = vbCancel then WScript.Quit

On Error Resume Next ' Excel未インストール対応
Set objExcel = CreateObject("Excel.Application")
On Error GoTo 0
If Not (objExcel Is Nothing) Then
' Excelあり
cmd = "CALL(""powrprof.dll"",""SetSuspendState"",""JJJJ"",0,0,0)" '1,0,0とすると休止
objExcel.ExecuteExcel4Macro(cmd)
objExcel.Quit ' Quitしないとプロセスが残るため
Else
' Excelなし ⇒ タスクマネージャーを起動
objWS.SendKeys "^+{esc}" ' タスクマネージャー起動
Do While Not objWS.AppActivate("Windows タスク マネージャ")
WScript.Sleep 250 ' タスクマネージャー起動待ち
Loop
WScript.Sleep 1000

' ショートカットキーを送信
objWS.SendKeys "%ub%fx" ' スタンバイ
'objWS.SendKeys "%uh%fx" ' 休止状態
'objWS.SendKeys "%uu%fx" ' シャットダウン
'objWS.SendKeys "%ur%fx" ' 再始動
'objWS.SendKeys "%ul%fx" ' ログオフ
End If

[VBScript] Craving Explorerの動画変換の終了後、PCをスタンバイにする

[PR]
by yozda | 2014-11-22 23:46 | プログラミング | Trackback | Comments(0)
[VBScript] デバッグ上手はプログラム上手6 ~まとめ改~
こんにチワワ。どーもボキです。

以下と組み合わせれば、実行時にホストを変更でき、デバッグが楽になる。
引数を引き継いだ上で、指定したホストで実行する

前回はデバッグクラスを自分で生成するようにしていたが、
今回の記事では、最初にdprintf()を実行したタイミングで自動生成するよう改良した。

配布時は、SetScriptHostのみコメントアウトすればよい。
デフォルトであるWScriptホストでは、デバッグメッセージが表示されないようにしているので。

プログラムとその実装例
SetScriptHost("CScript")
dprintf("デバッグモード")

' ↑上記にスクリプト本体を記載する
' ===============================================================================
' デバッグ
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
' -------------------------------------------------------------------------------
' 実行ホストを切り替える
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
objWS.Run s
WScript.Quit
End Sub
' -------------------------------------------------------------------------------
[VBScript] デバッグ上手はプログラム上手5 ~まとめ~

[PR]
by yozda | 2014-08-24 14:48 | プログラミング | Trackback | Comments(0)
[VBScript] 管理者昇格してスクリプトを実行する
こんばんワイン。どーもボキです。

Win7以降(Vista以降?)、管理者でのログインといえど、
プログラムが管理者権限で実行されるわけではない。これはスクリプトも同じ。

管理者権限で実行するならば、右クリック > 管理者として実行する。
これをしなければ、スクリプトでレジストリの書き換えすら出来ない。

PBPには、ボタン押す以外は困難を極めるため、こういった高度な操作は期待できない。

なので、スクリプト内でOSを判定させ、Win7以降の場合は、
勝手に管理者に昇格して、スクリプトを実行しなおす仕組みを用意した。

なお、Win7以前は管理者ログインで実行されたプロセスは管理者権限で動作するため、
OSバージョンがWin7以前の場合は、何もしないようにしている。

実行部
' 管理者権限でVBSを実行する
If ExecRunas Then WScript.Quit

' ~管理者権限で実行したいソース~


実装部
'--------------------------------------------------------------------------------------------------------
'OSのバージョンを取得する
Const osWinNT = 4.0
Const osWin2k = 5.0
Const osWinXP = 5.1
Const osWin7 = 6.1
Const osWin8 = 6.2
Function GetOSVersion
Dim objWMI, osInfo, os

Set objWMI = GetObject("winmgmts:" & "{impersonationLevel=impersonate}!\\.\root\cimv2")
Set osInfo = objWMI.ExecQuery("SELECT * FROM Win32_OperatingSystem")
For Each os in osInfo
GetOSVersion = CDbl(Left(os.Version, 3))
Next
End Function
'--------------------------------------------------------------------------------------------------------
' 管理者に昇格して実行する
Function ExecRunas
Const cKey = "/ExecRunas"
Dim s

ExecRunas = False

' OS情報を取得'
If GetOSVersion < osWin7 Then Exit Function

' 引数の処理'
s = ""
If WScript.Arguments.Count > 0 Then
If WScript.Arguments.item(0) = cKey Then Exit Function ' 実行済み'

For i = 0 To WScript.Arguments.Count -1
s = s & " """ & WScript.Arguments.item(i) & """"
Next
End If

' Runas実行'
CreateObject("Shell.Application").ShellExecute "wscript.exe", """" & WScript.ScriptFullName & """" & " " &cKey& " " & s, "", "runas", 1

ExecRunas = True
End Function
'--------------------------------------------------------------------------------------------------------



[PR]
by yozda | 2014-04-29 23:59 | プログラミング | Trackback(1) | Comments(0)
[VBScript] youkuの分割動画をリネームする
こんヴァンヘイレン。どーもボキです。

youkuから(一時的に)ダウンロードした動画ファイルは、訳の分からん長ったらしい名前がついている。
それを短くリネームするスクリプト。

動画ファイルを保存したフォルダをスクリプトファイルにドロップすれば、
以下のようにリネームしてくれる。
a0021757_2042648.gif
Const cPos = 9  ' 16^1の位の文字位置

If WScript.Arguments.Count = 0 Then WScript.Quit ' フォルダドロップでない

Set objFS = CreateObject("Scripting.FileSystemObject")

For idpth = 0 To WScript.Arguments.Count -1: Do
dpth = WScript.Arguments(idpth)
If Not objFS.FolderExists(dpth) Then Exit Do ' フォルダでない

dname = objFS.GetFileName(dpth) ' フォルダ名

' フォルダ内のファイル処理
Set Folder = objFS.GetFolder(dpth)
For Each File In Folder.Files: Do
fname = File.Name
If InStr(fname, dname) <> 0 Then Exit Do ' リネーム済み

If Len(fname) > cPos Then
' 16^1の位
i = CInt(Mid(fname,cPos,1))
' 16^0の位
s = Mid(fname,cPos+1,1)
If s < "A" Then
j = CInt(s)
Else
j = Asc(s) -Asc("A") +10
End If

' ファイル番号を生成
s = CStr(i*16 +j)
If Len(s) = 1 Then s = "0" & s

' ファイル名の変更
fname = dname &"_"& s & Right(fname,4)
ElseIf (Len(fname) = 6) And IsNumeric(Left(fname,2)) Then
fname = dname & "_" & fname
End If

File.Name = fname
Loop Until 1: Next
Loop Until 1: Next

[youku] オススメ動画サイトyouku(= 中国版Youtube)、そのダウンロード方法
[PR]
by yozda | 2013-06-29 20:38 | プログラミング | Trackback | Comments(0)
[VBScript] 「アーティスト名 - 曲名」ファイルを「アーティスト名」フォルダ/「曲名」ファイルに分ける
こんばんワイン。どーもボキです。

こういう平置きされたファイルをフォルダに分けるスクリプト。
特に使い勝手がないだろうが、メモとして。
a0021757_1461320.gif
If WScript.Arguments.Count = 0 Then WScript.Quit    ' フォルダドロップでない

Set objFS = CreateObject("Scripting.FileSystemObject")
s = WScript.Arguments(0)
If Not objFS.FolderExists(s) Then WScript.Quit ' フォルダでない


' フォルダ内のファイルサーチ
Set Folder = objFS.GetFolder(s)
For Each File In Folder.Files: Do
s = File.Name
i = InStr(s, " - ")
If i <= 1 Then Exit Do ' アーティスト名が不明

dnam = LTrim(Left(s, i-1))
dpth = Folder.Path &"\"& dnam &"\"
fnam = Right(s, Len(s) -i-2)

On Error Resume Next ' CreateFolderのエラー回避
objFS.CreateFolder(dpth)
objFS.MoveFile File.Path, dpth & fnam
On Error GoTo 0
Loop Until 1: Next

MsgBox "
終了"



[PR]
by yozda | 2013-04-29 01:48 | プログラミング | Trackback | Comments(0)
[VBScript] メモ帳のフォントを「MS ゴシック」「9pt」「装飾なし」にする
今朝は、朝から頭痛が痛い。どーもボキです。

レジストリを書き換えて、メモ帳のフォントを「MS ゴシック」「9pt」「装飾なし」に書き換えるスクリプト。
プロポーショナルフォントを使うやつぁ、わしゃSEとして認めんけぇの。
key  = "HKCU\Software\Microsoft\Notepad\"
font = "MS ゴシック"
Set objWS = CreateObject("WScript.Shell")
r = objWS.RegWrite(key & "lfFaceName", font, "REG_SZ") ' フォント
r = objWS.RegWrite(key & "lfItalic", 0, "REG_DWORD") ' イタリック 0/1
r = objWS.RegWrite(key & "lfWeight", 400, "REG_DWORD") ' ボールド 400/700
r = objWS.RegWrite(key & "lfStrikeOut", 0, "REG_DWORD") ' 取り消し線 0/1
r = objWS.RegWrite(key & "lfUnderline", 0, "REG_DWORD") ' 下線 0/1
r = objWS.RegWrite(key & "iPointSize", 90, "REG_DWORD") ' 9pt×10



[PR]
by yozda | 2012-10-21 18:19 | プログラミング | Trackback | Comments(0)