c0metssd @ ウィキ
c0metssd @ ウィキ

HTAでランチャー作成

メモ帳、TeraTerm,ブラウザ、エクスプローラー、エクセルを呼び出す例
起動時と終了時に時刻をログファイル「稼動ログ.txt」に残すおまけ付き 

<html>
<head>
<hta:application>
<style type="text/css">
.demo1 {
	border-top: 1px solid #ccc;
	border-right: 1px solid #999;
	border-bottom: 1px solid #999;
	border-left: 1px solid #ccc;
	padding: 5px 5px;
	margin: 2px 1px;
	font-weight: bold;
	cursor: pointer;
	color: #666;
}
</style>
<SCRIPT Language="VBScript">
	Const ForReading = 1
	Const ForWriting = 2
	Const ForApending = 8
	'Const vbShortDate = 2
	'Const vbShortTime = 4
	Const DATELOGNAME = "稼動ログ.txt"

	Function fnWriteTime
		Dim objFileSys
		Dim strScriptPath
		Dim strOpenFile
		Dim objTextStream
		Dim strText

		Set objFileSys = CreateObject("Scripting.FileSystemObject")
		strScriptPath = Replace(ScriptFullName,ScriptName,"")
		strOpenFile = objFileSys.BuildPath(strScriptPath,DATELOGNAME)
		Set objTextStream = objFileSys.OpenTextFile(strOpenFile, ForReading)

		Dim WriteBuf: WriteBuf = ""
		Dim Found: Found = False
		Dim StrDate:StrDate = FormatDateTime(Date, vbShortDate)
		Dim NowTime:NowTime = FormatDateTime(Time, vbShortTime)
		Do Until objTextStream.AtEndOfLine = True
			strText = objTextStream.ReadLine
			strVal = Split(strText, ",")
			If StrComp(StrDate, strVal(0), 1) = 0 then
				Found = True
				If Len(strval(1)) = 0 Then
					' 開始に入れる
					WriteBuf = WriteBuf & strval(0) & "," & NowTime & vbCrLf
				Else
					' 終了に入れる
					WriteBuf = WriteBuf & strval(0) & "," & strval(1) & "," & NowTime & vbCrLf
				End If
			Else
				' バッファに溜め込む
				WriteBuf = WriteBuf & strText & vbCrLf
			End If
		Loop
		If Found = False Then
			WriteBuf = WriteBuf & StrDate & "," & NowTime & vbCrLf
		End If
		objTextStream.Close

		Set objTextStream = Nothing
		Set objFileSys = Nothing

		' 書き込み
		fnFileWrite(WriteBuf)

	End Function

	Function fnFileWrite(Str)
		Set objFSO = CreateObject("Scripting.FileSystemObject")
		Set objFile = objFSO.OpenTextFile(DATELOGNAME, ForWriting, True)
		objFile.WriteLine Str
		objFile.Close
		Set objFile = Nothing
		Set objFSO = Nothing
	End function

	Const Maximized = -4137 // ウィンドウの最大化
	Function RunExcel(fname)
		Dim xl
		Set xl = CreateObject("Excel.Application")
		xl.Workbooks.Open(fname)
		xl.DisplayAlerts = true
		xl.Visible = True '立ち上げたExcelを表示する
		'Sleep(1000)
		'最前面に表示する
		toFront(xl.Caption)
		if xl.WindowState = -4143 then
			xl.WindowState = Maximized
		else
			xl.WindowState = -4143
		end if
		set xl = nothing
	End Function

	Function RunExec(Cmd)
		Dim WshShell
		Set WshShell = CreateObject("WScript.Shell")
		Return = WshShell.Run(Cmd, 1, true)
		set WshShell = nothing
	End Function

	Function RunExplore(Path)
		dim objShell
		set objShell = CreateObject("shell.application")
		objShell.Explore(Path)
		set objShell = nothing
	End Function

	Sub Sleep(millisec)
		Dim Wshell
		Dim dstart
		Set Wshell = CreateObject("WScript.Shell")
		dstart = timer * 1000
		Do while True
			Wshell.Run "%comspec% /c @",0,1
					'■環境によっては、単純に ＞　Wshell.Run "@",0,1　でも動くのだが…
			if timer * 1000 >= dstart + millisec then Exit Do
		Loop
		Set Wshell = Nothing
	End Sub

	Function toFront(Name)
		' 前面に出す
		Dim objWShell
		Set objWShell = CreateObject("WScript.Shell")
		objWShell.AppActivate Name
		'objWShell.SendKeys "% X"
		set objWShell = nothing
	    'CreateObject("WScript.Shell").AppActivate Name
	End Function

	Function RunIE(urlIE)
		Dim objIE
		Set objIE = CreateObject("InternetExplorer.application")
		objIE.Visible = True
		'操作したいページを表示
		objIE.Navigate2 urlIE


		'開ききるのを待ちます
		Do While objIE.busy
			Sleep(1000)
		Loop
		'Do While objIE.readyState < 4
		'	Sleep(1000)
		'Loop

		' 前面に出す
		toFront(objIE.LocationName)
		set objIE = nothing
	End Function

	' ロードイベント
	Sub Window_onLoad
		window.offscreenBuffering = True
		Call fnWriteTime
		'Call fnFileWrite("開始")
	End Sub

	Sub Window_onBeforeUnLoad
		Call fnWriteTime
		'Call fnFileWrite("終了")
	End Sub

	' ボタンイベント
	Sub ie_onClick
		RunIE("http://www.yahoo.co.jp")
	End Sub

	Sub excel_onClick
		RunExcel("C:\Opt\worktimerec\hoge.xlsx")
	End Sub

	Sub notepad_onClick
		RunExec("notepad")
	End Sub

	Sub teraterm_onClick
		RunExec("ap_server_jboss.ttl")
	End Sub

	Sub exploler_onClick
		RunExplore("C:\")
	End Sub

</SCRIPT>

<SCRIPT language="JavaScript">
<!--
// ウィンドウを指定されたサイズに変更する
function init() {
  resizeTo(550,100);
}
//-->
</SCRIPT>


</head>

<body onLoad="init()">
<input class="demo1" id="notepad" type="button" value="メモ帳"/>
<input class="demo1" id="teraterm" type="button" value="TeraTerm"/>
<input class="demo1" id="ie" type="button" value="Yahoo!"/>
<input class="demo1" id="exploler" type="button" value="エクスプローラ"/>
<input class="demo1" id="excel" type="button" value="Excel"/>
</BODY>
</html>
「HTAでランチャー作成」をウィキ内検索
最終更新：2014年07月31日 18:57