カテゴリ:プログラミング( 103 )
[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)
PCをリカバリーする
こんにちワイン。どーもボキです。

この週末でお願いされていたPCをリカバリーした。症状は「とにかく遅い、起動に30分かかる」とのこと。

実際に起動してみると確かに遅い、タスクマネージャーすらすぐに表示されない。
ようやく開いたタスクマネージャーでメモリを確認すると、搭載メモリが512MBに対して、使用量が700MB。
つまり、HDにキャッシュしてる。そら、遅いはずだ。バックアップを取ろうにも、その操作すらマトモにできない。

仕方がないので、いったんPCをシャットダウンを試みるも、ウィンドウズメニューが出てこない。
HDがずーっとカリカリカリカリいってる。いつまでまってもメニューすら出ないので、仕方なく強制終了。

そしたら、起動せんなった。セーフモードを選んでも起動しない。
チェックディスクで直るのだが、それが実行されない。

アワワ…。ヤバイィィ…。

預かったPCでの作業はあきらめ、家のPCにHDをつなぎチェックディスクやバックアップを試みた。
a0021757_15373436.jpg

起動後すぐにチェックディスクが起動した。よかった…。
この画面が延々と続く(右端の数値がひたすら増える。) とりあえず放置すること小一時間。
a0021757_15373594.jpg

チェックディスクが終わると、C&Dドライブに当たるディスクが認識できた。
Cドライブのユーザデータのバックアップを取ったあと、HDをもとに戻し、リカバリー。

リカバリー直後なら、512MBでも問題なかろうが、ちょっとアプリを入れだすと1GBはほしい。というかこのPCはMax1GB。
DDR-SDRAMなので、バルク品でもちょっとお高い。周辺の店での最安値は2,600円。(512MB×2)

リカバリー+メモリ増強後なので、いたって快適。あとはWindowsのアップデートしておしまい、
と思ったが、ここでもトラブル、アップデートが0x8024400Aエラーを出す。どうやらXP SP3へのアップデートが必要らしい。

XP SP3をダウンロードし、手動適用。その後は、Microsoft Updateでパッチ当て。
SP3直後なので、必要パッチは120個!? ここも放置。

あとは、
 ・Office2003+2007対応パッチ
 ・IE8
 ・Firefox+おススメのアドオン
などを入れて、そのPCに最初からついてたユーティリティでCドライブごとバックアップしておしまい。
7年前のPCだけど、ネット+α ならこの年代のスペックでも全然いける。
起動しなくなったときはかなりあせったけど、なんとかなってよかった。

PCを持っていったときにお菓子をいただいた。
ずっと気になっていたお店のお菓子。おいしかった。(けど、娘がほとんど食べた)


人のPCを直すのもいいけど、自分のもどうにかしないといけないわ。
Cドライブの容量確保するときに必要なファイルまで消してしまって、Office系のアイコンが出ない。
あとは、Windowsアップデートが正常にできない。
a0021757_14453431.gif
アイコンが表示されないExcelやWordのファイル

今の状態まで持っていくのって結構面倒だから、自分のPCのリカバリにはなかなか踏み切れない。


[PR]
by yozda | 2013-04-21 14:46 | プログラミング | Trackback(1) | Comments(0)
[Excel] コピーした文字列を改行ごとにテキストボックス化して張り付ける
『やっぱ今年はやめとくか?』 と言われそう。どーもボキです。

コピーした文字列を、選択セル位置を基準に一行ごとにテキストボックス化して貼り付けるマクロ。

ひとつのテキストボックスや行ごとに 箇条書きで書き溜めたアイデアを、
グループ分けしたり、前後関係で並べてみたり、そんなのに使えそう。

というかそのために作ったんだが、そもそも考えがまとまらないこととは関係なかったわ。
a0021757_1315010.gif
以下Excelマクロのソース。
Sub ClipBoardToTextBox()
' クリップボードの文字列を取得
s = CreateObject("htmlfile").parentwindow.clipboarddata.GetData("text")
If s = "" Then Exit Sub

