<% Option Explicit %> <% '-------------------------------------------------------------------------------------------------- '概　要 : 法人東京　スポーツデスク 資料請求・お問い合わせフォーム '更新日 : 2009/04/23 J.Nishikawa ' 2009/05/08 J.Nishikawa パラメタ取得時に半角カナを全角カナに変換 ' 2009/05/08 J.Nishikawa お問い合わせ時に回答方法を必須にするパラメタチェックを追加 '-------------------------------------------------------------------------------------------------- Call indexMain() Sub indexMain() Dim cConfig Dim objConn Dim dicParameter Dim xmlDoc Dim domElement Dim sError Dim sRedirect sRedirect = "" ' Config '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Set cConfig = New Config ' Sessionオブジェクトの初期化 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Session.Contents.RemoveAll() ' DB接続 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Set objConn = DBConnect(cConfig.Item("DBConnection")) ' 出力用DOMDocument生成 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Set xmlDoc = CreateDOMDocument(cConfig.Item("Encoding")) xmlDoc.appendChild(CreateElement(xmlDoc, "root", "")) ' Requestパラメータ取得 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Set dicParameter = Nothing Call GetParam(xmlDoc, cConfig.Item("ApplicationXML"), dicParameter) ' データチェックしてＯＫなら確認画面へ '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- If dicParameter.Item("Mode") = "Confirm" Then If IsDataCheck(objConn, dicParameter, xmlDoc, cConfig.Item("ApplicationXML")) Then Call SetSession(objConn, dicParameter, xmlDoc, cConfig.Item("ApplicationXML")) sRedirect = "confirm.asp" End If End If ' 出力 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- If sRedirect = "" Then ' XSLT適用 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- sError = "" Response.Write ApplyXSLT(xmlDoc, cConfig.Item("XSLFolder") & dicParameter.Item("ScriptName") & ".xsl", sError) ' デバッグ出力 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- If cConfig.Item("Debug") Then Set domElement = CreateElement(xmlDoc, "Configuration", "") Call DicToDom(domElement, cConfig.GetDictionary()) xmlDoc.documentElement.appendChild(domElement) Response.Write "

" & sError & "

" Response.Write "

