<% option Explicit %> <% '################################################ ' 名称 :共通変数・共通関数の定義 ' 作成日 :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("ErrorDirectory Listing Denied") Response.Write("

Directory Listing Denied

This Virtual Directory does not allow contents to be listed.") 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に該当する学校が存在しません。
") Response.Write("ログインし直してください。
") Response.Write("
") Response.Write("戻る") End If Else Response.Write("一定時間無操作により接続がタイムアウトしました。
") Response.Write("ログインし直してください。
") Response.Write("
") Response.Write("戻る") 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 & "日はショップ管理が許可されておりません。
") Response.Write("
") Response.Write("戻る") 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("現在時刻はショップ管理が許可されておりません。
") Response.Write("ショップ管理が可能な時間帯 " & StartTime & " 〜 " & EndTime & "
") Response.Write("
") Response.Write("戻る") End If End If Else Response.Write("ログインIDに該当するショップが存在しません。
") Response.Write("ログインし直してください。
") Response.Write("
") Response.Write("戻る") End If Else Response.Write("一定時間無操作により接続がタイムアウトしました。
") Response.Write("ログインし直してください。
") Response.Write("
") Response.Write("戻る") End If 'End If End Function Function SysAdminCheck() 'If 0=1 Then SysAdminCheck = False If GB_SysAdmin = "1" Then SysAdminCheck = True Else Response.Write("一定時間無操作により接続がタイムアウトしました。
") Response.Write("ログインし直してください。
") Response.Write("
") Response.Write("戻る") 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("データベースへの接続でエラーが発生しました


") Response.Write("メッセージ : " & Err.Description & "

") Response.Write("送信クエリ : " & Query & "


") 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("メールが送信できませんでした。
") Response.Write("エラーコード:") Response.Write(rc) Response.Write("

") Response.Write(ErrMes) Response.Write("

") Response.Write("戻る") 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 = "" ' If LCase(Right(ImagePath, 4)) = ".gif" Then ' 'GIFイメージカウントアップ(JavaScript内接リサイズ処理のためのidをユニークにするためページ内で通し番号にする) ' GIFCnt = GIFCnt + 1 ' TmpStr = TmpStr & "" & vbCrLf ' TmpStr = TmpStr & "" & vbCrLf ' Else ' TmpStr = TmpStr & "" & 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 = "" 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 & "" & 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 & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & 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 & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf End If HTMLOut = HTMLOut & "
" & 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 = "" End If End If If "" & Content.Fields("カート非利用") = "1" And "" & Content.Fields("カート非利用URL") <> "" Then HTMLOut = HTMLOut & " " & TmpImageTmp & "" & vbCrLf Else HTMLOut = HTMLOut & " " & TmpImageTmp & "" & vbCrLf End If HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf '半角英字想定によりボトムラインがずれるのでダミー HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf If Shoplink Then HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf End If HTMLOut = HTMLOut & "
" & Spacer(1, 3) & "
" & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & " " & vbCrLf HTMLOut = HTMLOut & "
" & Spacer(3, 1) & "" & vbCrLf If "" & Content.Fields("カート非利用") = "1" And "" & Content.Fields("カート非利用URL") <> "" Then HTMLOut = HTMLOut & " " & Content.Fields("名称") & "" & vbCrLf Else HTMLOut = HTMLOut & " " & Content.Fields("名称") & "" & vbCrLf End If HTMLOut = HTMLOut & " " & Spacer(3, 1) & "
" & vbCrLf HTMLOut = HTMLOut & "
" & vbCrLf If Content.Fields("価格") = 0 Then HTMLOut = HTMLOut & " 時価(ご注文後にお知らせいたします)" & vbCrLf Else HTMLOut = HTMLOut & " ¥" & ConvIntToMoney(Content.Fields("価格"), False, False) & "(" If "" & Content.Fields("消費税フラグ") = "1" Then HTMLOut = HTMLOut & "税込" Else HTMLOut = HTMLOut & "税別" End If HTMLOut = HTMLOut & ")" &vbCrLf End If HTMLOut = HTMLOut & "
" &vbCrLf Dim MaxRow MaxRow = 6 ' Dim RCnt ' Dim TmpRow ' TmpRow = Split("" & Content.Fields("紹介文"), "
") ' If UBound(TmpRow) + 1 < MaxRow Then ' MaxRow = UBound(TmpRow) + 1 ' End If ' For RCnt = 0 to MaxRow - 1 ' HTMLOut = HTMLOut & TmpRow(RCnt) & "
" & vbCrLf ' Next HTMLOut = HTMLOut & "
" & Content.Fields("紹介文") & "
" & vbCrLf HTMLOut = HTMLOut & "
" & vbCrLf HTMLOut = HTMLOut & " [" & Content.Fields("ショップ名称") & "]" & vbCrLf '全ての商品を表示する場合は学校名を表示 If (ShopGakko = "" Or IsNumeric(ShopGakko)) And LCase(Content.Fields("ホスト名")) <> "hsns" Then ' HTMLOut = HTMLOut & " :" & vbCrLf HTMLOut = HTMLOut & " [" & ShopGakko & Content.Fields("学校名称") & "]" & vbCrLf End If HTMLOut = HTMLOut & "
" & vbCrLf HTMLOut = HTMLOut & "
" & vbCrLf If Page > 0 Or Not(Content.BOF Or Content.EOF) Then HTMLOut = HTMLOut & " " & vbCrLf If Page > 0 Then HTMLOut = HTMLOut & "" & vbCrLf HTMLOut = HTMLOut & "" & vbCrLf HTMLOut = HTMLOut & "" & vbCrLf End If If Not(Content.BOF Or Content.EOF) Then HTMLOut = HTMLOut & "" & vbCrLf HTMLOut = HTMLOut & "" & vbCrLf HTMLOut = HTMLOut & "" & vbCrLf End If HTMLOut = HTMLOut & "
   " & 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 & "      " & 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 & "   
