<%
option Explicit
%>
<!-- #include file="./include_dim.txt" -->
<!-- #include file="./include_static.txt" -->
<!-- #include file="./include_variable.txt" -->
<!-- #include file="./include_strconv.asp" -->
<%
'################################################
'	 名称	：共通変数・共通関数の定義
'	 作成日	：2009/12/2
'	 作成者	：小野
'	 目的	：共通変数・共通関数を定義をする
'	 概要	：
'################################################
%>
<%

	Response.Buffer = True
	Response.AddHeader "Content-Type", "text/html; charset=Shift_JIS"	'文字化け対策

	Session.Timeout = 1440
	Server.ScriptTimeout = 1200


	Dim Query
	Dim Content

	'運用管理者ID取得
	Dim SysAdminID
	Dim SysAdminPass
	Dim SysVer
	Query = " SELECT * FROM TMシステム WHERE システムCD = 'SFC' "
	Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	If Not(Content.BOF Or Content.EOF) Then
		SysAdminID = "" & Content.Fields("管理者ID")
		SysAdminPass = "" & Content.Fields("パスワード")
		SysVer = "" & Content.Fields("バージョン")
	End If

	'グローバル変数（セッション代替）
	'※セッション変数の配列名称はスペルミスしてもNULLが返るだけでエラーにならないが
	'※通常変数に代入すれば変数名称のスペルミスでエラーが返るので間違いが起こらない。
	'管理者フラグ
	Dim GB_SysAdminPC
	GB_SysAdminPC = Session("ECMallSysAdminPC")
	Dim GB_SysAdmin
	GB_SysAdmin = Session("ECMallSysAdmin")
	Dim GB_SchoolAdmin
	GB_SchoolAdmin = Session("ECMallSchoolAdmin")
	Dim GB_ShopAdmin
	GB_ShopAdmin = Session("ECMallShopAdmin")

	'ビジターID
	Dim GB_VisitorID
	GB_VisitorID = Session("ECMallVisitorID")
	'ログインID
	Dim GB_UserID
	GB_UserID = Session("ECMallUserID")
	'パスワード
	Dim GB_Password
	GB_Password = Session("ECMallPassword")

	'演習CD ※ローカルモード用
	Dim GB_PracticeCD
	GB_PracticeCD = Session("ECMallPracticeCD")

	If Request("Logout") = "1" Then
		'管理者ログアウト時の処理
		Session("ECMallSysAdmin") = ""
		GB_SysAdmin = Session("ECMallSysAdmin")
		Session("ECMallSchoolAdmin") = ""
		GB_SchoolAdmin = Session("ECMallSchoolAdmin")
		Session("ECMallShopAdmin") = ""
		GB_ShopAdmin = Session("ECMallShopAdmin")
		If LocalMode = "1" Then
			'ローカルモードではビジターも抜ける
			Session("ECMallVisitorID") = ""
			GB_VisitorID = Session("ECMallVisitorID")
			Session("ECMallUserID") = ""
			GB_UserID = Session("ECMallUserID")
			Session("ECMallPassword") = ""
			GB_Password = Session("ECMallPassword")
			Session("ECMallPracticeCD") = ""
			GB_PracticeCD = Session("ECMallPracticeCD")
		End If
	End If

	'オートログインレベル（1：学校管理者、2：運用管理者）
	Dim GB_AutoLogin
	GB_AutoLogin = Session("AutoLogin")
	If "" & GB_AutoLogin = "" Then
		GB_AutoLogin = 0
	End If

	'ホスト名
	Dim GB_HostName
	GB_HostName = ""
	Dim LebelDomain
	LebelDomain = Split(LCase(Request.ServerVariables("SERVER_NAME")), ".")
	GB_HostName = LebelDomain(0) 'URLの先頭レベルドメイン
	'開発サーバ強制                       IPアドレス強制
	If LCase(GB_HostName) = "kaihatsu" Or IsNumeric(GB_HostName) Or LocalMode = "1" Then
		GB_HostName = "hsns"
	End If
	'テスト用強制
'	GB_HostName = "kanan"


	'公開/ローカルモード強制
	If Session("ECMallLocalMode") <> "" Then
		LocalMode = Session("ECMallLocalMode")
	End If


	'商品一覧表示数
	Dim GB_ItemViewCnt
	GB_ItemViewCnt = 10

	'アクセスログ保存日数
	Dim AccessLogTerms
	AccessLogTerms = 367

	'画像処理オブジェクト
	Dim LeadObj
	Set LeadObj = Server.CreateObject("LEAD.LeadCtrl.121")
	Dim DdleObj
	Set DdleObj = Server.CreateObject("Doodle2.MyCanvas")

	'ユーザーエージェント
	Dim GB_UserAgent
'	If "" & Session("UserAgent") = "" Then
		Session("UserAgent") = "Mobile"
		GB_UserAgent = Request.ServerVariables("HTTP_USER_AGENT")
		'LCaseして小文字判定すると失敗する
		If InStr(GB_UserAgent, "iPhone") > 0 Then
		ElseIf InStr(GB_UserAgent, "Android") > 0 And InStr(GB_UserAgent, "Mobile") > 0 Then
		ElseIf InStr(GB_UserAgent, "Android") > 0 And InStr(GB_UserAgent, "Opera") > 0 And InStr(GB_UserAgent, "Mini") > 0 Then
		ElseIf InStr(GB_UserAgent, "Windows Phone") > 0 Then
		Else
			Session("UserAgent") = "PC"
		End If
'	End If
'	Session("UserAgent") = "aa"
	GB_UserAgent = Session("UserAgent")

	'スマフォ用レイアウト
	If GB_UserAgent <> "PC" Then
		WidthAll = 540 '全体幅
	End If


	Dim Uniq
	Uniq = TimeUniq()
Function TimeUniq()
	TimeUniq = "TimeUniq=" & TimeUniqInt
End Function
Function TimeUniqInt()
	Dim MonthDay(12),ii,mtmp,TmpNow
	MonthDay(1) = 31	'月別日数配列
	MonthDay(2) = 28.25
	MonthDay(3) = 31
	MonthDay(4) = 30
	MonthDay(5) = 31
	MonthDay(6) = 30
	MonthDay(7) = 31
	MonthDay(8) = 31
	MonthDay(9) = 30
	MonthDay(10) = 31
	MonthDay(11) = 30
	MonthDay(12) = 31
	ii = 1
	mtmp = 0
	TmpNow = Now
	Do While ii < Month(TmpNow)
		mtmp = mtmp + MonthDay(ii)	'1/1～前月末までの日数を算出
		ii = ii + 1
	Loop
	TimeUniqInt = (((Year(TmpNow) - 1) * 365.25 + mtmp + (Day(TmpNow) - 1)) * 24 * 60 * 60 + Timer()) * 10000
End Function


'VisitorIDからビジターYMDまたはビジターIDを抽出
Function VisitorIDSplit(VisitorID, Mode)
	Dim TmpStr
	TmpStr = ""
	If Len(VisitorID) = 15 Then
		If Mode = "YMD" Then
			TmpStr = Left(VisitorID, 8)
		Else 'If Mode = "ID" Then
			TmpStr = ZeroTrim(Right(VisitorID, 7))
			If Not(IsNumeric(TmpStr)) Then
				TmpStr = ""
			End If
		End If
	End If
	VisitorIDSplit = TmpStr
End Function
Function VisitorIDGet(VisitorID)
	VisitorIDGet = VisitorIDSplit(VisitorID, "ID")
End Function
Function VisitorYMDGet(VisitorID)
	VisitorYMDGet = VisitorIDSplit(VisitorID, "YMD")
End Function


Function ZeroTrim(Target)
	Target = "" & Target
	Dim ii
	Dim Cnt
	Cnt = Len(Target)
	While Left(Target, 1) = "0" And Len(Target) > 1
		Target = Mid(Target, 2)
	Wend
'	If Target = "" Then
'		Target = "0"
'	End If
	ZeroTrim = CInt(Target)
End Function


Function InternetCheck()
'							インターネット強制許可でない										kaihatsuローカルIP以外										インターネットアドレス
	If InternetDeny = 1 And Session("ECMallPermit") <> "1" And Request.ServerVariables("SERVER_NAME") <> "192.168.0.253" And InStr(Request.ServerVariables("SERVER_NAME"), ".") > 0 Then
		Response.Write("<html><head><title>Error</title></head><body><head><title>Directory Listing Denied</title></head>")
		Response.Write("<body><h1>Directory Listing Denied</h1>This Virtual Directory does not allow contents to be listed.</body></body></html>")
		InternetCheck = False
	ElseIf Request.ServerVariables("REMOTE_ADDR") = "207.244.82.181" _
		Or Request.ServerVariables("REMOTE_ADDR") = "105.156.65.189" _
		Or Request.ServerVariables("REMOTE_ADDR") = "89.238.178.23" _
		Or Request.ServerVariables("REMOTE_ADDR") = "" Then
		InternetCheck = False
	Else
		InternetCheck = True
	End If
End Function


Function VisitorCheck()
	VisitorCheck = VisitorCheckMain(0)
End Function
Function VisitorCheckMail()
	VisitorCheckMail = VisitorCheckMain(1)
End Function

