| |
<%
Call Response.AddHeader( "Content-Type", "text/html; Charset=shift_jis" )
Response.ExpiresAbsolute=#May 31,2000 23:59:59#
Set MyData = Server.CreateObject("Scripting.Dictionary")
Set MyCookies = Server.CreateObject("Scripting.Dictionary")
if not IsMultipart() then
if Request.Form.Count <> 0 then
For Each workKey In Request.Form
MyData( workKey ) = Request.Form( workKey )
Next
end if
end if
if Request.QueryString.Count <> 0 then
For Each workKey In Request.QueryString
MyData( workKey ) = Request.QueryString( workKey )
Next
end if
For Each workKey In Request.Cookies
MyCookies( workKey ) = Request.Cookies( workKey )
Next
' **********************************************************
' HTTP アップロード用のチェック関数
' **********************************************************
Function IsMultipart( )
Dim ContentType
ContentType = Left( Request.ServerVariables("CONTENT_TYPE"), 9 )
if Ucase( ContentType ) = "MULTIPART" then
IsMultipart = True
else
IsMultipart = Flase
end if
end Function
' **********************************************************
' ログインページへの移動
' **********************************************************
Function LoginAction( strTarget )
if Session( strTarget ) = "" then
Session( "ReturnPath" ) = _
Request.ServerVariables( "SCRIPT_NAME" )
Redirect( Application("LOGIN_PATH") )
Response.End
end if
End Function
' **********************************************************
' ログインチェック
' **********************************************************
Function LoginCheck( strTarget )
if Session( strTarget ) = "" then
Response.Write "<HTML>"
Response.Write "<HEAD>"
Response.Write "<META HTTP-EQUIV="
Response.Write """Content-Type"""
Response.Write " CONTENT="
Response.Write """text/html; CHARSET=shift_jis"""
Response.Write ">"
Response.Write "<BODY>"
Response.Write "ログインを行なって下さい"
Response.Write "</BODY>"
Response.Write "</HEAD>"
Response.Write "</HTML>"
Response.End
end if
End Function
' **********************************************************
' 引継ぎ用埋め込みデータの作成
' **********************************************************
Function CreateInData( )
For Each workKey In MyData
if Mid( workKey, 1, 2 ) = "In" then
if Mid( workKey, 1, 3 ) <> "In2" then
InData = InData & _
"<INPUT type=hidden name=" & workKey
InData = InData & _
" value=""" & MyData(workKey) & _
""">" & vbCrLf
end if
end if
Next
End Function
' **********************************************************
' オプション文字列の作成
' **********************************************************
Function CreateOption( Cn, Rs, FieldName, Query )
Dim strRet
Call DBGet( Cn, Rs, Query, false )
Do While not Rs.EOF
strRet = strRet & "<OPTION value=""" & Rs.Fields(0).Value & """"
if Rs.Fields(0).Value & "" = MyData(FieldName) then
strRet = strRet & " selected"
end if
strRet = strRet & ">" & Rs.Fields(1).Value & "</OPTION>" & vbCrLf
Rs.MoveNext
Loop
CreateOption = strRet
End Function
' **********************************************************
' クッキーデータの設定
' **********************************************************
function SetCookie( strKey, strValue )
Response.Cookies( strKey ) = strValue
end function
' **********************************************************
' クッキーデータの復帰
' **********************************************************
function RestoreCookie( )
Dim strKey
For Each strKey In Request.Cookies
if Mid( strKey, 1, 2 ) = "In" then
if MyData( strKey ) = "" then
MyData(strKey) = Request.Cookies(strKey)
end if
end if
Next
end function
' **********************************************************
' 環境
' **********************************************************
Const COMMON_AUTHOR = "LIGHTBOX"
COMMON_VERSION = "4.0911"
' **********************************************************
' リダイレクト
' **********************************************************
function Redirect( UrlTarget )
Response.Redirect UrlTarget
end function
' **********************************************************
' 挟み込み関数
' **********************************************************
function Enclose( strValue, strChr, nType, strOption )
strRet = ""
Select Case nType
' 単純挟み込み
Case 0
strRet = strChr & strValue & strChr
' HTML挟み込み
Case 1
strRet = "<" & strChr & " " & strOption & ">"
strRet = strRet & strValue
strRet = strRet & "</" & strChr & ">"
End Select
Enclose = strRet
end function
' **********************************************************
' ' 挟み込み関数
' **********************************************************
function Ss( strValue )
Ss = Enclose( strValue, "'", 0, "" )
end function
' **********************************************************
' " 挟み込み関数
' **********************************************************
function Dd( strValue )
Dd = Enclose( strValue, """", 0, "" )
end function
' **********************************************************
' <TH> 挟み込み関数
' **********************************************************
function Th( strValue, strOption )
Th = Enclose( strValue, "TH", 1, strOption )
end function
' **********************************************************
' <TD> 挟み込み関数
' **********************************************************
function Td( strValue, strOption )
Td = Enclose( strValue, "TD", 1, strOption )
end function
' **********************************************************
' <A href> 挟み込み関数
' **********************************************************
function Alink( strUrl, strValue, strOption )
Alink = Enclose( strValue, "A", 1, "href=" & Dd(strUrl) & " " & strOption )
end function
' **********************************************************
' <DIV> 挟み込み関数
' **********************************************************
function Div( strValue, strOption )
Div = Enclose( strValue, "DIV", 1, strOption )
end function
' **********************************************************
' 改行付表示関数
' **********************************************************
function OutCr( strValue )
Response.Write strValue & vbCrLf
end function
' **********************************************************
' 改行+<BR> 表示関数
' **********************************************************
function print( strValue )
Response.Write strValue & "<BR>" & vbCrLf
end function
' **********************************************************
' デバッグ用情報表示関数
' **********************************************************
function DispHash( Hash, strTitle )
Dim strKey,strOption
strOption = "bgcolor=white"
OutCr( "<TABLE border=0 bgcolor=black cellspacing=1>" )
OutCr( Th( strTitle & " 名称", "bgcolor=silver" ) )
OutCr( Th( "内容", "bgcolor=silver" ) )
if ( Hash.Count <> 0 ) then
For Each strKey In Hash
OutCr( "<TR>" )
OutCr( Td( strKey, strOption ) )
OutCr( Td( Hash( strKey ), strOption ) )
OutCr( "</TR>" )
Next
end if
OutCr( "</TABLE>" )
end function
' **********************************************************
' デバッグ用情報表示関数
' **********************************************************
function DispDebug( strType )
Dim strTableTag,strErr,strOption
strTableTag = "<TABLE border=0 bgcolor=black cellspacing=1>"
strErr = "デバッグ用情報表示関数への引数が誤っています"
strOption = "bgcolor=white"
Select Case strType
case "VER"
OutCr( strTableTag )
OutCr( Th( "現在のVBScriptのメジャーバージョン", "bgcolor=silver" ) )
OutCr( "<TR>" )
OutCr( Td( ScriptEngineMajorVersion, strOption ) )
OutCr( "</TR>" )
OutCr( "</TABLE>" )
case "POST"
if not IsMultipart() then
Call DispHash( Request.Form, "POST" )
end if
case "GET"
Call DispHash( Request.QueryString, "GET" )
case "SESSION"
Call DispHash( Session.Contents, "SESSION" )
case "ENV"
Call DispHash( Request.ServerVariables, "ENV" )
case "SERVER"
Call DispHash( Request.ServerVariables, "ENV" )
case "COOKIE"
Call DispHash( MyCookies, "COOKIE" )
case "REQUEST"
Call DispHash( MyData, "REQUEST" )
Case Else
OutCr( TableTag )
OutCr( Th( strErr, strOption ) )
OutCr( "</TABLE>" )
End Select
end function
' **********************************************************
' デバッグ用メッセージの表示
' **********************************************************
function DispData()
Call DispHash( MyData, "入力" )
Call DispHash( Request.QueryString, "GET" )
if not IsMultipart() then
Call DispHash( Request.Form, "POST" )
end if
Call DispHash( Session.Contents, "SESSION" )
Call DispHash( MyCookies, "COOKIE" )
Call DispHash( Application.Contents, "Application" )
end function
%>
| |