" & vbCrLf End If HTMLOut = HTMLOut & "
" & Spacer(1,10) & "
" & 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 & "" & 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 & "" & vbCrLf End If HTML = HTML & "" & vbCrLf HTML = HTML & " " & vbCrLf HTML = HTML & " " & vbCrLf HTML = HTML & " " & vbCrLf HTML = HTML & " " & vbCrLf HTML = HTML & " " & vbCrLf HTML = HTML & "
" & Label & "
" & vbCrLf HTML = HTML & "" & 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 = "¥" + 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 & "" 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 + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" NGStr = NGStr + "1234567890" NGStr = NGStr + "/'""#\" OKStr = "アイウエオカキクケコサシスセソタチツテトナニヌネノ" OKStr = OKStr + "ハヒフヘホマミムメモヤユヨラリルレロワヲンァィゥェォャュョッ、。ー「」  " OKStr = OKStr + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" OKStr = OKStr + "1234567890" OKStr = OKStr + "/’”#¥" 'Response.Write("NGStr = " & Len(NGStr) & "
") 'Response.Write("OKStr = " & Len(OKStr) & "
") '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(" 禁止ワードが含まれています。
") Response.Write(" 入力し直してください。

") Response.Write(" 抵触ワード:システム予約ワード

") Response.Write(" 戻る" & vbCrLf) Response.Write("" & vbCrLf) Response.Write("" & 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(" 禁止ワードが含まれています。
") Response.Write(" 入力し直してください。

") Response.Write(" 抵触ワード:「" & DeniedWord(TmpCnt) & "」

") Response.Write(" 戻る" & vbCrLf) Response.Write("" & vbCrLf) Response.Write("" & 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 & "" & vbCrLf TmpHTML = TmpHTML & "
" & 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 & "" & vbCrLf TmpHTML = TmpHTML & "" & vbCrLf End If Next TmpHTML = TmpHTML & "
" & vbCrLf TmpHTML = TmpHTML & "" & vbCrLf TmpHTML = TmpHTML & "" & vbCrLf TmpHTML = TmpHTML & "" & 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 = "" 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 ", "
" & vbCrLf & "SELECT ") 'SELECT Queryword = Replace(Queryword, "FROM ", "
" & vbCrLf & "FROM ") 'FROM Queryword = Replace(Queryword, "LEFT ", "
" & vbCrLf & "LEFT ") 'LEFT OUTER JOIN Queryword = Replace(Queryword, "RIGHT ", "
" & vbCrLf & "RIGHT ") 'RIGHT OUTER JOIN Queryword = Replace(Queryword, "INNER ", "
" & vbCrLf & "INNER ") 'INNER JOIN Queryword = Replace(Queryword, "ON ", "
" & vbCrLf & "  ON ") 'ON(インデント) Queryword = Replace(Queryword, "WHERE ", "
" & vbCrLf & "WHERE ") 'WHERE Queryword = Replace(Queryword, "AND ", "
" & vbCrLf & "  AND ") 'AND(インデント) Queryword = Replace(Queryword, "OR ", "
" & vbCrLf & "  OR ") 'OR(インデント) Queryword = Replace(Queryword, "GROUP ", "
" & vbCrLf & "GROUP ") 'GROUP BY Queryword = Replace(Queryword, "HAVING ", "
" & vbCrLf & "HAVING ") 'HAVING Queryword = Replace(Queryword, "ORDER ", "
" & vbCrLf & "ORDER ") 'ORDER BY Queryword = Replace(Queryword, "UPDATE ", "
" & vbCrLf & "UPDATE ") 'UPDATE Queryword = Replace(Queryword, "SET ", "
" & vbCrLf & "SET ") 'SET Queryword = Replace(Queryword, "INSERT ", "
" & vbCrLf & "INSERT ") 'INSERT Queryword = Replace(Queryword, "VALUES ", "
" & vbCrLf & "VALUES ") 'VALUES Queryword = Replace(Queryword, "UNION ", "
" & vbCrLf & "UNION ") 'UNION ' Queryword = Replace(Queryword, " ", "
") ' '括弧内の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 '先頭に空白文字と
があったら削る Queryword = LTrim(Queryword) If Left(Queryword, 4) = "
" Then Queryword = Right(Queryword, Len(Queryword) - 4) End If '先頭装飾 Queryword = "SQLクエリ
" & vbCrLf & Queryword & vbCrLf '別ウィンドウで開く場合 If Viewmode > 0 Then 'クエリ文をCookieに書き込む Response.Cookies("Queryword") = Queryword '新規ウィンドウを開くHTML構文を返す Queryword = "" & 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 %>