ソース掲示板




すべてから検索

キーワード   条件 表示 現行ログ 過去ログ トピックス 名前 本文
VBScript のいろいろ参考になるソースコード集
日時: 2014/08/25 17:21
名前: lightbox



エクスプローラ再起動
' 起動用
Set WshShell = CreateObject( "WScript.Shell" )
' WMI用
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")

' いったん終了させます
Set colProcessList = objWMIService.ExecQuery _ 
	("Select * from Win32_Process Where Name = 'explorer.exe'") 
For Each objProcess in colProcessList
	on error resume next
	objProcess.Terminate() 
	on error goto 0
Next 

' 少し待ちます
Wscript.Sleep(500)
Call WshShell.Run( "explorer.exe" )
メンテナンス

クリップボードのテキストを取得 ( No.1 )
日時: 2014/08/24 04:57
名前: lightbox


日時: 2014/08/24 04:57
名前: lightbox
Set objHTML = CreateObject("htmlfile")
text = objHTML.ParentWindow.ClipboardData.GetData("text")

Wscript.Echo text
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
レジストリの値の一覧と、キーの一覧の取得( VBScript クラス ) ( No.2 )
日時: 2014/08/24 18:52
名前: lightbox
Set Shell = CreateObject("Shell.Application")
if WScript.Arguments.Count = 0 then
	Shell.ShellExecute "cmd.exe", "/c Cscript.exe """ & Wscript.ScriptFullName & """ dummy & pause", "", "runas", 1
	Wscript.Quit
end if

Dim obj

' **********************************************************
' インスタンス作成
' **********************************************************
Set obj = new Wmireg

' **********************************************************
' デフォルトメソッド実行
' **********************************************************
Set list = obj(WMI_HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Run")

' **********************************************************
' 一覧表示
' **********************************************************
For Each data in list.Keys

	Wscript.Echo data & " : " & list(data)

Next

Wscript.Echo

' **********************************************************
' サブキーの配列を取得
' **********************************************************
Call obj.GetLSubKeyArray(WMI_HKEY_LOCAL_MACHINE, "SOFTWARE\ODBC\ODBCINST.INI")

' **********************************************************
' 一覧表示
' **********************************************************
For Each data in obj.objArray

	Wscript.Echo data

Next



const WMI_HKEY_CLASSES_ROOT = &H80000000
const WMI_HKEY_CURRENT_USER = &H80000001
const WMI_HKEY_LOCAL_MACHINE = &H80000002
const WMI_HKEY_USERS = &H80000003
const WMI_HKEY_CURRENT_CONFIG = &H80000005

const WMI_REG_SZ = 1 
const WMI_REG_EXPAND_SZ = 2 
const WMI_REG_BINARY = 3 
const WMI_REG_DWORD = 4 
const WMI_REG_MULTI_SZ = 7 

Class Wmireg

	Public objReg 
	Public objArray

	' ************************************************
	' Initialize イベント
	' ************************************************
	Private Sub Class_Initialize

		Set objReg = _
			GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & _
			".\root\default:StdRegProv") 

	End Sub

	' ************************************************
	' サブキーの配列を取得
	' ************************************************
	Public Function GetLSubKeyArray( defKey, strPath )

		Dim aSubKeys,str

		objReg.EnumKey defKey, strPath, objArray
	 
	end function

	' ************************************************
	' 値の一覧の連想配列を取得( 規定のメソッド )
	' ************************************************
	Public Default Function GetLValueArray( defKey, strPath )

		Dim aValueNames, aValueTypes, strValue, aValue

		Set var = CreateObject( "Scripting.Dictionary" )

		objReg.EnumValues defKey, strPath,_ 
			aValueNames, aValueTypes 
		For i=0 To UBound(aValueNames)
			Select Case aValueTypes(i) 
				Case WMI_REG_SZ
					objReg.GetStringValue _
					defKey,strPath,aValueNames(i),strValue
					var(aValueNames(i)) = strValue
				Case WMI_REG_EXPAND_SZ
					objReg.GetExpandedStringValue _
					defKey,strPath,aValueNames(i),strValue
					var(aValueNames(i)) = strValue
				Case WMI_REG_DWORD
					objReg.GetDWORDValue _
					defKey,strPath,aValueNames(i),strValue
					var(aValueNames(i)) = strValue
				Case WMI_REG_MULTI_SZ
					objReg.GetMultiStringValue _
					defKey,strPath,aValueNames(i),aValue
					var(aValueNames(i)) = aValue
				Case WMI_REG_BINARY 
					objReg.GetBinaryValue _
					defKey,strPath,aValueNames(i),aValue
					var(aValueNames(i)) = aValue
			End Select 
		Next 

		Set GetLValueArray = var

	end function

	' ************************************************
	' 文字列セット
	' ************************************************
	Public Function SetLString( defKey, strPath, strName, strValue )

		objReg.SetStringValue _
			defKey,strPath,strName,strValue 

	end function

	' ************************************************
	' 整数セット
	' ************************************************
	Public Function SetLDword( defKey, strPath, strName, dwValue )

		objReg.SetDWORDValue _
			defKey,strPath,strName,dwValue

	end function

End Class
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
ごみ箱のプロパティの表示 ( No.3 )
日時: 2014/08/24 19:07
名前: lightbox
' このセクションは、cscript.exe で処理を強制させるものです
str = WScript.FullName
str = Right( str, 11 )
str = Ucase( str )
if str <> "CSCRIPT.EXE" then
	str = WScript.ScriptFullName
	Set WshShell = CreateObject( "WScript.Shell" )
	Call WshShell.Run( "cmd.exe /c cscript.exe """ & str & """", 3 )
	WScript.Quit
end if

Set objShell = CreateObject("Shell.Application")

Set objFolder = objShell.NameSpace(0)
Set objFile = objFolder.ParseName("::{645FF040-5081-101B-9F08-00AA002F954E}")
objFile.InvokeVerb("properties")

' WMI の処理の為のオブジェクトを取得
' スクリプトを終了しないようにしています
Set obj = GetObject("winmgmts:\\.\root\cimv2")
' イベントの定義
Set objMonitor = obj.ExecNotificationQuery( _
	"select * from __InstanceModificationEvent " & _
	"where TargetInstance isa 'Win32_LocalTime' " & _
	" and TargetInstance.Year = 0" _
)

Wscript.Echo "プロパティ表示後は、このコマンドプロンプトは閉じて下さい"
Set objLatestEvent = objMonitor.NextEvent 
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
テキストファイル一括書き込み ( No.4 )
日時: 2014/08/24 21:38
名前: lightbox
strValue = "この文字列を一括で、" & vbCrLf & "ファイルに書き込みます"

Set ws = WScript.CreateObject("WScript.Shell")
TempPath = ws.ExpandEnvironmentStrings("%TEMP%") 
TempFile = TempPath & "\_.txt"
Set fso = WScript.CreateObject("Scripting.FileSystemObject")

on error resume next
Set objHandle = fso.CreateTextFile( TempFile, True )
if Err.Number <> 0 then
	Wscript.Echo Err.Description
else
	objHandle.Write( strValue )
	objHandle.Close
end if
on error goto 0
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
一つ前のテキストファイルの内容をクリップボードにコピー ( No.5 )
日時: 2014/08/24 21:51
名前: lightbox
Set ws = WScript.CreateObject("WScript.Shell")
TempPath = ws.ExpandEnvironmentStrings("%TEMP%") 
TempFile = TempPath & "\_.txt"

strExec = "cmd /c clip.exe < """ & TempFile & """"
Call ws.Run(strExec, 0, True)
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
GUID 取得 ( No.6 )
日時: 2014/08/24 21:58
名前: lightbox
Set TypeLib = CreateObject("Scriptlet.TypeLib")
Wscript.Echo TypeLib.guid

'テンポラリファイル名にするなら、

FileName = TypeLib.guid
FileName = Replace(FileName,"{","")
FileName = Replace(FileName,"}","")
FileName = Replace(FileName,"-","")
FileName = FileName & ".txt"

Wscript.Echo FileName
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
CDO.Message で SSL を使って Gmail でメール送信( 添付、HTML、テキスト ) ( No.7 )
日時: 2014/08/25 17:52
名前: lightbox
strUser = "Gmailユーザ"
strPass = "パスワード"
strTo = "宛先"

' ***********************************************************
' 使用するパラメータ
' ***********************************************************
strFrom = "わたしです <" & strUser & "@gmail.com>"
strTo = "あなたです <" & strTo & ">"

strServer = "smtp.gmail.com"
nPort = 465

' ***********************************************************
' オブジェクト
' ***********************************************************
Set Cdo = WScript.CreateObject("CDO.Message")

' ***********************************************************
' 自分のアドレスと宛先
' ***********************************************************
Cdo.From = strFrom
Cdo.To = strTo

' ***********************************************************
' 件名と本文
' ***********************************************************
Cdo.Subject	= "件名の文字列 / " & Now()
Cdo.Textbody = "テキスト本文" & vbCrLf & "改行は vbCrLf"

' ***********************************************************
' CC BCC HTMLメール( CC BCC はどちらか片方  )
' ※ 両方指定すると CC
' ***********************************************************
'Cdo.Cc = "メールアドレス1,メールアドレス2"
'Cdo.Bcc = "メールアドレス1,メールアドレス2"
Cdo.Htmlbody = "<img src=""http://winofsql.jp/image/winofsql.png"">"

' ***********************************************************
' ファイル添付あり
' ***********************************************************
Cdo.AddAttachment( "C:\Users\lightbox\Desktop\画像\_img.jpg" )
Cdo.AddAttachment( "C:\Users\lightbox\Downloads\del.gif" )

' ***********************************************************
' 設定
' ***********************************************************
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strServer
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = nPort

' SSL 使用
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = true

Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Cdo.Configuration.Fields.Item _
 ("http://schemas.microsoft.com/cdo/configuration/sendusername") = strUser
Cdo.Configuration.Fields.Item _ 
 ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = strPass

' ***********************************************************
' 設定の反映
' ***********************************************************
Cdo.Configuration.Fields.Update

' ***********************************************************
' 送信
' ***********************************************************
on error resume next
Cdo.Send
if Err.Number <> 0 then
	strMessage = Err.Description
else
	strMessage = "送信が完了しました"
end if
on error goto 0

Wscript.Echo strMessage
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
.xlsx と .xls で Excel のブックを作成 ( No.8 )
日時: 2014/08/25 18:08
名前: lightbox
Call NewBook("C:\Users\lightbox\Documents\test.xlsx", "")
Call NewBook("C:\Users\lightbox\Documents\test.xls", "OLD")

' **********************************************************
' 新しい Excel の Book を作成する
' **********************************************************
Function NewBook( BookPath, strType )

	Dim ExcelApp	' アプリケーション
	Dim ExcelBook	' ブック

	Set ExcelApp = Wscript.CreateObject("Excel.Application")

	' 警告を出さないようにする
	ExcelApp.DisplayAlerts = False

	' ブック追加
	ExcelApp.Workbooks.Add

	' 追加したブックを取得
	Set ExcelBook = ExcelApp.Workbooks( ExcelApp.Workbooks.Count )

	on error resume next
	' 保存
	' 56 は、拡張子 .xls で保存する場合に必要
	if strType = "OLD" then
		Call ExcelBook.SaveAs( BookPath, 56 )
	else
		Call ExcelBook.SaveAs( BookPath )
	end if
	if Err.Number <> 0 then
		MsgBox( "ERROR:" & Err.Description )
		ExcelApp.Quit
		Set ExcelApp = Nothing
	end if
	on error goto 0

	' Excel をアプリケーションとして終了
	ExcelApp.Quit
	' Excel を VBScript から開放
	Set ExcelApp = Nothing

End Function
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
キー入力をエミュレートしてタスクマネージャを開く ( No.9 )
日時: 2014/08/25 18:12
名前: lightbox
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set WshShell = WScript.CreateObject("WScript.Shell")
WshShell.SendKeys "^+({ESC})"
if GetOSVersion() < 6 then
	WScript.Sleep 500
	WshShell.AppActivate "Windows タスク マネージャ"
end if

Function GetOSVersion()

	Dim colTarget,str,aData,I,nTarget

	Set colTarget = objWMIService.ExecQuery( _
		 "select Version from Win32_OperatingSystem" _
	)
	For Each objRow in colTarget
		str = objRow.Version
	Next

	aData = Split( str, "." )
	For I = 0 to Ubound( aData )
		if I > 1 then
			Exit For
		end if
		if I > 0 then
			nTarget = nTarget & "."
		end if
		nTarget = nTarget & aData(I)
	Next

	GetOSVersion = CDbl( nTarget )

End Function
このアーティクルの参照用URLをクリップボードにコピー メンテナンス
複数項目のソート( 一時的なDBテーブル ) ( No.10 )
日時: 2014/08/25 18:28
名前: lightbox
Set WshShell = WScript.CreateObject("WScript.Shell")

Crun

' ***********************************************************
' 処理開始
' ***********************************************************
Const HKEY_LOCAL_MACHINE = &H80000002
Const adVarChar = 200
Const adInteger = 3

Dim ErrorMessage

Set objRegistry = GetObject("Winmgmts:root\default:StdRegProv")

strPath = "SOFTWARE\ODBC\ODBCINST.INI\ODBC Drivers"
bRet = WMIRegEnumValues( HKEY_LOCAL_MACHINE, strPath, aNames, aTypes )

if not bRet then
	Wscript.Echo ErrorMessage
	Wscript.Quit
end if

' ソートする前
For Each data in aNames

	Wscript.Echo data

Next

Wscript.Echo "-------------------------------------"

Set Rs = CreateObject("ADODB.Recordset")
Rs.Fields.Append "ソートキー", adVarChar,255
Rs.Fields.Append "最初の順番", adInteger
Rs.Open

nCount = 0
For Each data In aNames
	nCount = nCount + 1
	Rs.AddNew
	Rs.Fields("ソートキー").value = data
	Rs.Fields("最初の順番").value = nCount
Next

Rs.Sort = "ソートキー"
Rs.MoveFirst

' ソート後
Do while not Rs.EOF
	Wscript.Echo Rs.Fields("最初の順番").value & ":" & Rs.Fields("ソートキー").value & ""
	Rs.MoveNext
Loop

Rs.Close

' **********************************************************
' 列挙
' **********************************************************
Function WMIRegEnumValues ( nType, strPath, aNames, aTypes )
	WMIRegEnumValues = False

	on error resume next
	WMIRet = objRegistry.EnumValues( nType, strPath, aNames, aTypes )
	if Err.Number <> 0 then
		ErrorMessage = Err.Description
		Exit Function
	end if
	if WMIRet <> 0 then
		ErrorMessage = Hex( WMIRet )
		Exit Function
	end if
	on error goto 0

	WMIRegEnumValues = True
End Function

' ***********************************************************
' Cscript.exe で強制実行
' ***********************************************************
Function Crun( )

	Dim str

	str = WScript.FullName
	str = Right( str, 11 )
	str = Ucase( str )
	if str <> "CSCRIPT.EXE" then
		str = WScript.ScriptFullName
		strParam = " "
		For I = 0 to Wscript.Arguments.Count - 1
			if instr(Wscript.Arguments(I), " ") < 1 then
				strParam = strParam & Wscript.Arguments(I) & " "
			else
				strParam = strParam & Dd(Wscript.Arguments(I)) & " "
			end if
		Next
		Call WshShell.Run( "cmd.exe /c cscript.exe " & Dd(str) & strParam & " & pause", 3 )
		WScript.Quit
	end if

End Function

' ***********************************************************
' ダブルクォート
' ***********************************************************
Function Dd( strValue )

	Dd = """" & strValue & """"

End function
このアーティクルの参照用URLをクリップボードにコピー メンテナンス