' 表示更新を停止
Application.ScreenUpdating = False

' アクティブセルの座標を取得
x = ActiveCell.Left
y = ActiveCell.Top

' 改行ごとに格納
slst = Split(s, vbCrLf)

For i = 0 To UBound(slst): Do
If slst(i) = "" Then Exit Do

' テキストボックスを該当行に作成
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, x, y, 0#, 0#).Select

' テキストボックスに文字を反映
Selection.Characters.Text = slst(i)

' テキストボックスの装飾
Selection.ShapeRange(1).TextFrame.AutoSize = msoTrue
Selection.ShapeRange.Line.Visible = msoTrue
' Selection.ShapeRange.Line.Style = msoLineThinThin ' 縁取り線「=」
' Selection.ShapeRange.Line.Weight = 3#
Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Fill.ForeColor.SchemeColor = 9
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid

' テキストボックスの作成座標を更新
y = y + Selection.Height
Loop Until 1: Next

' 表示更新を再開
Application.ScreenUpdating = True
End Sub
ここの下のほうにあるDataObjectを使うやり方を試したんだが、
Microsoft Forms 2.0 Object Libraryを参照設定するために、ユーザフォームを追加したり面倒。
クリップボードから文字列の取得する方法もわからんかった(Formatなんとかってエラーが出る)のであきらめた。


[PR]
by yozda | 2012-11-04 13:19 | プログラミング | 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)
[VBScript] メッセージダイアログを実現する
こんにチワワ。ドーモボキです。

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

ラジオボタンダイアログのソースを利用して、メッセージダイアログを作成した。

実行ソース
r = MessageDlg("タイトル","キャプション","アイテム0,アイテム1,アイテム2")
a0021757_21263884.gif

戻り値は、押されたボタンのインデックス (0~)。
[×]で終了した場合は、-1。

◆ソース◆
[PR]
by yozda | 2012-09-22 18:08 | プログラミング | Trackback | Comments(0)
[VBScript] ラジオボタンダイアログを実現する その3
こんにチワワ。どーもボキです。

前回の記事 ⇒ [VBScript] ラジオボタンダイアログを実現する その2

ラジオボタンダイアログを改良した。タイトルバーに「http:/// -」を出なくした。

実行ソース
r = RadioGroupBox("タイトル","キャプション","アイテム0,アイテム1,アイテム2",1)
a0021757_21244099.gif
戻り値は、[OK]ボタンが押された場合は項目インデックス (0~)。
[キャンセル]ボタン や [×]で終了した場合は、-1。

RadioGroupBox_MaxCount = 3
とすることで、項目が指定数(この場合は3)以上になった場合、プルダウンメニュータイプに変更できる。
a0021757_21243675.gif





◆ソース◆
[PR]
by yozda | 2012-09-22 17:37 | プログラミング | Trackback(2) | Comments(10)
[VBScript] 右クリックメニューのカスタマイズ 他
こんばんワイン。どーもボキです。

ファイルやフォルダを右クリックした際に表示されるメニューをカスタマイズするスクリプト。
出来ることは以下。
a0021757_2243191.gif
実行結果イメージ
ファイル 右クリックメニュー
 ・選択ファイルの親フォルダ基準ででエクスプローラを開く
 ・選択ファイルの親フォルダ基準でコマンドプロンプトを開く

フォルダ 右クリックメニュー
 ・選択ファイルの親フォルダ基準ででエクスプローラを開く
 ・選択ファイルの親フォルダ基準でコマンドプロンプトを開く

拡張子がないファイルのテキストファイル関連付け

(サクラエディタがインストール済みの場合、以下をサクラエディタに関連付け)
 ・全ファイルの右クリックメニューにサクラエディタで編集を追加
 ・IEのソースエディタ
 ・VBScriptの編集エディタ
Set objWS = WScript.CreateObject("WScript.Shell")
Set objFS = CreateObject("Scripting.FileSystemObject")

