GINPRO / SQLの窓と銀プログラマ

<meta http-equiv="content-type" content="text/html; charset=SHIFT_JIS">
<SCRIPT language="VBScript">

	Dim WshShell,TargetDir,objShell,nId

	Set WshShell = CreateObject( "WScript.Shell" )
	TargetDir = WshShell.SpecialFolders("Favorites")
	Set objShell = CreateObject("Shell.Application")

	Set Fso = CreateObject( "Scripting.FileSystemObject" )

Function SetTable()

	Set objFolder = Fso.GetFolder( TargetDir )
	Set objFiles = objFolder.SubFolders 

	str=""
	str=str&"<TABLE id=ieex border=0 cellspacing=1 cellpadding=6> "&vbCrLf
	str=str&"<TH style='width:35px;'></TH> "&vbCrLf
	str=str&"<TH>エントリをクリックするとプロパティを開きます<br>エントリが二段で下がリンクの場合クリックすると IE で開く事ができます</TH> "&vbCrLf
	str=str&"<TH></TH> "&vbCrLf

	nId = 1
	For each objFile in objFiles

		str=str&"<tr>" & vbCrLf
		str=str&"<td>" & vbCrLf
		' チェックボックス ( check+n )
		str=str&"<input type='checkbox' id=check" & nId

		' hidden の場合
		if objFile.Attributes and 2 then
			' なにもしない
		else
			' 通常表示されている状態
			str=str&" checked "
		end if

		str=str&">"
		str=str&"</td>" & vbCrLf
		str=str&"<td style='background-color:silver;font-weight:bold;'>" & vbCrLf
		str=str&"<input type='button' value='フォルダに移動' onClick='Call ChangeDir("""& TargetDir & "\" & objFile.Name &""")'>&nbsp;"
		str=str&"<span id=target" & nId & " style='cursor:pointer;color:navy;vertical-align:4px' onClick='Call OpenProp(""" & nId & """)'>["

		Set objShellFolder = objShell.NameSpace(TargetDir & "\" & objFile.Name)

		str=str&objShellFolder.Title
		str=str&"]</span>"
		str=str&"</td>" & vbCrLf
		str=str&"<td style='background-color:silver;font-weight:bold;' id=fullpath" & nId & ">"
		str=str&TargetDir & "\" & objFile.Name
		str=str&"</td>" & vbCrLf
		str=str&"</tr>" & vbCrLf

		nId = nId + 1

	Next

	Set objFiles = objFolder.Files

	For each objFile in objFiles

		if Ucase(Right(objFile.Name,4)) = ".URL" then

			str=str&"<tr>" & vbCrLf
			str=str&"<td>" & vbCrLf
			' チェックボックス ( check+n )
			str=str&"<input type='checkbox' id=check" & nId
		
			' hidden の場合
			if objFile.Attributes and 2 then
				' なにもしない
			else
				' 通常表示されている状態
				str=str&" checked "
			end if
		
			str=str&">"
			str=str&"</td>" & vbCrLf
			str=str&"<td>" & vbCrLf
			str=str&"<span id=target" & nId & " style='cursor:pointer;color:navy' onClick='Call OpenProp(""" & nId & """)'>"
			str=str&objFile.Name
			str=str&"</span>"
		
			str=str&"<br>"
			Set oUrlLink = WshShell.CreateShortcut(TargetDir & "\" & objFile.Name)
			if Ucase(Left(Trim(oUrlLink.TargetPath),11)) <> "JAVASCRIPT:" then
				str=str&"<a style='color:blue;' href='"
				str=str&oUrlLink.TargetPath
				str=str&"' target=_blank>"&oUrlLink.TargetPath&"</a>"
			end if
		
			str=str&"</td>" & vbCrLf
			str=str&"<td id=fullpath" & nId & ">"
			str=str&TargetDir & "\" & objFile.Name
			str=str&"</td>" & vbCrLf
			str=str&"</tr>" & vbCrLf
		
			nId = nId + 1

		end if

	Next

	nId = nId - 1

	str=str&"</TABLE>"&vbCrLf

	document.getElementById("table").innerHTML = str

End Function

Function OpenProp( nRow )

	Dim str,str1,str2

	str = document.getElementById("fullpath"&nRow).innerText

	Dim objWork,bFlg

	if Ucase(document.getElementById("fullpath"&nRow).style.backgroundColor) = "SILVER" then
		Set objWork = Fso.GetFolder(str)
	else
		Set objWork = Fso.GetFile( str )
	end if
	bFlg = False
	if (objWork.Attributes and 2) = 2 then
		objWork.Attributes = objWork.Attributes and (255-2)
		bFlg = True
	end if

	Set objFolder = objShell.NameSpace(TargetDir)

	For each objFile in objFolder.items
		if str = objFile.Path then
			Set obj = objFile.Verbs
			For i = 0 To obj.Count - 1
				if InStr( obj.item(i).Name, "プロパティ" ) > 0 then
					objFile.InvokeVerb("Properties")
				end if
			Next
		end if
	Next

	if bFlg then
		objWork.Attributes = objWork.Attributes or 2
	end if

End Function

Function AttUpdate()

	Dim idx,str,work,objFile

	For idx = 1 to nId
		' 対象となるパス
		str = document.getElementById("fullpath"&idx).innerText

		if Ucase(document.getElementById("fullpath"&idx).style.backgroundColor) = "SILVER" then
			' ファイルオブジェクト
			Set objFile = Fso.GetFolder(str)
		else
			' ファイルオブジェクト
			Set objFile = Fso.GetFile(str)
		end if

		if document.getElementById("check"&idx).checked then
			' チェックされているので hidden を除く
			objFile.Attributes = objFile.Attributes and (255-2)
		else
			' チェックが外されているので hidden を設定する
			objFile.Attributes = objFile.Attributes or 2
		end if
	Next

	alert("更新しました　　　")

End Function

Function ChangeDir( path )

	TargetDir = path

	Call SetTable()

	document.title = path

End Function

</SCRIPT>
<html>
<head>
<title>お気に入り ディレクトリ/メンテナンス</title>
<HTA:APPLICATION ID="Sqlwin"
	BORDERSTYLE="sunken"
	INNERBORDER="yes"
	SCROLL="yes"
	ICON="http://winofsql.jp/WinOfSql.ico"
>
<style type="text/css">
* {
	font-size:12px;
	font-family: "メイリオ";
}
body {
	margin:0;
}

#ieex {
	table-layout:fixed;
	margin-top:4px;
	margin-left:20px;
	width:1000px;
	background-color:black;
}

#ieex td,#ieex th {
	background-color:white;
}

#update {
	margin-top:0px;
	margin-left:20px;
}

</stylE>
</head>
<body>
<div style='padding:5px 20px;font-size:16px;font-weight:bold'>IE のお気に入りディレクトリにあるファイルの表示・非表示を設定する</div>
<div style='width:1000px;'>
	<input style='float:right' type="button" value="HOME" onclick='TargetDir = WshShell.SpecialFolders("Favorites"):Call SetTable():document.title = "お気に入り ディレクトリ/メンテナンス"'>
	<input id=update type=button value="更新" onClick='Call AttUpdate()'> <span style='vertical-align:4px'>チェックを外して更新すると、IE 側で表示だけしなくなります(<b>IE は再起動するか、タブを複製して下さい</b>)。</span>
</div>
<div id=table>

</BODY>
</html>
<SCRIPT for=window event=onload language="VBScript">

	window.focus()
	top.moveTo 0, 0
	top.resizeTo screen.width, screen.height - 32

	Call SetTable()

</SCRIPT>

<SCRIPT for=window event=onunload language="VBScript">

</SCRIPT>