Function VisitorCheckMain(Mode)
'If 0=1 Then
	VisitorCheckMain = False
	'古いビジターIDを削除（1ヶ月以上前のもの）
	'※ビジター有効状態において他ノードから当該ビジターを削除されると不都合が出るが、
	'※有効状態で最終アクセス日時が1ヶ月以上前ならその間にセッションが切れるので有り得ない。
	If LocalMode <> "1" Then 'ローカルモードはショップと連動するので自動削除しない。ショップ削除時に連動削除する。
		Query = "exec SPMビジター削除自動"
		Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	End If
	If GB_VisitorID = "" Then
		Dim Query
		Dim Content
		If LocalMode <> "1" Then
			'クッキーを参照
			If Request.Cookies("ECMall")("VisitorID") <> "" And VisitorIDSplit(Request.Cookies("ECMall")("VisitorID"), "ID") <> "" Then
				'クッキーが存在する場合
				Query = "exec SPMビジター取得 '" & VisitorIDSplit(Request.Cookies("ECMall")("VisitorID"), "YMD") & "', " & VisitorIDSplit(Request.Cookies("ECMall")("VisitorID"), "ID") & ""
				Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
				If Not(Content.BOF Or Content.EOF) Then
					'クッキーが合致すればセッション復元
					Session("ECMallVisitorID") = Content.Fields("ビジターYMD") & Right("000000" & Content.Fields("ビジターID"), 7)
					VisitorCheckMain = True
				End If
			End If
			If Not(VisitorCheckMain) Then
				'新規
				Query = "exec SPMビジター作成 '" & Year(Now) & Right("0" & Month(Now), 2) & Right("0" & Day(Now), 2) & "'"
				Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
				If Not(Content.BOF Or Content.EOF) Then
					Session("ECMallVisitorID") = Content.Fields(0) & Right("000000" & Content.Fields(1), 7)
					VisitorCheckMain = True
				End If
			End If
		Else
			'ローカルモードではビジターログインに飛ばす
			If Mode = 1 Then
				Response.Redirect(HomeAliasSL & "visitor.asp?Mail=1")
			Else
				Response.Redirect(HomeAliasSL & "visitor.asp")
			End If
		End If
		'グローバル変数に代入
		GB_VisitorID = Session("ECMallVisitorID")
	Else
		VisitorCheckMain = True
	End If
	'クッキー保存
	Response.Cookies("ECMall")("VisitorID") = GB_VisitorID
	Response.Cookies("ECMall").Expires = DateAdd("m", 1, Now) '有効期限1ヶ月
	If Not(VisitorCheckMain) Then
		Response.Write("メンテナンス中")
	Else
		'最終アクセス日時更新
		'クローラ・ロボットを除外
		Dim TmpAgent
		TmpAgent = LCase(Request.ServerVariables("HTTP_USER_AGENT"))
		If InStr(TmpAgent, LCase("Googlebot")) < 1 And _
			InStr(TmpAgent, LCase("crawler")) < 1 And _
			InStr(TmpAgent, LCase("feedfetcher")) < 1 And _
			InStr(TmpAgent, LCase("360spider")) < 1 And _
			InStr(TmpAgent, LCase("java/1.7.0")) < 1 And _
			InStr(TmpAgent, LCase("Googlebot-Image")) < 1 And _
			InStr(TmpAgent, LCase("YPBot")) < 1 And _
			InStr(TmpAgent, LCase("Yahoo! Slurp")) < 1 And _
			InStr(TmpAgent, LCase("bingbot")) < 1 And _
			InStr(TmpAgent, LCase("bitlybot")) < 1 And _
			InStr(TmpAgent, LCase("Yeti")) < 1 And _
			InStr(TmpAgent, LCase("Baiduspider")) < 1 And _
			InStr(TmpAgent, LCase("Steeler")) < 1 And _
			InStr(TmpAgent, LCase("ichiro")) < 1 And _
			InStr(TmpAgent, LCase("hotpage.fr")) < 1 And _
			InStr(TmpAgent, LCase("ia_archiver")) < 1 And _
			InStr(TmpAgent, LCase("YandexBot")) < 1 And _
			InStr(TmpAgent, LCase("msnbot")) < 1 And _
			InStr(TmpAgent, LCase("zenback bot")) < 1 And _
			InStr(TmpAgent, LCase("Y!J-BRI")) < 1 And _
			InStr(TmpAgent, LCase("TurnitinBot")) < 1 And _
			InStr(TmpAgent, LCase("Google Desktop")) < 1 And _
			InStr(TmpAgent, LCase("BaiduMobaider")) < 1 And _
			InStr(TmpAgent, LCase("Seznam screenshot-generator")) < 1 And _
			InStr(TmpAgent, LCase("SiteBot")) < 1 And _
			InStr(TmpAgent, LCase("Purebot")) < 1 And _
			InStr(TmpAgent, LCase("emBot-GalaBuzz/Nutch")) < 1 And _
			InStr(TmpAgent, LCase("Search17Bot")) < 1 And _
			InStr(TmpAgent, LCase("Tumblr")) < 1 And _
			InStr(TmpAgent, LCase("DotBot")) < 1 And _
			InStr(TmpAgent, LCase("masscan")) < 1 And _
			InStr(TmpAgent, LCase("AhrefsBot")) < 1 And _
			InStr(TmpAgent, LCase("Exabot")) < 1 And _
			InStr(TmpAgent, LCase("MJ12bot")) < 1 And _
			InStr(TmpAgent, LCase("Riddler")) < 1 And _
			InStr(TmpAgent, LCase("Twitterbot")) < 1 And _
			InStr(TmpAgent, LCase("EtaoSpider")) < 1 And _
			InStr(TmpAgent, LCase("EasouSpider")) < 1 And _
			InStr(TmpAgent, LCase("YisouSpider")) < 1 And _
			InStr(TmpAgent, LCase("Nmap Scripting Engine")) < 1 And _
			InStr(TmpAgent, LCase("Python-urllib")) < 1 And _
			InStr(TmpAgent, LCase("FunWebProducts")) < 1 And _
			InStr(TmpAgent, LCase("SemrushBot")) < 1 And _
			InStr(TmpAgent, LCase("Chilkat")) < 1 Then
			Query = "exec SPMビジター最終アクセス更新 '" & VisitorIDSplit(GB_VisitorID, "YMD") & "', " & VisitorIDSplit(GB_VisitorID, "ID") & ", '" & Request.ServerVariables("REMOTE_ADDR") & "', '" & Request.ServerVariables("HTTP_USER_AGENT") & "', '" & GB_HostName & "'"
			Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
		End If
	End If
	If LocalMode = "1" Then
		If GB_PracticeCD = "" Then
			'ローカルモードでは演習選択に飛ばす
			Response.Redirect(HomeAliasSL & "practice.asp")
		End If
	End If
'End If
End Function


Function SchoolAdminCheck()
'If 0=1 Then
	SchoolAdminCheck = False
	If GB_SchoolAdmin <> "" Then
		Dim Query
		Dim Content
		Dim Content2
		Query = ""
		Query = Query & " SELECT * FROM TM学校 WHERE 学校CD = '" & GB_SchoolAdmin & "' "
		Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
		If Not(Content.BOF Or Content.EOF) Then
			SchoolAdminCheck = True
		Else
			Response.Write("ログインIDに該当する学校が存在しません。<br>")
			Response.Write("ログインし直してください。<br>")
			Response.Write("<br>")
			Response.Write("<a href=""" & HomeAliasSL & "adminlogin.asp"">戻る</a>")
		End If
	Else
		Response.Write("一定時間無操作により接続がタイムアウトしました。<br>")
		Response.Write("ログインし直してください。<br>")
		Response.Write("<br>")
		Response.Write("<a href=""" & HomeAliasSL & "adminlogin.asp"">戻る</a>")
	End If
'End If
End Function


Function ShopAdminCheck()
'If 0=1 Then
	ShopAdminCheck = False
	If GB_ShopAdmin <> "" Then
		Dim Query
		Dim Content
		Dim Content2
		Set Content = QueryGetShopAdmin(GB_ShopAdmin, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
		If Not(Content.BOF Or Content.EOF) Then
			Dim SeigenDay
			Dim ActDay
			SeigenDay = "" & Content.Fields("ログイン制限日")
			If SeigenDay = "" Then
				SeigenDay = DefAdminKyujitsu 'システムデフォルト
			End If
			SeigenDay = CInt(SeigenDay)
			'曜日を取得
			ActDay = Weekday(Now)
			'祝日チェック
			Dim TmpFlg
			TmpFlg = True
			If SeigenDay > 1 Then
				Query = ""
				Query = Query & "  "
				Query = Query & " SELECT TM祝日.* "
				Query = Query & " FROM TM祝日 "
				Query = Query & " WHERE 年 = " & Year(Now) & " AND 月 = " & Month(Now) & " AND 日 = " & Day(Now) & " "
'				Query = Query & " WHERE 月 = 1 AND 日 = 1 "
				Set Content2 = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
				If Not(Content2.BOF Or Content2.EOF) Then
					TmpFlg = False
				End If
			End If
			'  祝日制限        土曜制限                          日曜制限
			If Not(TmpFlg) Or (SeigenDay > 1 And ActDay = 7) Or (SeigenDay > 0 And ActDay = 1) Then
				Dim Label
				Label = "日・祝"
				If SeigenDay > 1 Then
					Label = "土日祝"
				End If
				Response.Write(Label & "日はショップ管理が許可されておりません。<br>")
				Response.Write("<br>")
				Response.Write("<a href=""" & HomeAliasSL & "?Logout=1"">戻る</a>")
			Else
				Dim StartTime
				Dim EndTime
				Dim ActTime
				StartTime = "" & Content.Fields("ログイン許可始")
				EndTime = "" & Content.Fields("ログイン許可終")
'				If StartTime = "" Then
'					StartTime = DefAdminStart 'システムデフォルト
'				End If
'				If EndTime = "" Then
'					EndTime = DefAdminEnd 'システムデフォルト
'				End If
				'時刻オブジェクトに変換
				If StartTime <> "" Then
					StartTime = TimeValue(StartTime & ":0:0")
				Else
					StartTime = TimeValue("0:0:0")
				End If
				If EndTime <> "" Then
					EndTime = TimeValue(EndTime & ":0:0")
				Else
					EndTime = TimeValue("23:59:59")
				End If
				ActTime = TimeValue(Hour(Now) & ":" & Minute(Now) & ":" & Second(Now))
				If StartTime <= ActTime And EndTime => ActTime Then
					ShopAdminCheck = True
				Else
					Response.Write("現在時刻はショップ管理が許可されておりません。<br>")
					Response.Write("ショップ管理が可能な時間帯 " & StartTime & " ～ " & EndTime & "<br>")
					Response.Write("<br>")
					Response.Write("<a href=""" & HomeAliasSL & "?Logout=1"">戻る</a>")
				End If
			End If
		Else
			Response.Write("ログインIDに該当するショップが存在しません。<br>")
			Response.Write("ログインし直してください。<br>")
			Response.Write("<br>")
			Response.Write("<a href=""" & HomeAliasSL & "adminlogin.asp"">戻る</a>")
		End If
	Else
		Response.Write("一定時間無操作により接続がタイムアウトしました。<br>")
		Response.Write("ログインし直してください。<br>")
		Response.Write("<br>")
		Response.Write("<a href=""" & HomeAliasSL & "adminlogin.asp"">戻る</a>")
	End If
'End If
End Function


Function SysAdminCheck()
'If 0=1 Then
	SysAdminCheck = False
	If GB_SysAdmin = "1" Then
		SysAdminCheck = True
	Else
		Response.Write("一定時間無操作により接続がタイムアウトしました。<br>")
		Response.Write("ログインし直してください。<br>")
		Response.Write("<br>")
		Response.Write("<a href=""" & HomeAliasSL & "adminlogin.asp"">戻る</a>")
	End If
'End If
End Function


'SQLクエリー発行関数
'SQLQuery(クエリ文, サーバー名, データベース名, データベースユーザー名, データベースユーザーパスワード)
Function SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)

	Dim SQLConnection
	SQLConnection = "Provider=SQLOLEDB.1;Persist Security Info=False;"
	SQLConnection = SQLConnection & "User ID=" & DatabaseUser & ";"
	SQLConnection = SQLConnection & "Password=" & DatabasePass & ";"
	SQLConnection = SQLConnection & "Initial Catalog=" & DatabaseName & ";"
	SQLConnection = SQLConnection & "Data Source=" & SQLServer

	Dim db
	Set db = Server.CreateObject("ADODB.Connection")
	db.ConnectionTimeout = 60
	db.CommandTimeout    = 60
	db.Open SQLConnection

	Dim Content

Call Application.Lock()
	On Error Resume Next
		Err.Clear()
		Set Content = db.Execute(Query)
		If Err.Description <> "" Then
			Response.Write("<B>データベースへの接続でエラーが発生しました</B><BR><BR><BR>")
			Response.Write("メッセージ ： <B>" & Err.Description & "</B><BR><BR>")
			Response.Write("送信クエリ ： <B>" & Query & "</B><BR><BR><BR>")
			Exit Function
		End If
	On Error Goto 0

	'クエリ結果待機処理（Contentに結果が返っていないか、もしくはNothing以外の結果が返っている間ループさせる）
	'	Nothingであれば正しく「フィールド無し」の結果が返っているのでループ内処理を行わなず次へ。
	'	Nothingでない場合は (1)正しくフィールド結果が返っている (2)まだ結果が返っていない の2パターンがあり得るので
	'	(1)であればその時点でループを抜け、(2)の場合は念のためNextRecordSet()を発行してからループ先頭に戻る。
	Do While Not Content Is Nothing
		If Content.Fields.Count > 0 Then
			Exit Do
		End If
		Set Content = Content.NextRecordSet()
	Loop
Call Application.Unlock()

	Set SQLQuery = Content

End Function