' サクラエディタのインストールパス
cmd = "サクラエディタで開く"
fpth = ""
On Error Resume Next ' 未インストールへの対応 (RegReadでエラーになる)
s = Replace(objWS.RegRead("HKEY_CLASSES_ROOT\Applications\sakura.exe\shell\open\command\"),"""","",1,-1,1)
fpth = Left(s,InStr(s,"
%1")-1)
On Error GoTo 0

' エディタのパスを設定
If Not objFS.FileExists(fpth) Then
cmd = "
メモ帳で開く"
fpth = "
notepad"
End If
'--------------------------------------------------------------------------------------------------------
' ファイル 右クリメニュー
root = "
HKEY_CLASSES_ROOT\*\shell\"

key = root & cmd & "
\"
val = cmd & "
(&E)"
r = objWS.RegWrite(key, val, "
REG_SZ")
key = key & "
command\"
val = "
""" & fpth &""" ""%1"""
r = objWS.RegWrite(key, val, "
REG_SZ")

cmd = "
エクスプローラ"
key = root & cmd & "
\"
val = cmd & "
(&X)"
r = objWS.RegWrite(key, val, "
REG_SZ")
key = key & "
command\"
val = "
explorer /e , ""%1\.."""
r = objWS.RegWrite(key, val, "
REG_SZ")

cmd = "
エクスプローラ (このフォルダ基準)"
key = root & cmd & "
\"
val = cmd & "
(&X)"
r = objWS.RegWrite(key, val, "
REG_SZ")
key = key & "
command\"
val = "
explorer /e ,/root, ""%1\.."""
r = objWS.RegWrite(key, val, "
REG_SZ")

cmd = "
コマンドプロンプトを開く"
key = root & cmd & "
\"
val = cmd & "
(&W)"
r = objWS.RegWrite(key, val, "
REG_SZ")
key = key & "
command\"
val = "
cmd.exe /k ""cd %1\.."""
r = objWS.RegWrite(key, val, "
REG_SZ")

'--------------------------------------------------------------------------------------------------------
' フォルダ 右クリメニュー
root = "
HKEY_LOCAL_MACHINE\SOFTWARE\Classes\Directory\shell\"

cmd = "
エクスプローラ (このフォルダ基準)"
key = root & cmd & "
\"
val = cmd & "
(&X)"
r = objWS.RegWrite(key, val, "
REG_SZ")
key = key & "
command\"
val = "
explorer /e ,/root, ""%1"""
r = objWS.RegWrite(key, val, "
REG_SZ")

cmd = "
コマンドプロンプトを開く"
key = root & cmd & "
\"
val = cmd & "
(&W)"
r = objWS.RegWrite(key, val, "
REG_SZ")
key = key & "
command\"
val = "
cmd.exe /k ""cd %1"""
r = objWS.RegWrite(key, val, "
REG_SZ")

'--------------------------------------------------------------------------------------------------------
' 拡張子のないファイルを関連付け
fpth_bat = objFS.GetSpecialFolder(2) &"
\tmp.bat"
Set txt = objFS.OpenTextFile(fpth_bat,2,True)
txt.WriteLine "
assoc .=txtfile"
txt.Close
r = objWS.Run(fpth_bat,0,True)
objFS.DeleteFile(fpth_bat)

If fpth = "
notepad" Then WScript.Quit

' IEソース表示エディタの変更
key = "
HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Internet Explorer\View Source Editor\Editor Name\"
val = fpth
r = objWS.RegWrite(key, val, "
REG_SZ")

' テキストの編集用エディタを変更
key = "
HKEY_CLASSES_ROOT\txtfile\Shell\Edit\command\"
val = fpth & "
%1"
r = objWS.RegWrite(key, val, "
REG_SZ")

' VBScriptの編集用エディタを変更
key = "
HKEY_CLASSES_ROOT\VBSFile\Shell\Edit\command\"
val = fpth & "
%1"
r = objWS.RegWrite(key, val, "
REG_SZ")



[PR]
by yozda | 2012-06-25 22:08 | プログラミング | Trackback | Comments(0)