" End If End If '開放処理 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Set objConn = Nothing Set dicParameter = Nothing Set xmlDoc = Nothing Set cConfig = Nothing 'リダイレクト '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- If sRedirect <> "" Then Response.Redirect(sRedirect) End Sub '------------------------------------------------------------------------------- '概　要 : パラメータ取得 '引　数 : xmlDoc - MSXML2.DOMDocument '　　　 : sApplyXMLFileName - アプリケーション設定XMLファイル名(String) '　　　 : dicParameter - パラメータDictionary(Dictionary)[OUT] '戻り値 : '------------------------------------------------------------------------------- Sub GetParam(ByRef xmlDoc, ByVal sApplyXMLFileName, ByRef dicParameter) Const PARAMETER_ELEMENT = "Parameters" Const SEARCH_PARAM_XPATH = "/root/Page[@Name = 'index']/Parameters/Param/text()" Dim dom Dim domElement Dim fld 'パラメタ取得：Application.xmlに定義のある必要なキー名のみ取得 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Call LoadXML(sApplyXMLFileName, dom) Set dicParameter = GetRequestParam(GetNodeValues(dom, SEARCH_PARAM_XPATH)) Set dom = Nothing '2009/05/08 J.Nishikawa パラメタ中の半角カナを全角カナに変換 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- For Each fld in dicParameter.Keys dicParameter.Item(fld) = HanToZen( dicParameter.Item(fld) ) Next 'パラメータをXMLへ '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Set domElement = CreateElement(xmlDoc, PARAMETER_ELEMENT, "") Call DicToDom(domElement, dicParameter) xmlDoc.documentElement.appendChild(domElement) Set domElement = Nothing End Sub '------------------------------------------------------------------------------- '概　要 : 入力チェック '引　数 : objConn - ADODB.Connection '　　　 : dicParameter - Dictionary Object '　　　 : xmlDoc - MSXML2.DOMDocument '　　　 : sApplyXMLFileName - アプリケーション設定XMLファイル名(String) '戻り値 : Boolean True:OK / False:NG '------------------------------------------------------------------------------- '更新履歴 ' 2009/04/16 J.Nishikawa エラーメッセージ作成時に '------------------------------------------------------------------------------- Function IsDataCheck(ByRef objConn, ByRef dicParameter, ByRef xmlDoc, ByVal sApplyXMLFileName) Const ERROR_PARENT_TAG = "InputErrors" Const ERROR_TAG = "InputError" Const ERROR_ATTRIBUTE_NAME = "InputName" Const SEARCH_PARAM_XPATH = "/root/Page[@Name = 'index']/IsDataCheck/Parameters/Param/text()" 'エラーメッセージ Const ERROR_MESSAGE_EMAIL01 = "メールアドレスと確認用メールアドレスが一致しません。もう一度ご入力ください。" Const ERROR_MESSAGE_EMAIL02 = "お問い合わせの場合は回答方法をご選択ください。" Dim bFlg Dim dom Dim aParam Dim domElement , domElement2 Dim dicDefine Dim sItem Dim vValue Dim sError Dim s Dim i Dim sbuff Dim chkEmail1, chkEmail2 bFlg = True 'データチェック配列取得：Application.xmlに定義のある必要なキー名配列のみ取得 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Call LoadXML(sApplyXMLFileName, dom) aParam = GetNodeValues(dom, SEARCH_PARAM_XPATH) Set dom = Nothing 'ERROR_PARENT_TAG部の生成 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Set domElement = xmlDoc.createElement(ERROR_PARENT_TAG) Set dicDefine = DataDefine() For Each sItem In aParam sError = "" 'デフォルト値 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- vValue = dicDefine.Item(sItem)(5) If Len(vValue) = 0 Then vValue = dicParameter.Item(sItem) '入力チェック '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- dicParameter.Item(sItem) = Validate(dicParameter.Item(sItem), dicDefine.Item(sItem)(0), dicDefine.Item(sItem)(2), dicDefine.Item(sItem)(3), dicDefine.Item(sItem)(4), vValue, sError) '固有チェック '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- If Len(sError) = 0 Then Select Case sItem Case "confirmEmail01" '確認用Emailの一致 If Len( dicParameter.Item("confirmEmail01") ) > 0 and Len( dicParameter.Item("confirmEmail02") ) > 0 Then chkEmail1 = dicParameter.Item("Email01") & "@" & dicParameter.Item("Email02") chkEmail2 = dicParameter.Item("confirmEmail01") & "@" & dicParameter.Item("confirmEmail02") If Not chkEmail1 = chkEmail2 Then sError = ERROR_MESSAGE_EMAIL01 End If Case "AnswerMethod1" '2009/05/08 J.Nishikawa お問い合わせ時に回答方法を必須とする。 If dicParameter.Item("InquiryType") = "2" Then If Not ( dicParameter.Item("AnswerMethod1") = "1" or dicParameter.Item("AnswerMethod2") = "1" ) Then sError = ERROR_MESSAGE_EMAIL02 End If End If End Select End If 'エラーメッセージ生成 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- If Len(sError) > 0 Then '2009/04/16 J.Nishikawa '属性値でERROR_ATTRIBUTE_NAMEを追記してエラーメッセージの場所を場所を各コントロールの下などに '表示できるようにするために記述 'ERROR_TAG部生成 set domElement2 = CreateElement(xmlDoc, ERROR_TAG, sError) 'ERROR_PARENT_TAGへ属性値( ERROR_ATTRIBUTE_NAME )を追加／値はパラメタ名 call domElement2.setAttribute( ERROR_ATTRIBUTE_NAME, sItem ) 'ERROR_PARENT_TAGの子ノードとしてERROR_TAG部を追加（属性値付与済） domElement.appendChild(domElement2) set domElement2 = nothing bFlg = False End If Next Set dicDefine = Nothing 'xmlDocに対してERROR_PARENT_TAG部を追加 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- xmlDoc.documentElement.appendChild(domElement) Set domElement = Nothing IsDataCheck = bFlg End Function '------------------------------------------------------------------------------- '概　要 : セッションへ格納 '引　数 : objConn - ADODB.Connection '　　　 : dicParameter - Dictionary Object '　　　 : xmlDoc - MSXML2.DOMDocument '　　　 : sApplyXMLFileName - アプリケーション設定XMLファイル名(String) '戻り値 : '------------------------------------------------------------------------------- Sub SetSession(ByRef objConn, ByRef dicParameter, ByRef xmlDoc, ByVal sApplyXMLFileName) Const SEARCH_PARAM_XPATH = "/root/Page[@Name = 'index']/SetSession/Parameters/Param/text()" Dim dom Dim aParam Dim sItem 'Application.xmlに定義のある必要なキー名のみ取得 '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- Call LoadXML(sApplyXMLFileName, dom) aParam = GetNodeValues(dom, SEARCH_PARAM_XPATH) Set dom = Nothing 'パラメタをセッションへセット '--- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- For Each sItem In aParam Session.Contents(sItem) = dicParameter.Item(sItem) Next End Sub %>