Function QueryGetItemAdmin(ShopGakko, Item, Cat, SubCat, Order, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Set QueryGetItemAdmin = QueryGetItemMain(ShopGakko, Item, Cat, SubCat, "", Order, True, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function

Function QueryGetItem(ShopGakko, Item, Cat, SubCat, Search, Order, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Set QueryGetItem = QueryGetItemMain(ShopGakko, Item, Cat, SubCat, Search, Order, False, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function

Function QueryGetItemMain(ShopGakko, Item, Cat, SubCat, Search, Order, Admin, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Dim TmpShop 'ショップIDと学校CDのトグルで直代入するとグローバル変数が書き換えられてしまうため別変数
	TmpShop = ShopGakko
	Dim GakkoCD '学校モール絞り込み用
	GakkoCD = ""
	Dim GakkoShopID
	GakkoShopID = ""
	If Not(IsNumeric(TmpShop)) Then
		'文字列の場合は学校CD
		'学校CDをセットしショップIDを空にする
		GakkoCD = ShopGakko
		TmpShop = ""
	End If
	Query = ""
	Query = Query & "  "
	Query = Query & " SELECT TF商品.* "
	Query = Query & " 	, TMカテゴリ.名称 AS カテゴリ名称 "
	Query = Query & " 	, TMサブカテゴリ.名称 AS サブカテゴリ名称 "
	Query = Query & " 	, TMショップ.名称 AS ショップ名称 "
	Query = Query & " 	, TMショップ.商品ショップ名サイズ "
	Query = Query & " 	, TM学校.名称 AS 学校名称 "
	Query = Query & " 	, TM学校.ホスト名 "
	Query = Query & " 	, TM学校.商品表示 "
	Query = Query & " FROM TF商品 "
'	If Admin Then
		Query = Query & " LEFT OUTER JOIN TMカテゴリ "
'	Else
'		Query = Query & " INNER JOIN TMカテゴリ "
'	End If
	Query = Query & " 	ON TF商品.カテゴリID = TMカテゴリ.カテゴリID "
'	If Admin Then
		Query = Query & " LEFT OUTER JOIN TMサブカテゴリ "
'	Else
'		Query = Query & " INNER JOIN TMサブカテゴリ "
'	End If
	Query = Query & " 	ON TF商品.カテゴリID = TMサブカテゴリ.カテゴリID "
	Query = Query & " 	AND TF商品.サブカテゴリID = TMサブカテゴリ.サブカテゴリID "
	Query = Query & " INNER JOIN TMショップ "
	Query = Query & " 	ON TF商品.ショップID = TMショップ.ショップID "
	Query = Query & " LEFT OUTER JOIN TM学校 "
	Query = Query & " 	ON TMショップ.ログインID LIKE TM学校.学校CD + '%' "
	Query = Query & " LEFT OUTER JOIN TM学校所属ショップ "
	Query = Query & " 	ON TMショップ.ショップID = TM学校所属ショップ.ショップID "
	Query = Query & " WHERE 1 = 1 "
	If GakkoCD <> "" Then
		'学校CDで絞り込み
		'Query = Query & " 	AND LEFT(TMショップ.ログインID, " & Len(GakkoCD) & ") = '" & GakkoCD & "' "
		Query = Query & " 	AND ( TMショップ.ログインID LIKE '" & GakkoCD & "%' "
		Query = Query & " 		OR TM学校所属ショップ.学校CD = '" & GakkoCD & "' ) "
	End If
	If TmpShop <> "" And IsNumeric(TmpShop) Then
		Query = Query & " 	AND TF商品.ショップID = " & TmpShop & " "
	End If
	If Item <> "" And IsNumeric(Item) Then
		Query = Query & " 	AND TF商品.商品ID = " & Item & " "
	End If
	If Cat <> "" And IsNumeric(Cat) Then
		If Cat = "9999999" Then
			'生徒開発商品
			Query = Query & " 	AND TF商品.生徒開発商品 IS NOT NULL AND TF商品.生徒開発商品 = '1' "
		Else
			Query = Query & " 	AND TF商品.カテゴリID = " & Cat & " "
		End If
	End If
	If SubCat <> "" And IsNumeric(SubCat) Then
		If SubCat = "9999999" Then
			'生徒開発商品
		Else
			Query = Query & " 	AND TF商品.サブカテゴリID = " & SubCat & " "
		End If
	End If
	If Not(Admin) Then
'		Query = Query & " 	AND TMショップ.商品公開 IS NOT NULL AND TMショップ.商品公開 = '1' "
		Query = Query & " 	AND TF商品.公開 = '1' AND TF商品.公開 IS NOT NULL "
		If Session("ECMallShopVisible") <> "" Then
			Query = Query & " 	AND ( (TMショップ.公開フラグ = '1' AND TMショップ.公開フラグ IS NOT NULL) "
			Query = Query & " 		OR TMショップ.ログインID LIKE '" & Session("ECMallShopVisible") & "%' "
			Query = Query & " 		OR TM学校所属ショップ.学校CD = '" & Session("ECMallShopVisible") & "' ) "
		Else
			Query = Query & " 	AND TMショップ.公開フラグ = '1' AND TMショップ.公開フラグ IS NOT NULL "
		End If
	End If
	If Search <> "" Then
		Query = Query & " 	AND TF商品.名称 LIKE '%" & Search & "%' "
	End If
	If Order = "Osusume" Then
		Query = Query & " 	AND TF商品.おすすめ = '1' "
	End If
	If LocalMode = "1" And Not(Admin) Then
		'ローカルモードは演習CDで絞込み
		Query = Query & " AND TMショップ.演習CD = " & GB_PracticeCD & " "
	End If
	Dim OrderWord
	OrderWord = ""
	If Order = "Osusume" And GB_HostName <> "" Then 'ホスト名がある場合はおすすめ商品で学校商品を優先表示
		'学校の商品を優先
		OrderWord = OrderWord & " CASE WHEN TM学校.ホスト名 = '" & GB_HostName & "' THEN 0 ELSE 1 END "
	ElseIf Order = "New" Then
		OrderWord = OrderWord & " TF商品.最終更新日時 DESC "
	ElseIf Order = "Old" Then
		OrderWord = OrderWord & " TF商品.最終更新日時 "
	ElseIf Order = "Low" Then
		OrderWord = OrderWord & " TF商品.価格 "
	ElseIf Order = "High" Then
		OrderWord = OrderWord & " TF商品.価格 DESC "
	End If
	If OrderWord <> "" Then
		OrderWord = OrderWord & " , "
	End If
	OrderWord = OrderWord & " TF商品.表示順 "
	If OrderWord <> "" Then
		Query = Query & " ORDER BY " & OrderWord
	End If
	Set QueryGetItemMain = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
'Response.Write(Query)
'Response.Write(SQLServer)
End Function

Function QueryGetItemArea(Area, Pref, Order, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Query = ""
	Query = Query & "  "
	Query = Query & " SELECT TF商品.* "
'	Query = Query & " 	, TMカテゴリ.名称 AS カテゴリ名称 "
'	Query = Query & " 	, TMサブカテゴリ.名称 AS サブカテゴリ名称 "
	Query = Query & " 	, TMショップ.名称 AS ショップ名称 "
	Query = Query & " FROM TF商品 "
	Query = Query & " INNER JOIN TMショップ "
	Query = Query & " 	ON TF商品.ショップID = TMショップ.ショップID "
	Query = Query & " INNER JOIN TM地方 "
	Query = Query & " 	ON TF商品.地方CD = TM地方.地方CD "
	If Pref <> "" And IsNumeric(Pref) Then
		Query = Query & " INNER JOIN TM都道府県 "
		Query = Query & " 	ON TF商品.地方CD = TM都道府県.地方CD "
		Query = Query & " 	AND TF商品.都道府県CD = TM都道府県.都道府県CD "
	End If
	Query = Query & " WHERE TF商品.地方CD = " & Area & " "
	If Pref <> "" And IsNumeric(Pref) Then
		Query = Query & " 	AND TF商品.都道府県CD = " & Pref & " "
	End If
	Query = Query & " 	AND TF商品.公開 IS NOT NULL AND TF商品.公開 = '1' "
'	Query = Query & " 	AND TMショップ.商品公開 IS NOT NULL AND TMショップ.商品公開 = '1' " 'フラグ廃止
	Query = Query & " 	AND TMショップ.公開フラグ = '1' AND TMショップ.公開フラグ IS NOT NULL "
	Dim OrderWord
	OrderWord = ""
	If Order = "New" Then
		OrderWord = OrderWord & " TF商品.最終更新日時 DESC "
	ElseIf Order = "Old" Then
		OrderWord = OrderWord & " TF商品.最終更新日時 "
	ElseIf Order = "Low" Then
		OrderWord = OrderWord & " TF商品.価格 "
	ElseIf Order = "High" Then
		OrderWord = OrderWord & " TF商品.価格 DESC "
	End If
	If OrderWord <> "" Then
		OrderWord = OrderWord & " , "
	End If
	OrderWord = OrderWord & " TF商品.表示順 "
	If OrderWord <> "" Then
		Query = Query & " ORDER BY " & OrderWord
	End If
	Set QueryGetItemArea = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	'Response.Write(Query)
End Function


Function QueryGetShop(Shop, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Set QueryGetShop = QueryGetShopMain(Shop, "0", SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function

Function QueryGetShopAdmin(Shop, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Set QueryGetShopAdmin = QueryGetShopMain(Shop, "1", SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function


Function QueryGetShopMain(Shop, Admin, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Dim Content2
	If Shop = "Rnd" Then
		'ランダムモード用ランダム値更新
		Call RndUpdate("TMショップ", "ショップID", SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	End If
	Query = ""
	Query = Query & "  "
	Query = Query & " SELECT TMショップ.*, TM都道府県.名称 AS 都道府県 "
	Query = Query & " FROM TMショップ "
	Query = Query & " LEFT OUTER JOIN TM都道府県 "
	Query = Query & " 	ON TMショップ.都道府県CD = TM都道府県.都道府県CD "
	Query = Query & " LEFT OUTER JOIN TM学校所属ショップ "
	Query = Query & " 	ON TMショップ.ショップID = TM学校所属ショップ.ショップID "
	Query = Query & " WHERE 1 = 1 "
	If Admin <> "1" Then
		If Session("ECMallShopVisible") <> "" Then
			Query = Query & " 	AND (TMショップ.公開フラグ = '1' AND TMショップ.公開フラグ IS NOT NULL "
			Query = Query & " 		OR TMショップ.ログインID LIKE '" & Session("ECMallShopVisible") & "%' "
			Query = Query & " 		OR TM学校所属ショップ.学校CD = '" & Session("ECMallShopVisible") & "' ) "
		Else
			Query = Query & " 	AND (TMショップ.公開フラグ = '1' AND TMショップ.公開フラグ IS NOT NULL) "
		End If
	End If
	If Shop <> "" Then
		If IsNumeric(Shop) Then '数値なら当該ショップのみ
			Query = Query & " AND TMショップ.ショップID = " & Shop & " "
		ElseIf Shop <> "All" Then '文字でAll以外なら学校所属ショップ
			Query = Query & " AND (TMショップ.ログインID LIKE '" & Shop & "%' "
			Query = Query & " 	OR TM学校所属ショップ.学校CD = '" & Shop & "' ) "
		End If
	End If
	If LocalMode = "1" And Admin <> "1" Then
		'ローカルモードは演習CDで絞込み（ビジター側のみ）
		Query = Query & " AND TMショップ.演習CD = " & GB_PracticeCD & " "
	End If
	If Shop = "Rnd" Then
		Query = Query & " ORDER BY TMショップ.ランダム値 "
	ElseIf Admin = "1" Then
		Query = Query & " ORDER BY TMショップ.名称 "
	End If
	Set QueryGetShopMain = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function


'先頭行は 都道府県CD = 0 = 全国一律送料
Function QueryGetShopSoryo(Shop, Kubun, Order, GetNull, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Dim Content2
	Query = ""
	Query = Query & " SELECT TM都道府県.*, TFショップ送料.送料 "
	Query = Query & " FROM TM都道府県 "
	Query = Query & " LEFT OUTER JOIN (SELECT * FROM TFショップ送料 WHERE ショップID = " & Shop & " AND 区分 = " & Kubun & ") TFショップ送料 "
	Query = Query & "  	ON TFショップ送料.都道府県CD = TM都道府県.都道府県CD "
'	Query = Query & " LEFT OUTER JOIN TFショップ送料 "
'	Query = Query & " 	ON TFショップ送料.都道府県CD = TM都道府県.都道府県CD "
'	Query = Query & " 	AND TFショップ送料.区分 = " & Kubun & " "
'	Query = Query & " WHERE (TFショップ送料.ショップID IS NULL OR TFショップ送料.ショップID = " & Shop & ") "
'	Query = Query & " 	AND (TFショップ送料.区分 IS NULL OR TFショップ送料.区分 = " & Kubun & ") "
'	Query = Query & " 	AND TM都道府県.都道府県CD < 48 "
	If Not(GetNull) Then
		Query = Query & " 	AND 送料 IS NOT NULL "
	End If
	If Order = "Soryo" Then        '送料順ソートの場合も全国一律送料は先頭にする
		Query = Query & " ORDER BY (CASE TM都道府県.都道府県CD WHEN 0 THEN 0 ELSE 1 END), TFショップ送料.送料, TM都道府県.都道府県CD "
	Else 'If Order = "Pref" Then
		Query = Query & " ORDER BY TM都道府県.都道府県CD "
	End If
	Set QueryGetShopSoryo = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function


Function QueryGetSchoolLogin(LoginID, Password, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Query = ""
	Query = Query & "  "
	Query = Query & " SELECT TM学校.* "
	Query = Query & " FROM TM学校 "
	Query = Query & " WHERE TM学校.学校CD = '" & LoginID & "' "
	Query = Query & " 	AND TM学校.パスワード = '" & Password & "' "
	Set QueryGetSchoolLogin = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function


Function QueryGetShopLogin(LoginID, Password, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Query = ""
	Query = Query & "  "
	Query = Query & " SELECT TMショップ.* "
	Query = Query & " FROM TMショップ "
	Query = Query & " WHERE TMショップ.ログインID = '" & LoginID & "' "
	Query = Query & " 	AND TMショップ.パスワード = '" & Password & "' "
	Set QueryGetShopLogin = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function


Function QueryGetLogin(LoginID, Password, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Query = ""
	Query = Query & "  "
	Query = Query & " SELECT TMログイン.*, TM都道府県.名称 AS 都道府県 "
	Query = Query & " FROM TMログイン "
	Query = Query & " LEFT OUTER JOIN TM都道府県 "
	Query = Query & " 	ON TMログイン.都道府県CD = TM都道府県.都道府県CD "
	Query = Query & " WHERE TMログイン.メールアドレス = '" & LoginID & "' "
	If Password = "" Then
		'ログインID存在チェックのためパスワード未指定でも取得可能とする。
		'※パスワード未入力対策はASP側で適宜制約すること！
	Else
		Query = Query & " 	AND TMログイン.パスワード = '" & Password & "' "
	End If
	Set QueryGetLogin = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
End Function


'ランダム値更新（引数にテーブル名とキー列名を指定）
Sub RndUpdate(Table, KeyField, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Dim Query
	Dim Content
	Dim Content2
	If Table <> "" And KeyField <> "" Then
		Dim RndSeed
		RndSeed = TimeUniqInt()
		Query = ""
		Query = Query & " SELECT * "
		Query = Query & " FROM " & Table & " "
		Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
		Do While Not(Content.BOF Or Content.EOF)
			Randomize '乱数ジェネレータを初期化
			RndSeed = Fix(1000000 * Rnd(RndSeed)) '直前の値をシードとして0～1000000の値を取得
			Query = ""
			Query = Query & " UPDATE " & Table & " "
			Query = Query & " SET ランダム値 = " & RndSeed & " "
			Query = Query & " WHERE " & KeyField & " = " & Content.Fields(KeyField) & " "
			Set Content2 = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
			Content.MoveNext
		Loop
	End If
End Sub


Function BASPSendMail(SendMailTo, SendMailFrom, Subject, Body, Files, ErrMes)
'If 0=1 Then
	Session.Timeout = 1440
	Server.ScriptTimeout = 1200
	'BASP21オブジェクト作成
	Dim ObjBASP
	Set ObjBASP = Server.CreateObject("basp21")
	Dim SMTPServer
'	SMTPServer = "mail.sfc-jpn.co.jp:587"	'プロバイダSMTP
'	SendMailFrom = SendMailFrom & vbTab & "webmail@sfc-jpn.co.jp:0n0m1k10"	'SMTP認証アカウント：パスワード
	SMTPServer = "127.0.0.1:25"	'ローカルSMTP
	SendMailFrom = SendMailFrom	'SMTP認証無し
	Dim rc
	rc = ObjBASP.SendMail(SMTPServer, SendMailTo, SendMailFrom, Subject, Body, Files)
	If rc <> "" Then
		rc = ObjBASP.SendMail(SMTPServer, SendMailTo, SendMailFrom, Subject, Body, Files) 'リトライ
	End If
	If rc <> "" Then
		rc = ObjBASP.SendMail(SMTPServer, SendMailTo, SendMailFrom, Subject, Body, Files) 'リトライ
	End If
	If rc <> "" Then
		rc = ObjBASP.SendMail(SMTPServer, SendMailTo, SendMailFrom, Subject, Body, Files) 'リトライ
	End If
	If rc <> "" Then
		rc = ObjBASP.SendMail(SMTPServer, SendMailTo, SendMailFrom, Subject, Body, Files) 'リトライ
	End If
	If rc <> "" Then
		Response.Write("メールが送信できませんでした。<br>")
		Response.Write("エラーコード：")
		Response.Write(rc)
		Response.Write("<br><br>")
		Response.Write(ErrMes)
		Response.Write("<br><br>")
		Response.Write("<a href=""JavaScript:history.go(-1)"">戻る</a>")
		BASPSendMail = False
	Else
		BASPSendMail = True
	End If
'End If
End Function



	'GIFイメージカウンタ（JavaScript内接リサイズ処理のためのidをユニークにするためページ内で通し番号にする）
'	Dim GIFCnt
'	GIFCnt = 0

	'画像サイズ取得用グローバル変数
	Dim ImageWidth
	Dim ImageHeight

'画像サイズ取得（サイズを取得しグローバル変数に代入）
Sub ImageSize(ImagePath)
	ImageWidth = 0
	ImageHeight = 0
	Dim Result
On Error Resume Next
	'指定された画像のサイズを取得
	If LCase(Right(ImagePath, 4)) = ".gif" Then
		'GIFのみLeadToolsではライセンスの関係で処理出来ないのでDoodle2コンポーネントを利用
		Result = DdleObj.LoadFromFile(Server.MapPath(ImagePath))
		If Result = 0 Then
			ImageWidth = DdleObj.Width
			ImageHeight = DdleObj.Height
		End If
	Else
		Result = LeadObj.Load(Server.MapPath(ImagePath), 0, 0, 1)
		If Result = 0 Then
			ImageWidth = LeadObj.BitmapWidth
			ImageHeight = LeadObj.BitmapHeight
		End If
	End If
On Error Goto 0
End Sub

	'画像内接サイズ取得用グローバル変数
	Dim InscribedWidth
	Dim InscribedHeight

'画像内接サイズ取得（指定サイズに対する内接サイズを取得しグローバル変数に代入）
Sub InscribedImageSize(ImagePath, TargetWidth, TargetHeight)
	InscribedWidth = 0
	InscribedHeight = 0
	Dim Result
	Dim ImgWidth
	Dim ImgHeight
	ImgWidth = 0
	ImgHeight = 0
	Dim Hiritsu
	If TargetWidth > 0 And TargetHeight > 0 Then
On Error Resume Next
		'指定された画像のサイズを取得
		If LCase(Right(ImagePath, 4)) = ".gif" Then
			'GIFのみLeadToolsではライセンスの関係で処理出来ないのでDoodle2コンポーネントを利用
			Result = DdleObj.LoadFromFile(Server.MapPath(ImagePath))
			If Result = 0 Then
				ImgWidth = DdleObj.Width
				ImgHeight = DdleObj.Height
			End If
		Else
			Result = LeadObj.Load(Server.MapPath(ImagePath), 0, 0, 1)
			If Result = 0 Then
				ImgWidth = LeadObj.BitmapWidth
				ImgHeight = LeadObj.BitmapHeight
			End If
		End If
		If ImgWidth > 0 And ImgHeight > 0 Then
			'指定サイズの縦横比に対して画像の縦横比のいずれか広い側の比率を取得する
			If ImgWidth / ImgHeight > TargetWidth / TargetHeight Then
				Hiritsu = ImgWidth / TargetWidth '指定サイズに対する画像の縦横比の横が広い場合
			Else
				Hiritsu = ImgHeight / TargetHeight '指定サイズに対する画像の縦横比の縦が広い場合
			End If
			'比率から内接サイズを計算しグローバル変数に代入（小数点以下四捨五入）
			InscribedWidth = Fix((ImgWidth / Hiritsu) + 0.5)
			InscribedHeight = Fix((ImgHeight / Hiritsu) + 0.5)
		End If
On Error Goto 0
	End If
End Sub

'画像出力（指定サイズで内接リサイズするimgタグを出力）
Function InscribedImage(ImagePath, TargetWidth, TargetHeight)
	Call InscribedImageSize(ImagePath, TargetWidth, TargetHeight) '指定サイズに対する内接サイズを取得しグローバル変数に代入
	Dim TmpStr
	TmpStr = ""
	TmpStr = "<img src=""" & ImagePath & "?" & Uniq & """ border=""0"" width=""" & InscribedWidth & """ height=""" & InscribedHeight & """>"
'	If LCase(Right(ImagePath, 4)) = ".gif" Then
'		'GIFイメージカウントアップ（JavaScript内接リサイズ処理のためのidをユニークにするためページ内で通し番号にする）
'		GIFCnt = GIFCnt + 1
'		TmpStr = TmpStr & "<img id=""GIFImage" & GIFCnt & """ src=""" & ImagePath & "?" & Uniq & """ border=""0"" width=""0"" height=""0"">" & vbCrLf
'		TmpStr = TmpStr & "<SCRIPT LANGUAGE=""JavaScript"">" & vbCrLf
'		TmpStr = TmpStr & "<!--" & vbCrLf
'		TmpStr = TmpStr & "	InscribedImage(""GIFImage" & GIFCnt & """, " & ImageWidth & ", " & ImageHeight & ");" & vbCrLf
'		TmpStr = TmpStr & "-->" & vbCrLf
'		TmpStr = TmpStr & "</SCRIPT>" & vbCrLf
'	Else
'		TmpStr = TmpStr & "<img src=""" & ImagePath & "?" & Uniq & """ border=""0"">" & vbCrLf
'	End If
	InscribedImage = TmpStr
End Function

'画像出力（指定サイズで内接リサイズしOutPathに保存）※GIF以外は全てJPEGで保存
Sub InscribedImageOut(ImagePath, OutPath, TargetWidth, TargetHeight)
	Call InscribedImageSize(ImagePath, TargetWidth, TargetHeight) '指定サイズに対する内接サイズを取得しグローバル変数に代入
	Dim Result
	'縮小（拡大）
	If LCase(Right(ImagePath, 4)) = ".gif" Then
		'GIFのみLeadToolsではライセンスの関係で処理出来ないのでDoodle2コンポーネントを利用
		Result = DdleObj.LoadFromFile(Server.MapPath(ImagePath))
		If Result = 0 Then
			'サイズ変更
			Result = DdleObj.Stretch(InscribedWidth, InscribedHeight, True, True) '第4引数はFalseで内接リサイズだが余白が生じるだけなのでダメ
			If Result = 0 Then
				'画像を保存
				Result = DdleObj.SaveToFile(OutPath)
			End If
		End If
	Else
		Result = LeadObj.Load(Server.MapPath(ImagePath), 0, 0, 1)
		If Result = 0 Then
			'サイズ変更
			Result = LeadObj.Size(InscribedWidth, InscribedHeight, 4)
			If Result = 0 Then
				'全てJPEGで保存（強制）
				Dim NewFilePath
				NewFilePath = Left(OutPath, Len(OutPath) - 4) & ".jpg"
				Result = LeadObj.Save(NewFilePath, 10, 24, 24, 0) '第4引数が圧縮率
			End If
		End If
	End If

End Sub

'透明画像スペーサー（幅、高さ）
Function Spacer(Width, Height)
	Spacer = "<img src=""" & HomeAliasSL & "images/spacer.gif"" border=""0"" width=""" & Width & """ height=""" & Height & """>"
End Function


'商品一覧出力（幅100%テーブル）※ショップIDまたは学校CD,商品ID,カテゴリ(地方),サブカテゴリ(都道府県),抽出区分,検索文字列,ソート順,ページNo,ページ表示数,ページングURL,ショップリンクフラグ
Function HTMLItemList(ShopGakko, Item, Cat, SubCat, Kubun, Search, Order, Page, Number, Pagelink, Shoplink)
	Dim fso
	Set fso = Server.CreateObject("Scripting.FileSystemObject")
	Dim TmpImage
	Dim ActFileNum
	Dim TmpImageTmp
	Dim TopImageFlg
	TopImageFlg = "&TopImage=0" '商品詳細表示時にトップイメージを表示しないフラグ
	If Shoplink Then
		TopImageFlg = "" 'Shoplink指定時（ショップ以外）は表示する
	End If
	Search = ConvQueryChar(Search)
	If "" & Page <> "" And IsNumeric(Page) Then
		Page = CInt(Page)
	Else
		Page = 0
	End If
	Dim StartRow
	If "" & Number <> "" And IsNumeric(Number) Then
		Number = CInt(Number)
		StartRow = Page * CInt(Number) + 1
	Else
		Number = null
		StartRow = 0
	End If
	Dim RowCnt
	RowCnt = 0
	Dim Content
	Dim HTMLOut
	HTMLOut = ""
	HTMLOut = HTMLOut & ""
	HTMLOut = HTMLOut & "<table border=""0"" cellpadding=""0"" cellspacing=""4"" width=""100%"">" & vbCrLf
	If Kubun = "Area" Then	'          Area Pref
		Set Content = QueryGetItemArea(Cat, SubCat, Order, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Else
		Set Content = QueryGetItem(ShopGakko, Item, Cat, SubCat, Search, Order, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	End If
	Do While Not(Content.BOF Or Content.EOF)
		RowCnt = RowCnt + 1
		If "" & StartRow = "" Or RowCnt >= StartRow Then
			If "" & Number <> "" And RowCnt >= (StartRow + Number) Then
				Exit Do
			End If
			HTMLOut = HTMLOut & "	<tr>" & vbCrLf
			HTMLOut = HTMLOut & "		<td width=""" & ImageXItemThumb & """ align=""center"" valign=""top"" valign=""middle"">" & vbCrLf

			If "" & Content.Fields("商品画像一覧表示") <> "" Then
				TmpImage = Content.Fields("商品画像" & Content.Fields("商品画像一覧表示"))
				ActFileNum = Content.Fields("商品画像トグル" & Content.Fields("商品画像一覧表示"))
			ElseIf "" & Content.Fields("商品画像1") <> "" Then
				TmpImage = Content.Fields("商品画像1")
				ActFileNum = Content.Fields("商品画像トグル1")
			ElseIf "" & Content.Fields("商品画像2") <> "" Then
				TmpImage = Content.Fields("商品画像2")
				ActFileNum = Content.Fields("商品画像トグル2")
			ElseIf "" & Content.Fields("商品画像3") <> "" Then
				TmpImage = Content.Fields("商品画像3")
				ActFileNum = Content.Fields("商品画像トグル3")
			End If

			If "" & TmpImage <> "" Then
				TmpImageTmp = Left(TmpImage, InStrRev(TmpImage, ".") - 1)	'ファイル名を取り出す
				TmpImageTmp = TmpImageTmp & "_" & ImageXItemThumb & "_" & ImageyItemThumb & "_" & ActFileNum '商品画像トグルを付加
				If LCase(Right(TmpImage, 4)) = ".gif" Then
					TmpImageTmp = TmpImageTmp & Mid(TmpImage, InStrRev(TmpImage, ".")) '拡張子を付加
				Else
					TmpImageTmp = TmpImageTmp & ".jpg" 'GIF以外はすべてjpg拡張子を付加
				End If
				'ファイル存在チェック                                                                                                    GIFは除外
				If Not(fso.FileExists(Server.MapPath(HomeAliasSL & ItemFolderSL & Content.Fields("ショップID") & "/" & TmpImageTmp))) Or LCase(Right(TmpImageTmp, 4)) = ".gif" Then
					'無ければ元ファイル表示
					TmpImageTmp = InscribedImage(HomeAliasSL & ItemFolderSL & Content.Fields("ショップID") & "/" & TmpImage, ImageXItemThumb, ImageyItemThumb)
				Else
					'サムネイル表示
					TmpImageTmp = "<img src=""" & HomeAliasSL & ItemFolderSL & Content.Fields("ショップID") & "/" & TmpImageTmp & "?" & Uniq & """ border=""0"">"
				End If
			End If

			If "" & Content.Fields("カート非利用") = "1" And "" & Content.Fields("カート非利用URL") <> "" Then
				HTMLOut = HTMLOut & "			<a href=""" & Content.Fields("カート非利用URL") & """ target=""_blank"">" & TmpImageTmp & "</a>" & vbCrLf
			Else
				HTMLOut = HTMLOut & "			<a href=""" & HomeAliasSL & "shop.asp?SelShop=" & Content.Fields("ショップID") & "&Item=" & Content.Fields("商品ID") & TopImageFlg & """>" & TmpImageTmp & "</a>" & vbCrLf
			End If
			HTMLOut = HTMLOut & "		</td>" & vbCrLf
			HTMLOut = HTMLOut & "		<td valign=""top"">" & vbCrLf
			HTMLOut = HTMLOut & "			<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""100%"" class=""tx1416"">" & vbCrLf
			HTMLOut = HTMLOut & "				<tr>" & vbCrLf
			HTMLOut = HTMLOut & "					<td bgcolor=""#eeeeee"">" & Spacer(1, 3) & "</td>" & vbCrLf '半角英字想定によりボトムラインがずれるのでダミー
			HTMLOut = HTMLOut & "				</tr>" & vbCrLf
			HTMLOut = HTMLOut & "				<tr>" & vbCrLf
			HTMLOut = HTMLOut & "					<td bgcolor=""#eeeeee"" valign=""bottom"">" & vbCrLf
			HTMLOut = HTMLOut & "						<table border=""0"" cellpadding=""0"" cellspacing=""1"" width=""100%"" class=""tx1416"">" & vbCrLf
			HTMLOut = HTMLOut & "							<tr>" & vbCrLf
			HTMLOut = HTMLOut & "								<td width=""3"">" & Spacer(3, 1) & "</td>" & vbCrLf
			HTMLOut = HTMLOut & "								<td class=""ItemListName"" bgcolor=""#eeeeee"" valign=""bottom"">" & vbCrLf
			If "" & Content.Fields("カート非利用") = "1" And "" & Content.Fields("カート非利用URL") <> "" Then
				HTMLOut = HTMLOut & "									<a href=""" & Content.Fields("カート非利用URL") & """ target=""_blank"">" & Content.Fields("名称") & "</a>" & vbCrLf
			Else
				HTMLOut = HTMLOut & "									<a href=""" & HomeAliasSL & "shop.asp?SelShop=" & Content.Fields("ショップID") & "&Item=" & Content.Fields("商品ID") & TopImageFlg & """>" & Content.Fields("名称") & "</a>" & vbCrLf
			End If
			HTMLOut = HTMLOut & "								</td>" & vbCrLf
			HTMLOut = HTMLOut & "								<td width=""3"">" & Spacer(3, 1) & "</td>" & vbCrLf
			HTMLOut = HTMLOut & "							</tr>" & vbCrLf
			HTMLOut = HTMLOut & "						</table>" & vbCrLf
			HTMLOut = HTMLOut & "					</td>" & vbCrLf
			HTMLOut = HTMLOut & "				</tr>" & vbCrLf
			HTMLOut = HTMLOut & "				<tr>" & vbCrLf
			HTMLOut = HTMLOut & "					<td>" & vbCrLf
			If Content.Fields("価格") = 0 Then
				HTMLOut = HTMLOut & "						<span class=""tx1618""><b>時価</b></span><span class=""tx1416"">（ご注文後にお知らせいたします）</span>" & vbCrLf
			Else
				HTMLOut = HTMLOut & "						<span class=""tx1618""><b>&yen;" & ConvIntToMoney(Content.Fields("価格"), False, False) & "</b></span><span class=""tx1416"">（"
				If "" & Content.Fields("消費税フラグ") = "1" Then
					HTMLOut = HTMLOut & "税込"
				Else
					HTMLOut = HTMLOut & "税別"
				End If
				HTMLOut = HTMLOut & "）</span>" &vbCrLf
			End If
			HTMLOut = HTMLOut & "<br>" &vbCrLf
			Dim MaxRow
			MaxRow = 6
'			Dim RCnt
'			Dim TmpRow
'			TmpRow = Split("" & Content.Fields("紹介文"), "<br>")
'			If UBound(TmpRow) + 1 < MaxRow Then
'				MaxRow = UBound(TmpRow) + 1
'			End If
'			For RCnt = 0 to MaxRow - 1
'				HTMLOut = HTMLOut & TmpRow(RCnt) & "<br>" & vbCrLf
'			Next
			HTMLOut = HTMLOut & "						<div class=""tx1416"" style=""height:" & (17 * MaxRow) & "px;width:100%;overflow:hidden;"">" & Content.Fields("紹介文") & "</div>" & vbCrLf
			HTMLOut = HTMLOut & "					</td>" & vbCrLf
			HTMLOut = HTMLOut & "				</tr>" & vbCrLf
			If Shoplink Then
				HTMLOut = HTMLOut & "				<tr>" & vbCrLf
				HTMLOut = HTMLOut & "					<td height=""24"" valign=""middle"">" & vbCrLf
				HTMLOut = HTMLOut & "						<a href=""" & HomeAliasSL & "shop.asp?SelShop=" & Content.Fields("ショップID") & """>[" & Content.Fields("ショップ名称") & "]</a>" & vbCrLf
				'全ての商品を表示する場合は学校名を表示
				If (ShopGakko = "" Or IsNumeric(ShopGakko)) And LCase(Content.Fields("ホスト名")) <> "hsns" Then
'					HTMLOut = HTMLOut & "						：" & vbCrLf
					HTMLOut = HTMLOut & "						<a href=""http://" & Content.Fields("ホスト名") & ".hsns.sfc-jpn.jp"">[" & ShopGakko & Content.Fields("学校名称") & "]</a>" & vbCrLf
				End If
				HTMLOut = HTMLOut & "					</td>" & vbCrLf
				HTMLOut = HTMLOut & "				</tr>" & vbCrLf
			End If
			HTMLOut = HTMLOut & "			</table>" & vbCrLf
			HTMLOut = HTMLOut & "		</td>" & vbCrLf
			HTMLOut = HTMLOut & "	</tr>" & vbCrLf
		End If
		Content.MoveNext
	Loop
	If Pagelink <> "" Then
		Dim PageQuery
		If InStr(Pagelink, "?") > 0 Then
			PageQuery = "&Page="
		Else
			PageQuery = "?Page="
		End If
		HTMLOut = HTMLOut & "	<tr><td align=""center"" colspan=""2"">" & vbCrLf
		If Page > 0 Or Not(Content.BOF Or Content.EOF) Then
			HTMLOut = HTMLOut & "		<table border=""0"" cellpadding=""0"" cellspacing=""0""><tr>" & vbCrLf
			If Page > 0 Then
				HTMLOut = HTMLOut & "<td>&nbsp;&nbsp;&nbsp;</td>" & vbCrLf
				HTMLOut = HTMLOut & "<td>" & vbCrLf
				HTMLOut = HTMLOut & ActionButton3Image("PageBackward", "images/btn01bl.png", "images/btn01bl_o.png", 4, "images/btn01bc.png", "images/btn01bc_o.png", 74, "images/btn01br.png", "images/btn01br_o.png", 4, 25, "前のページ", "tx1416w", "center", "location.href='" & Pagelink & PageQuery & (Page - 1) & "';")
				HTMLOut = HTMLOut & "</td>" & vbCrLf
				HTMLOut = HTMLOut & "<td>&nbsp;&nbsp;&nbsp;</td>" & vbCrLf
			End If
			If Not(Content.BOF Or Content.EOF) Then
				HTMLOut = HTMLOut & "<td>&nbsp;&nbsp;&nbsp;</td>" & vbCrLf
				HTMLOut = HTMLOut & "<td>" & vbCrLf
				HTMLOut = HTMLOut & ActionButton3Image("PageForward", "images/btn01bl.png", "images/btn01bl_o.png", 4, "images/btn01bc.png", "images/btn01bc_o.png", 74, "images/btn01br.png", "images/btn01br_o.png", 4, 25, "次のページ", "tx1416w", "center", "location.href='" & Pagelink & PageQuery & (Page + 1) & "';")
				HTMLOut = HTMLOut & "</td>" & vbCrLf
				HTMLOut = HTMLOut & "<td>&nbsp;&nbsp;&nbsp;</td>" & vbCrLf
			End If
			HTMLOut = HTMLOut & "		</tr></table>" & vbCrLf
		End If
		HTMLOut = HTMLOut & "	</td></tr>" & vbCrLf
		HTMLOut = HTMLOut & "	<tr><td>" & Spacer(1,10) & "</td></tr>" & vbCrLf
	End If
	HTMLOut = HTMLOut & "</table>" & vbCrLf
	HTMLItemList = HTMLOut
End Function


'都道府県選択プルダウン（name="ToDoFuKen"）
Function HTMLToDoFuKenSelect(MinTDFK, MaxTDFK, SelTDFK, StyleCls, Zokusei)
	MinTDFK = "" & MinTDFK
	MaxTDFK = "" & MaxTDFK
	SelTDFK = "" & SelTDFK
	StyleCls = "" & StyleCls
	If MinTDFK = "" Then
		MinTDFK = "1"
	End If
	If MaxTDFK = "" Then
		MaxTDFK = "47"
	End If
	If StyleCls = "" Then
		StyleCls = "select14"
	End If
	Dim HTMLOut
	HTMLOut = ""
	HTMLOut = HTMLOut & ""
	HTMLOut = HTMLOut & "<select name=""ToDoFuKen"" class=""" & StyleCls & """ " & Zokusei & ">" & vbCrLf
	HTMLOut = HTMLOut & "	<option value=""""></option>" & vbCrLf
	Dim Query
	Dim Content
	Query = ""
	Query = Query & "  "
	Query = Query & " SELECT TM都道府県.* "
	Query = Query & " FROM TM都道府県 "
	Query = Query & " WHERE TM都道府県.都道府県CD >= " & MinTDFK & " "
	Query = Query & " 	AND TM都道府県.都道府県CD <= " & MaxTDFK & " "
	Query = Query & " ORDER BY TM都道府県.都道府県CD "
	Set Content = SQLQuery(Query, SQLServer, DatabaseName, DatabaseUser, DatabasePass)
	Do While Not(Content.BOF Or Content.EOF)
		'一時セッション変数による都道府県絞込み
		If Session("OrderRegion") = "" Or InStr(Session("OrderRegion"), "," & Content.Fields("都道府県CD") & ",") > 0 Then
			HTMLOut = HTMLOut & "	<option value=""" & Content.Fields("都道府県CD") & """"
			If "" & Content.Fields("都道府県CD") = SelTDFK Then
				HTMLOut = HTMLOut & " selected"
			End If
			HTMLOut = HTMLOut & ">" & Content.Fields("名称") & "</option>" & vbCrLf
		End If
		Content.MoveNext
	Loop
	HTMLOut = HTMLOut & "</select>" & vbCrLf
	HTMLToDoFuKenSelect = HTMLOut
End Function


'テーブルタグによるアクションボタン生成
'Identity：テーブルセルID及び関数に利用される文字列。同一ページ内重複不可。
Function ActionButton3Image(Identity, ImageOutL, ImageOverL, WidthL, ImageOutC, ImageOverC, WidthC, ImageOutR, ImageOverR, WidthR, Height, Label, LabelStyle, LabelAlign, OnClkScript)
'Function ActionButton3Image(Identity, ImageOut, ImageOver, ImageExt, WidthLeft, WidthCenter, WidthRight, Height, Label, LabelStyle, LabelAlign, OnClkScript)
	Dim HTML
	HTML = ""
	HTML = HTML & "" & vbCrLf
If 0=1 Then
	HTML = HTML & "<script type=""text/javascript"">" & vbCrLf
	HTML = HTML & "<!--" & vbCrLf
	HTML = HTML & "	ImgFileOutL = new Image();" & vbCrLf
	HTML = HTML & "	ImgFileOutC = new Image();" & vbCrLf
	HTML = HTML & "	ImgFileOutR = new Image();" & vbCrLf
	HTML = HTML & "	ImgFileOverL = new Image();" & vbCrLf
	HTML = HTML & "	ImgFileOverC = new Image();" & vbCrLf
	HTML = HTML & "	ImgFileOverR = new Image();" & vbCrLf
	HTML = HTML & "	ImgFileOutL.src = """ & ImageOutL & """;" & vbCrLf
	HTML = HTML & "	ImgFileOutC.src = """ & ImageOutC & """;" & vbCrLf
	HTML = HTML & "	ImgFileOutR.src = """ & ImageOutR & """;" & vbCrLf
	HTML = HTML & "	ImgFileOverL.src = """ & ImageOverL & """;" & vbCrLf
	HTML = HTML & "	ImgFileOverC.src = """ & ImageOverC & """;" & vbCrLf
	HTML = HTML & "	ImgFileOverR.src = """ & ImageOverR & """;" & vbCrLf
	HTML = HTML & "-->" & vbCrLf
	HTML = HTML & "</SCRIPT>" & vbCrLf
End If
	HTML = HTML & "<table border=""0"" cellpadding=""0"" cellspacing=""0"" width=""" & CInt(WidthL) + CInt(WidthC) + CInt(WidthR) & """ style=""cursor:pointer;"" class=""" & LabelStyle & """ onMouseOut=""ImageToggle3" & Identity & "('Out');"" onMouseOver=""ImageToggle3" & Identity & "('Over');"" onClick=""" & OnClkScript & """>" & vbCrLf
	HTML = HTML & "	<tr height=""" & Height & """>" & vbCrLf
	HTML = HTML & "		<td id=""" & Identity & "L"" width=""" & WidthL & """ height=""" & Height & """ background=""" & ImageOutL & """ valign=""middle""></td>" & vbCrLf
	HTML = HTML & "		<td id=""" & Identity & "C"" width=""" & WidthC & """ height=""" & Height & """ background=""" & ImageOutC & """ valign=""middle"" align=""" & LabelAlign & """><nobr>" & Label & "</nobr></td>" & vbCrLf
	HTML = HTML & "		<td id=""" & Identity & "R"" width=""" & WidthR & """ height=""" & Height & """ background=""" & ImageOutR & """ valign=""middle""></td>" & vbCrLf
	HTML = HTML & "	</tr>" & vbCrLf
	HTML = HTML & "</table>" & vbCrLf
	HTML = HTML & "<script type=""text/javascript"">" & vbCrLf
	HTML = HTML & "<!--" & vbCrLf
	HTML = HTML & "	function ImageToggle3" & Identity & "(Mode) {" & vbCrLf
	HTML = HTML & "		if (Mode == ""Over"") {" & vbCrLf
	HTML = HTML & "			document.getElementById(""" & Identity & "L"").style.backgroundImage = ""url(" & ImageOverL & ")"";" & vbCrLf
	HTML = HTML & "			document.getElementById(""" & Identity & "C"").style.backgroundImage = ""url(" & ImageOverC & ")"";" & vbCrLf
	HTML = HTML & "			document.getElementById(""" & Identity & "R"").style.backgroundImage = ""url(" & ImageOverR & ")"";" & vbCrLf
	HTML = HTML & "		} else {" & vbCrLf
	HTML = HTML & "			document.getElementById(""" & Identity & "L"").style.backgroundImage = ""url(" & ImageOutL & ")"";" & vbCrLf
	HTML = HTML & "			document.getElementById(""" & Identity & "C"").style.backgroundImage = ""url(" & ImageOutC & ")"";" & vbCrLf
	HTML = HTML & "			document.getElementById(""" & Identity & "R"").style.backgroundImage = ""url(" & ImageOutR & ")"";" & vbCrLf
	HTML = HTML & "		}" & vbCrLf
	HTML = HTML & "	}" & vbCrLf
	HTML = HTML & "-->" & vbCrLf
	HTML = HTML & "</SCRIPT>" & vbCrLf
	ActionButton3Image = HTML
End Function



'SQLQueryで送信するChar型の値を整合
Function ConvQueryChar(Str)
	Str = Replace(Str, "'", "’")	'シングルコーテーションを全角化
	ConvQueryChar = Str
End Function


Function ConvIntToMoney(F_Target, F_Yenmark, F_Zeronull)
	Dim return1
	return1 = ""
	If IsNull(F_Target) Then
		F_Target = ""
	End If
	return1 = NumComma(F_Target, F_Zeronull)
	If F_Yenmark And return1 <> "" Then
		return1 = "&yen;" + return1
	End If
	ConvIntToMoney = return1
End Function

Function NumComma(F_Target, F_Zeronull)
	Dim Target			'変換対象
	Dim return1
	Dim tmp				'整数部・小数部の分割Work
	Dim Syosu			'少数部分
	Dim strlen
	If F_Zeronull And F_Target = "0" Then
		NumComma = ""
	ElseIf F_Target <> "" Then
		Target = CStr(F_Target)
		If InStr(Target, ".") > 0 Then
			tmp = Split(Target, ".")
			Target = tmp(0)
			Syosu  = tmp(1)
		End If
		Do While(Len(Target) > 0)
			strlen = 3
			If Len(Target) < 3 Then
				strlen = Len(Target)
			End If
			return1 = Right(Target, strlen) + return1
			Target  = Left(Target, Len(Target) - strlen)
			If (Target <> "-" And Len(Target) > 0) Or (Target = "-" And Len(Target) > 1) Then
				return1 = "," + return1
			End If
		Loop
		If Syosu <> "" Then
			return1 = return1 & "." & Syosu
		End If
		NumComma = return1
	End If
End Function


'半角英数字の連続を途中で改行可能にする
Function HardWrap(Str)
	Dim TmpStr
	Dim Cnt
	If Str <> "" Then
		For Cnt = 1 To Len(Str)
			If TmpStr <> "" Then
				TmpStr = TmpStr & "<wbr>"
			End If
			TmpStr = TmpStr & Mid(Str, Cnt, 1)
		Next
	End If
	HardWrap = TmpStr
End Function



Function NumComma(F_Target, F_Zeronull)
	Dim Target			'変換対象
	Dim return1
	Dim tmp				'整数部・小数部の分割Work
	Dim Syosu			'少数部分
	Dim strlen

	If F_Zeronull And F_Target = "0" Then
		NumComma = ""
	ElseIf F_Target <> "" Then
		Target = CStr(F_Target)
		If InStr(Target, ".") > 0 Then
			tmp = Split(Target, ".")
			Target = tmp(0)
			Syosu  = tmp(1)
		End If
		Do While(Len(Target) > 0)
			strlen = 3
			If Len(Target) < 3 Then
				strlen = Len(Target)
			End If

			return1 = Right(Target, strlen) + return1
			Target  = Left(Target, Len(Target) - strlen)
			If (Target <> "-" And Len(Target) > 0) Or (Target = "-" And Len(Target) > 1) Then
				return1 = "," + return1
			End If
		Loop
		If Syosu <> "" Then
			return1 = return1 & "." & Syosu
		End If
		NumComma = return1
	End If
End Function




Function ConvProhiStr(Str)	'サーバーサイド
	Dim NGStr
	Dim OKStr
	Dim rc
	NGStr = "ｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾊﾋﾌﾍﾎ"
	OKStr = "ガギグゲゴザジズゼゾダヂヅデドバビブベボパピプペポ"
	rc = ""
	Dim ii
	Dim c
	Dim n
	For ii = 1 To Len(Str)
		If Mid(Str, ii, 1) <> "ﾞ" And Mid(Str, ii, 1) <> "ﾟ" Then
			c = Mid(Str, ii, 1)
			n = InStr(NGStr, c)
			If n > 0 Then
				If ii + 1 < Len(Str) Then
					If Mid(Str, ii + 1, 1) = "ﾞ" Then
						c = Mid(OKStr, n, 1)
					ElseIf Mid(Str, ii + 1, 1) = "ﾟ" Then
						c = Mid(OKStr, n + 5, 1) '半濁音時は置換文字を5文字シフト
					End If
				End If
			End If
			rc = rc + c
		End If
	Next
	Str = rc
	NGStr = "ｱｲｳｴｵｶｷｸｹｺｻｼｽｾｿﾀﾁﾂﾃﾄﾅﾆﾇﾈﾉﾊﾋﾌﾍﾎﾏﾐﾑﾒﾓﾔﾕﾖﾗﾘﾙﾚﾛﾜｦﾝｧｨｩｪｫｬｭｮｯ､｡ｰ｢｣ﾞﾟ"
	NGStr = NGStr + "ａｂｃｄｅｆｇｈｉｊｋｌｍｎｏｐｑｒｓｔｕｖｗｘｙｚＡＢＣＤＥＦＧＨＩＪＫＬＭＮＯＰＱＲＳＴＵＶＷＸＹＺ"
	NGStr = NGStr + "１２３４５６７８９０"
	NGStr = NGStr + "／'""#\"
	OKStr = "アイウエオカキクケコサシスセソタチツテトナニヌネノ"
	OKStr = OKStr + "ハヒフヘホマミムメモヤユヨラリルレロワヲンァィゥェォャュョッ、。ー「」　　"
	OKStr = OKStr + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"
	OKStr = OKStr + "1234567890"
	OKStr = OKStr + "/’”＃￥"
'Response.Write("NGStr = " & Len(NGStr) & "<BR>")
'Response.Write("OKStr = " & Len(OKStr) & "<BR>")
'Exit Function
	rc = ""
	For ii = 1 To Len(Str)
		c = Mid(Str, ii, 1)
		n = InStr(NGStr, c)
		If n > 0 Then
			c = Mid(OKStr, n, 1)
		End If
		rc = rc + c
	Next
	ConvProhiStr = rc
End Function


'URL文字列の補正 -「http://」を補完する
Function URLHttpComp(URLStr)
	If Left(URLStr, 1) = "/" Or Left(URLStr, 2) = "./" Or Left(URLStr, 3) = "../" Then	'先頭が相対パス指定なら除外
	Else
		If URLStr <> "" Then
			If InStr(URLStr, "://") < 1 Then
				URLStr = "http://" & URLStr
			End If
		End If
	End If
	URLHttpComp = URLStr
End Function



'禁止ワード
Function DeniedWordCheck(Str)
	Dim Query
	Dim Content
	Dim TmpCnt
	DeniedWordCheck = True
	Dim TmpStr
	TmpStr = UCase("" & Str)
	'SQLインジェクション対策
	TmpStr = Replace("" & TmpStr, vbCrLf, " ")	'改行コードは半角スペースに変換（SQL文では改行が構文セパレータに使えるため）
	Dim TableAry
	ReDim TableAry(0)
	Query = " SELECT * FROM dbo.sysobjects WHERE xtype = 'U' AND LEFT(name, 1) = 'T' ORDER BY name "
	Set Content = OpenQuery(Query)
	Do While Not(Content.BOF Or Content.EOF)
		ReDim PreServe TableAry(UBound(TableAry) + 1)	'配列+1
		TableAry(UBound(TableAry)) = UCase(" " & Content.Fields("name").value)	'テーブル名の前に半角スペースがある場合のみを対象とする
		Content.MoveNext
	Loop
	For TmpCnt = 1 To UBound(TableAry)
		If InStr(TmpStr, TableAry(TmpCnt)) > 0 And ( _
			(InStr(TmpStr, "DELETE ") > 0 And InStr(TmpStr, " FROM ") > 0) _
			Or (InStr(TmpStr, "UPDATE ") > 0 And InStr(TmpStr, " SET ") > 0) _
			Or (InStr(TmpStr, "INSERT ") > 0 And (InStr(TmpStr, " SELECT") > 0 Or InStr(TmpStr, " VALUES") > 0)) _
		) Then
			Response.Write(HtmlHeader("Default", "0"))
			Response.Write("　禁止ワードが含まれています。<br>")
			Response.Write("　入力し直してください。<br><br>")
			Response.Write("　抵触ワード：システム予約ワード<br><br>")
			Response.Write("　<a href=""JavaScript:history.go(-1);"">戻る</a>" & vbCrLf)
			Response.Write("</body>" & vbCrLf)
			Response.Write("</html>" & vbCrLf)
			DeniedWordCheck = False
			Exit Function
		End If
	Next
	'禁止ワード
	Dim DeniedWord
	ReDim DeniedWord(0)
	Query = "exec SPM禁止ワード取得"
	Set Content = OpenQuery(Query)
	Do While Not(Content.BOF Or Content.EOF)
		ReDim PreServe DeniedWord(UBound(DeniedWord) + 1)	'配列+1
		DeniedWord(UBound(DeniedWord)) = UCase("" & Content.Fields("禁止ワード"))
		Content.MoveNext
	Loop
	For TmpCnt = 1 To UBound(DeniedWord)
		If InStr(StrConvNarrow(TmpStr), StrConvNarrow(DeniedWord(TmpCnt))) > 0 Then
			Response.Write(HtmlHeader("Default", "0"))
			Response.Write("　禁止ワードが含まれています。<br>")
			Response.Write("　入力し直してください。<br><br>")
			Response.Write("　抵触ワード：「" & DeniedWord(TmpCnt) & "」<br><br>")
			Response.Write("　<a href=""JavaScript:history.go(-1);"">戻る</a>" & vbCrLf)
			Response.Write("</body>" & vbCrLf)
			Response.Write("</html>" & vbCrLf)
			DeniedWordCheck = False
			Exit Function
		End If
	Next
End Function



'文字列のByte数を取得
Function AscLen(p_Str)
	Dim i
	Dim ii
	Dim iAscCode
	Dim iCount
	If Len(p_Str) = 0 Then
		AscLen = 0
		Exit Function
	End If
	If IsNull(Len(p_Str)) Then
		AscLen = 0
		Exit Function
	End If
	AscLen = 0	'初期化
	iCount = 0	'初期化
	For i = 1 to Len(p_Str)				'1文字ずつ処理
		iCount = iCount + 1			'Byteカウントアップ
		iAscCode = Asc(Mid(p_Str, i, 1))	'Asc関数で文字コード取得
		If Len(Hex(iAscCode)) > 2 Then		'16進3桁以上なら全角文字と判定
			iCount = iCount + 1		'全角文字の場合はByteカウントアップ
		End If
	Next
	AscLen = iCount
End Function



'クエリ文字の日本語はプロキシによって送信出来ないケースがあるので
'submit()コマンドでリダイレクトさせるHTML構文を書き出す
Function SubmitRedirect(Url)

	Dim UrlQueryString
	Dim UrlQueryStrAry
	Dim TmpCnt
	Dim TmpQuery
	Dim TmpHTML
	TmpHTML = ""

	If InStr(Url, "?") > 0 Then
		TmpHTML = TmpHTML & HtmlHeader("Default", "0")
		TmpHTML = TmpHTML & "<body>" & vbCrLf
		TmpHTML = TmpHTML & "<form method=""POST"" name=""formHystoryBack"" action=""" & Left(Url, InStr(Url, "?") - 1) & """>" & vbCrLf
		UrlQueryString = Mid(Url, InStr(Url, "?") + 1)
		UrlQueryStrAry = Split(UrlQueryString, "&")
		For TmpCnt = 0 To UBound(UrlQueryStrAry)
			TmpQuery = Split(UrlQueryStrAry(TmpCnt), "=")
			If UBound(TmpQuery) = 1 Then
'				TmpHTML = TmpHTML & "<input type=""hidden"" name=""" & TmpQuery(0) & """ value=""" & TmpQuery(1) & """>" & vbCrLf
				TmpHTML = TmpHTML & "<input type=""hidden"" name=""" & TmpQuery(0) & """ value="""">" & vbCrLf
			End If
		Next
		TmpHTML = TmpHTML & "</form>" & vbCrLf
		TmpHTML = TmpHTML & "</body>" & vbCrLf
		TmpHTML = TmpHTML & "<SCRIPT FOR=""window"" EVENT=""onload"" LANGUAGE=""JavaScript"">" & vbCrLf
		TmpHTML = TmpHTML & "<!--" & vbCrLf
		For TmpCnt = 0 To UBound(UrlQueryStrAry)
			TmpQuery = Split(UrlQueryStrAry(TmpCnt), "=")
			If UBound(TmpQuery) = 1 Then
				TmpHTML = TmpHTML & "	document.formHystoryBack." & TmpQuery(0) & ".value = """ & TmpQuery(1) & """;" & vbCrLf
			End If
		Next
		TmpHTML = TmpHTML & "	SubmitReal(formHystoryBack);" & vbCrLf
		TmpHTML = TmpHTML & "-->" & vbCrLf
		TmpHTML = TmpHTML & "</SCRIPT>" & vbCrLf
		TmpHTML = TmpHTML & "</html>" & vbCrLf
	End If

	SubmitRedirect = TmpHTML

End Function


'070417小野　引数：整数,0画像URL,1画像URL,2画像URL,3画像URL,4画像URL,5画像URL,6画像URL,7画像URL,8画像URL,9画像URL,最小桁数
Function AccessCounter(AccCnt,zeropic,onepic,twopic,threepic,fourpic,fivepic,sixpic,sevenpic,eightpic,ninepic,column)
	Dim i
	Dim ii
	Dim TmpAccCnt
	Dim TmpStr
	ReDim TmpStr(0)
	Dim TmpImg
	'文字列化
	TmpAccCnt = "" & AccCnt
	'空文字なら"0"
	If TmpAccCnt = "" Then
		TmpAccCnt = "0"
	End If
	'文字列の右端から1文字ずつ配列化
	For i = 1 To Len(TmpAccCnt)
		ReDim Preserve TmpStr(i)
		TmpStr(i) = Mid(TmpAccCnt, Len(TmpAccCnt)-i+1, 1)
	Next
	'文字数がcolumn未満なら0を増やしてcolumn桁にする
	For ii = i To column
		ReDim Preserve TmpStr(ii)
		TmpStr(ii) = "0"
	Next
	'右端から1文字ずつimgタグ化
	TmpAccCnt = ""
	For i = 1 To UBound(TmpStr)
		TmpImg = "<img src="""
		Select Case TmpStr(i)
			Case	"0"
				TmpImg = TmpImg & zeropic
			Case	"1"
				TmpImg = TmpImg & onepic
			Case	"2"
				TmpImg = TmpImg & twopic
			Case	"3"
				TmpImg = TmpImg & threepic
			Case	"4"
				TmpImg = TmpImg & fourpic
			Case	"5"
				TmpImg = TmpImg & fivepic
			Case	"6"
				TmpImg = TmpImg & sixpic
			Case	"7"
				TmpImg = TmpImg & sevenpic
			Case	"8"
				TmpImg = TmpImg & eightpic
			Case	"9"
				TmpImg = TmpImg & ninepic
		End Select
		TmpImg = TmpImg & """>"
		TmpAccCnt = TmpImg + TmpAccCnt
	Next
	AccessCounter = TmpAccCnt
End Function

'SQLクエリを適当に整えてHTML書式にする（Viewmodeが1以上なら別ウィンドウを開く）
Function QueryView(Queryword, Viewmode)

	'連続半角空白を単独半角空白に変換
	Dim StrCnt
	For StrCnt = 1 To Len(Queryword)	'文字数ループ
		Queryword = Replace(Queryword, "  ", " ")
	Next

	'適当なキーワードの直前に改行タグと改行コードを入れる
	Queryword = Replace(Queryword, "SELECT ", "<BR>" & vbCrLf & "SELECT ")	'SELECT
	Queryword = Replace(Queryword, "FROM ",   "<BR>" & vbCrLf & "FROM ")	'FROM
	Queryword = Replace(Queryword, "LEFT ",   "<BR>" & vbCrLf & "LEFT ")	'LEFT OUTER JOIN
	Queryword = Replace(Queryword, "RIGHT ",  "<BR>" & vbCrLf & "RIGHT ")	'RIGHT OUTER JOIN
	Queryword = Replace(Queryword, "INNER ",  "<BR>" & vbCrLf & "INNER ")	'INNER JOIN
	Queryword = Replace(Queryword, "ON ",     "<BR>" & vbCrLf & "　　ON ")	'ON（インデント）
	Queryword = Replace(Queryword, "WHERE ",  "<BR>" & vbCrLf & "WHERE ")	'WHERE
	Queryword = Replace(Queryword, "AND ",    "<BR>" & vbCrLf & "　　AND ")	'AND（インデント）
	Queryword = Replace(Queryword, "OR ",     "<BR>" & vbCrLf & "　　OR ")	'OR（インデント）
	Queryword = Replace(Queryword, "GROUP ",  "<BR>" & vbCrLf & "GROUP ")	'GROUP BY
	Queryword = Replace(Queryword, "HAVING ", "<BR>" & vbCrLf & "HAVING ")	'HAVING
	Queryword = Replace(Queryword, "ORDER ",  "<BR>" & vbCrLf & "ORDER ")	'ORDER BY
	Queryword = Replace(Queryword, "UPDATE ", "<BR>" & vbCrLf & "UPDATE ")	'UPDATE
	Queryword = Replace(Queryword, "SET ",    "<BR>" & vbCrLf & "SET ")		'SET
	Queryword = Replace(Queryword, "INSERT ", "<BR>" & vbCrLf & "INSERT ")	'INSERT
	Queryword = Replace(Queryword, "VALUES ", "<BR>" & vbCrLf & "VALUES ")	'VALUES
	Queryword = Replace(Queryword, "UNION ",  "<BR>" & vbCrLf & "UNION ")	'UNION
'	Queryword = Replace(Queryword, " ", "<BR> ")	'

	'括弧内のAND/ORをインデントする処理
	Dim KakkoCnt
	Dim TmpStr
	KakkoCnt = 0
	For StrCnt = 1 To Len(Queryword)
		'開く括弧があったらKakkoCnt+1
		If Mid(Queryword, StrCnt, 1) = "(" Then
			KakkoCnt = KakkoCnt + 1
		'KakkoCnt>0で"AND"もしくは"OR"があったらインデント
		ElseIf KakkoCnt > 0 And (Mid(Queryword, StrCnt, 4) = "AND " Or Mid(Queryword, StrCnt, 3) = "OR ") Then
			TmpStr = Left(Queryword, StrCnt - 1)
			Dim SpaceCnt
			'KakkoCntの数だけインデントする
			For SpaceCnt = 1 To KakkoCnt
				TmpStr = TmpStr & "　　"
			Next
			Queryword = TmpStr & Right(Queryword, Len(Queryword) - StrCnt + 1)
			'検索位置をシフトする（最低でも"　　OR"の分シフトするので+4)
			StrCnt = StrCnt + 4
		'閉じる括弧があったらKakkoCnt-1
		ElseIf Mid(Queryword, StrCnt, 1) = ")" Then
			KakkoCnt = KakkoCnt - 1
		End If
	Next

	'先頭に空白文字と<BR>があったら削る
	Queryword = LTrim(Queryword)
	If Left(Queryword, 4) = "<BR>" Then
		Queryword = Right(Queryword, Len(Queryword) - 4)
	End If

	'先頭装飾
	Queryword = "<B>SQLクエリ</B><BR>" & vbCrLf & Queryword & vbCrLf


	'別ウィンドウで開く場合
	If Viewmode > 0 Then

		'クエリ文をCookieに書き込む
		Response.Cookies("Queryword") = Queryword

		'新規ウィンドウを開くHTML構文を返す
		Queryword = "<SCRIPT LANGUAGE=""JavaScript"">" & vbCrLf
		Queryword = Queryword & "<!--" & vbCrLf
								'新規ウィンドウのqueryword.asp側でCookieを取得表示する
		Queryword = Queryword & "	window.open(""queryword.asp"", ""Queryword"");" & vbCrLf
		Queryword = Queryword & "-->" & vbCrLf
		Queryword = Queryword & "</SCRIPT>" & vbCrLf

	End If

	'戻り値
	QueryView = Queryword

End Function


'CreateWhereword(テーブル名, 比較列名, キーワード, AND/ORスイッチ, =/LIKEスイッチ)
'　WHEREによる絞込み文字列を作成する関数
'　　( テーブル名.比較列名 (NOT)LIKE '%キーワード配列0%' AND/OR テーブル名.比較列名 =/<> 'キーワード配列1' AND/OR ・・・)
'　　のような形式でクエリ文を生成する。
'　　テーブル名はNULL文字は許容されるが、テーブル結合の際はテーブル名を入れておかないと
'　　テーブル結合により同じ名前の列が複数生じた際に比較対象列があいまいでエラーになる。
Function CreateWhereword(TableName, FieldName, Keyword, AndOr, LikeFlg)
	Dim TmpTableName
	If TableName <> "" Then
		TmpTableName = TableName & "."
	End If
	Dim TmpStr
	Dim CreateStr
	TmpStr = Keyword

	'Keywordがカンマ区切り配列なら半角空白区切りに変換（事前処理）
	TmpStr = Replace(TmpStr, ",", " ")

	'Keywordに含まれる全角空白を半角空白に置換＆先頭及び末尾の空白を除去（事前処理）
	TmpStr = LTrim(RTrim(Replace(TmpStr, "　", " ")))

	'Keywordに含まれる連続半角空白を単独半角空白に置換（事前処理）
	Dim ii
	For ii = 1 To Len(TmpStr)	'文字数ループ
		TmpStr = Replace(TmpStr, "  ", " ")
	Next

	'Keywordを半角空白区切りで配列に分解
	Dim TmpStrArray
	TmpStrArray = Split(TmpStr, " ")

	'Keywordが存在しなければキーワード配列が作成されないため例外処理（ワイルドカード文字を代入）
	If Replace(TmpStr, " ", "") = "" Then
		CreateStr = " ( " & TableName & "." & FieldName & " LIKE '%' ) "

	'抽出条件作成処理
	Else
		'OR検索に対応させるため括弧を付ける
		CreateStr = CreateStr & " ( "
		Dim KeywordCnt
		For KeywordCnt = 0 To UBound(TmpStrArray)
			'配列番号1以降は先頭にAND/OR条件を付ける
			If KeywordCnt > 0 Then
				If AndOr <> "1" Then
					CreateStr = CreateStr & " AND "
				Else
					CreateStr = CreateStr & " OR "
				End If
			End If
			'列内比較文字列の作成処理
			'　キーワードの先頭に"-"があればNOT条件にする（その場合は先頭の"-"を削った文字列がキーワードになる）
			'　ワールドカード利用フラグの状態によって比較演算子を切り替える
			If Left(TmpStrArray(KeywordCnt), 1) = "-" Then
				If LikeFlg > 0 Then
					CreateStr = CreateStr & " " & TableName & "." & FieldName & " NOT LIKE '%" & Right(TmpStrArray(KeywordCnt), Len(TmpStrArray(KeywordCnt)) - 1) & "%' "
				Else
					CreateStr = CreateStr & " " & TableName & "." & FieldName & " <> '" & Right(TmpStrArray(KeywordCnt), Len(TmpStrArray(KeywordCnt)) - 1) & "' "
				End If
			Else
				If LikeFlg > 0 Then
					CreateStr = CreateStr & " " & TableName & "." & FieldName & " LIKE '%" & TmpStrArray(KeywordCnt) & "%' "
				Else
					CreateStr = CreateStr & " " & TableName & "." & FieldName & " = '" & TmpStrArray(KeywordCnt) & "' "
				End If
			End If
		Next
		'OR検索に対応させるため括弧を付ける
		CreateStr = CreateStr & " ) "
	End If

	'戻り値
	CreateWhereword = CreateStr

End Function


%>