<%
' ====================================================================
' スーパー実践くん4WebCollabo
'
' 共通関数群 for VBScript
' File Name : include_func.asp
' --Update Information------------------------------------------------
' Version : V0.01
' Developer <Date> : Takeshi Yamazaki <2002/08/09(Fri)>
' --------------------------------------------------------------------
' Version : V0.02
' Developer <Date> : Shinichirou Onuma <2005/07/11(Mon)>
' --------------------------------------------------------------------
' ====================================================================
%>
<%
' --------------------------------------------------------------------
' 00. デバッグ用表示
' --------------------------------------------------------------------
' 戻り値
' 引数
' :
' --------------------------------------------------------------------
Function DebugResponse(DebugName,DebugStr)
Response.Write("<FONT SIZE=""+1"" face=""ＭＳ ゴシック"">" & vbCrLf)
Response.Write(DebugName & " = " & DebugStr & vbCrLf)
Response.Write("</FONT>" & vbCrLf)
End Function
' --------------------------------------------------------------------
' 00. セッションの有効期限が切れていないかをチェックする
' --------------------------------------------------------------------
' 戻り値
' 負 : 不正・タイムアウト
' 正 : 正常セッション
' 引数
' :
' --------------------------------------------------------------------
Function SessionCheck()
Dim TmpHeader
TmpHeader = ""
TmpHeader = TmpHeader & "<html>" & vbCrLf
TmpHeader = TmpHeader & "<head>" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Content-Type"" content=""text/html; charset=shift_jis"">" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Pragma"" content=""no-cache"">" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Cache-Control"" content=""no-cache"">" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Expires"" content=""-1"">" & vbCrLf
TmpHeader = TmpHeader & "<title>" & AppTitle & "</title>" & vbCrLf
TmpHeader = TmpHeader & "</head>" & vbCrLf
TmpHeader = TmpHeader & "<SCRIPT LANGUAGE=""JavaScript"">" & vbCrLf
TmpHeader = TmpHeader & "</SCRIPT>" & vbCrLf
TmpHeader = TmpHeader & "<body bgcolor=""#DDDDDD"" leftmargin=""0"" topmargin=""0"" marginwidth=""0"" marginheight=""0"">" & vbCrLf
TmpHeader = TmpHeader & "<BR>" & vbCrLf
Dim TmpHeaderUser
TmpHeaderUser = ""
TmpHeaderUser = TmpHeaderUser & "<SCRIPT LANGUAGE=""JavaScript"">" & vbCrLf
TmpHeaderUser = TmpHeaderUser & "var bClose = 0;" & vbCrLf
TmpHeaderUser = TmpHeaderUser & "if (typeof(parent.document.all.tags(""frame"")[0]) != ""undefined"") {" & vbCrLf
TmpHeaderUser = TmpHeaderUser & " if (("""" + parent.document.all.tags(""frame"")[0].src).indexOf(""kityo"") >= 0 || ("""" + parent.document.all.tags(""frame"")[0].src).indexOf(""mail"") >= 0 || ("""" + parent.document.all.tags(""frame"")[0].src).indexOf(""syoukai"") >= 0 || ("""" + parent.document.all.tags(""frame"")[0].src).indexOf(""portal"") >= 0) {" & vbCrLf
TmpHeaderUser = TmpHeaderUser & " bClose = 1;" & vbCrLf
TmpHeaderUser = TmpHeaderUser & " }" & vbCrLf
TmpHeaderUser = TmpHeaderUser & "}" & vbCrLf
If Session(DBName & "Admin") = "" Then
Response.Write(TmpHeader)
Response.Write(" タイムアウトしたか、不正なページ表示です。<br>")
Response.Write(" ログインし直して下さい。<br><br>")
Response.Write(TmpHeaderUser)
Response.Write("if(bClose == 1)document.write("" <a href='#' onclick='top.close()'>閉じる</a>"")" & vbCrLf)
Response.Write("else document.write("" <a href='/" & HomeAlias & "/default.asp' target='_top'>ログインページ</a>"")" & vbCrLf)
Response.Write("</SCRIPT>" & vbCrLf)
Response.Write("</body>" & vbCrLf)
Response.Write("</html>" & vbCrLf)
SessionCheck = false
ElseIf Session(DBName & "Admin") = "0" Then 'マスター照会は社長室から利用するので運用管理判定から除外
If InStr(UCase(Request.ServerVariables("URL")), UCase("/" & HomeAlias & "/admin")) > 0 And InStr(UCase(Request.ServerVariables("URL")), UCase("/" & HomeAlias & "/admin/master")) = 0 And InStr(UCase(Request.ServerVariables("URL")), UCase("/" & HomeAlias & "/admin/enshu")) = 0 Then
Response.Write(TmpHeader)
Response.Write(" このPCによる運用管理者ログインが許可されていないか<br>")
Response.Write(" もしくは運用管理者セッションがタイムアウトしています。<br>")
Response.Write(" <br>")
Response.Write(" 運用管理者セッションがタイムアウトした場合は<br>")
Response.Write(" 一旦ウィンドウを閉じた後にアイコンから開き直してください。<br>")
Response.Write(" <br>")
If GB_IEmode = "1" Then 'Edgeではログオフ後に閉じるボタンが反応しない
Response.Write(" <a href="""" onclick=""ExitFlg=0;top.window.close();"">閉じる</a>")
End If
Response.Write("</body>" & vbCrLf)
Response.Write("</html>" & vbCrLf)
SessionCheck = false
Else
Dim Query
Dim Content
Dim KurikoshiFlg
KurikoshiFlg = 0
Query = "exec SPM会社取得 '" & GB_SystemCD & "', '" & GB_EnshuCD & "', '" & GB_KaisyaCD & "'"
Set Content = OpenQuery(Query)
Do While Not(Content.BOF Or Content.EOF)
If Content.Fields("会社CD") = GB_KaisyaCD Then
If "" & Content.Fields("次演習繰越フラグ") = "1" Then
KurikoshiFlg = 1
Exit Do
End If
End If
Content.MoveNext
Loop
If KurikoshiFlg = 1 And Session(HomeAlias & "AutoLoginButton") <> "1" Then '運用管理オートログインは除外
Query = "exec SPM演習取得 '" & GB_SystemCD & "', '" & GB_EnshuCD & "'"
Set Content = OpenQuery(Query)
If Not(Content.BOF Or Content.EOF) Then
Response.Write(TmpHeader)
Response.Write(" この会社は次期演習へ期末繰越処理されました。<br><br>")
Response.Write(TmpHeaderUser)
Response.Write("if(bClose == 1)document.write("" <a href='#' onclick='top.close()'>閉じる</a>"")" & vbCrLf)
Response.Write("else document.write("" <a href='/" & HomeAlias & "/user/default_bin.asp?AutoLogin=1&EnshuCD=" & Content.Fields("期末繰越先演習CD") & "&AutoLoginKaisyaCD=" & GB_KaisyaCD & "' target='_top'>次期演習へ移動する</a>"")" & vbCrLf)
Response.Write("</SCRIPT>" & vbCrLf)
Response.Write("</body>" & vbCrLf)
Response.Write("</html>" & vbCrLf)
SessionCheck = false
Else
Response.Write(TmpHeader)
Response.Write(" タイムアウトしたか、不正なページ表示です。<br>")
Response.Write(" ログインし直して下さい。<br><br>")
Response.Write(TmpHeaderUser)
Response.Write("if(bClose == 1)document.write("" <a href='#' onclick='top.close()'>閉じる</a>"")" & vbCrLf)
Response.Write("else document.write("" <a href='/" & HomeAlias & "/default.asp' target='_top'>ログインページ</a>"")" & vbCrLf)
Response.Write("</SCRIPT>" & vbCrLf)
Response.Write("</body>" & vbCrLf)
Response.Write("</html>" & vbCrLf)
SessionCheck = false
End If
Else
SessionCheck = True
End If
End If
Else
SessionCheck = True '運用管理は此処
End If
End Function
' --------------------------------------------------------------------
' 00. クエリ発行
' --------------------------------------------------------------------
' 戻り値
' 負 : エラー発生
' 正 : 項目の件数
' 引数
' F_Query : クエリ文
' --------------------------------------------------------------------
Function OpenQuery(F_Query)
Set db = Server.CreateObject("ADODB.Connection")
db.ConnectionTimeout = 60
db.CommandTimeout = 60
db.Open SQLConn
Set OpenQuery = ExecQuery(db, F_Query)
End Function
Sub CloseQuery()
db.close
Set db = Nothing
Set Content = Nothing
End Sub
Function OpenQuery2(q)
Set OpenQuery2 = OpenQuery(q)
End Function
Function InitQuery()
Dim db1
Set db1 = Server.CreateObject("ADODB.Connection")
db1.Open SQLConn
Set InitQuery = db1
End Function
Function ExecQuery(db1, F_Query)
'データベースエラー表示機能追加（090609小野）
On Error Resume Next
Err.Clear()
Set Content = db1.Execute(F_Query)
If Err.Description <> "" Then
Response.Write("<B>データベースへの接続でエラーが発生しました</B><BR><BR><BR>")
Response.Write("メッセージ ： <B>" & Err.Description & "</B><BR><BR>")
Response.Write("送信クエリ ： <B>" & F_Query & "</B><BR><BR><BR>")
Exit Function
End If
On Error Goto 0
Do While Not Content Is Nothing
If Content.Fields.Count > 0 Then
Exit Do
End If
'データベースエラー表示機能追加（100526小野）
On Error Resume Next
Err.Clear()
Set Content = Content.NextRecordSet()
If Err.Description <> "" Then
Response.Write("<B>データベースへの接続でエラーが発生しました</B><BR><BR><BR>")
Response.Write("メッセージ ： <B>" & Err.Description & "</B><BR><BR>")
Response.Write("送信クエリ ： <B>" & F_Query & "</B><BR><BR><BR>")
Exit Function
End If
On Error Goto 0
' Set Content = Content.NextRecordSet()
Loop
Set ExecQuery= Content
End Function
Function DebugQuery(F_Query)
If Request.ServerVariables("SERVER_NAME") = "Eagle-Dev" Then
Response.Write(F_Query)
Response.Write("<br>" & vbCrLf)
End If
End Function
' --------------------------------------------------------------------
' 00. クエリ発行(Webcolabo)
' --------------------------------------------------------------------
' 戻り値
' 負 : エラー発生
' 正 : 項目の件数
' 引数
' F_Query : クエリ文
' --------------------------------------------------------------------
Function OpenQuery3(F_Query)
Set db = Server.CreateObject("ADODB.Connection")
db.ConnectionTimeout = 60
db.CommandTimeout = 60
db.Open TvConn
Set OpenQuery3 = ExecQuery3(db, F_Query)
End Function
Sub CloseQuery3()
db.close
Set db = Nothing
Set Content = Nothing
End Sub
Function InitQuery3()
Dim db1
Set db1 = Server.CreateObject("ADODB.Connection")
db1.Open TvConn
Set InitQuery3 = db1
End Function
Function ExecQuery3(db1, F_Query)
Set Content = db1.Execute(F_Query)
Do While Not Content Is Nothing
If Content.Fields.Count > 0 Then
Exit Do
End If
Set Content = Content.NextRecordSet()
Loop
Set ExecQuery3= Content
End Function
Function DebugQuery3(F_Query)
If Request.ServerVariables("SERVER_NAME") = "Eagle-Dev" Then
Response.Write(F_Query)
Response.Write("<br>" & vbCrLf)
End If
End Function
' --------------------------------------------------------------------
' 00. フラグからフラグ名称に変換
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 : フラグ名称
' 引数
' F_Flag :
' F_Type :
' --------------------------------------------------------------------
Function ConvFlagMeisyo(F_Flag, F_Type)
If F_Flag = 1 Or F_Flag = "1" Then
If F_Type = 1 Then
ConvFlagMeisyo = "○"
ElseIf F_Type = 2 Then
ConvFlagMeisyo = "済"
ElseIf F_Type = 3 Then
ConvFlagMeisyo = ""
ElseIf F_Type = 4 Then
ConvFlagMeisyo = "×"
ElseIf F_Type = 5 Then
ConvFlagMeisyo = "済"
ElseIf F_Type = 6 Then
ConvFlagMeisyo = "済"
End If
Else
If F_Type = 1 Then
ConvFlagMeisyo = "×"
ElseIf F_Type = 2 Then
ConvFlagMeisyo = "未"
ElseIf F_Type = 3 Then
ConvFlagMeisyo = "×"
ElseIf F_Type = 4 Then
ConvFlagMeisyo = ""
ElseIf F_Type = 5 Then
ConvFlagMeisyo = "<font color=""#FF1010"">未発信</font>"
ElseIf F_Type = 6 Then
ConvFlagMeisyo = "未発信"
End If
End If
End Function
' --------------------------------------------------------------------
' 00. 日付の文字列を解析・指定書式に変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' F_Target :
' F_DispType 1:YYYY/MM/DD
' 2:YYYY年MM月DD日
' 3:HYY年MM月DD日
' --------------------------------------------------------------------
Function SetDate(F_Target, F_DispType)
Dim DateStr '日付文字列
Dim CheckFlg '
Dim Nen '年
Dim Tsuki '月
Dim Hi '日
Dim TargetDate
Dim ParseDate
Dim TargetDate2
Dim Nen2 '年
Dim Tsuki2 '月
Dim Hi2 '日
Dim Query
Dim Content
Dim GengoNameAry
Dim GengoDateAry
ReDim GengoNameAry(0)
ReDim GengoDateAry(0)
DateStr = ReplaceSpace(F_Target)
If DateStr <> "" Then
'元号配列作成（171031小野）
Query = " SELECT * FROM TC9元号M WHERE システムCD = '" & GB_SystemCD & "' ORDER BY 開始日 DESC "
Set Content = OpenQuery(Query)
Do While Not(Content.BOF Or Content.EOF)
If "" & Content.Fields("元号") <> "" And "" & Content.Fields("開始日") <> "" Then
ReDim PreServe GengoNameAry(UBound(GengoNameAry) + 1) '配列+1
ReDim PreServe GengoDateAry(UBound(GengoDateAry) + 1) '配列+1
GengoNameAry(UBound(GengoNameAry)) = "" & Content.Fields("元号")
GengoDateAry(UBound(GengoDateAry)) = Content.Fields("開始日") 'Dateオブジェクト型
End If
Content.MoveNext
Loop
CheckFlg = true
DateStr = Replace(DateStr, "年", "/")
DateStr = Replace(DateStr, "月", "/")
DateStr = Replace(DateStr, "日", "")
ParseDate = Split(DateStr, "/")
Nen = ParseDate(0)
Tsuki = ParseDate(1)
Hi = ParseDate(2)
'DateStrに元号が含まれる場合の変換処理（通常は利用されない）
If InStr(Nen, "平成") > 0 Then
Nen = Int(Replace(Nen, "平成", ""))
Nen = Nen + 1988
ElseIf InStr(Nen, "昭和") > 0 Then
Nen = Int(Replace(Nen, "昭和", ""))
Nen = Nen + 1925
ElseIf InStr(Nen, "大正") > 0 Then
Nen = Int(Replace(Nen, "大正", ""))
Nen = Nen + 1911
ElseIf InStr(Nen, "明治") > 0 Then
Nen = Int(Replace(Nen, "明治", ""))
Nen = Nen + 1867
End If
'DateStrに元号が含まれる場合の変換処理（通常は利用されない）
Nen = Int(Nen)
Tsuki = Int(Tsuki)
Hi = Int(Hi)
TargetDate = DateSerial(Nen, Tsuki, Hi)
TargetDate2 = DateSerial(Nen, Tsuki, Hi + 1)
Nen2 = Year(TargetDate2)
Tsuki2 = Month(TargetDate2)
Hi2 = Day(TargetDate2)
If Not(IsNumeric(Nen)) Then CheckFlg = false End If
If Not(IsNumeric(Tsuki)) Then CheckFlg = false End If
If Not(IsNumeric(Hi)) Then CheckFlg = false End If
If Nen < 1900 Or 2100 < Nen Then CheckFlg = false End If
If Tsuki < 1 Or 12 < Tsuki Then CheckFlg = false End If
If Hi < 1 Or 31 < Hi Then CheckFlg = false End If
If CheckFlg = false Then
Exit Function
End If
If F_DispType < 8 Then
If Len(Tsuki) = 1 Then
Tsuki = "0" & CStr(Tsuki)
End If
If Len(Hi) = 1 Then
Hi = "0" & CStr(Hi)
End If
End If
If F_DispType = 1 Then
SetDate = Nen & "/" & Tsuki & "/" & Hi
ElseIf F_DispType = 2 Then
SetDate = Nen & "年" & Tsuki & "月" & Hi & "日"
ElseIf F_DispType = 3 Then
'元号配列から和暦に変換（171031小野）
Dim Cnt
For Cnt = 1 To UBound(GengoDateAry)
If TargetDate >= GengoDateAry(Cnt) Then
Nen = Nen - (Year(GengoDateAry(Cnt)) - 1)
Nen = GengoNameAry(Cnt) & CStr(Nen)
Exit For
End If
Next
SetDate = Nen & "年" & Tsuki & "月" & Hi & "日"
ElseIf F_DispType = 8 Then '期末日
If Tsuki2 <> "1" Or Hi2 <> "1" Then
SetDate = "翌年"
End If
SetDate = SetDate & Tsuki & "月" & Hi & "日"
ElseIf F_DispType = 9 Then '期首日
SetDate = Tsuki2 & "月" & Hi2 & "日"
End If
End If
End Function
'西暦年月日から元号のみを取得
Function SetGengo(F_Target)
Dim DateStr '日付文字列
Dim CheckFlg '
Dim Nen '年
Dim Tsuki '月
Dim Hi '日
Dim TargetDate
Dim ParseDate
Dim TargetDate2
Dim Nen2 '年
Dim Tsuki2 '月
Dim Hi2 '日
Dim Query
Dim Content
DateStr = ReplaceSpace(F_Target)
If DateStr <> "" Then
CheckFlg = true
DateStr = Replace(DateStr, "年", "/")
DateStr = Replace(DateStr, "月", "/")
DateStr = Replace(DateStr, "日", "")
ParseDate = Split(DateStr, "/")
Nen = ParseDate(0)
Tsuki = ParseDate(1)
Hi = ParseDate(2)
'DateStrに元号が含まれる場合の変換処理（通常は利用されない）
If InStr(Nen, "平成") > 0 Then
Nen = Int(Replace(Nen, "平成", ""))
Nen = Nen + 1988
ElseIf InStr(Nen, "昭和") > 0 Then
Nen = Int(Replace(Nen, "昭和", ""))
Nen = Nen + 1925
ElseIf InStr(Nen, "大正") > 0 Then
Nen = Int(Replace(Nen, "大正", ""))
Nen = Nen + 1911
ElseIf InStr(Nen, "明治") > 0 Then
Nen = Int(Replace(Nen, "明治", ""))
Nen = Nen + 1867
End If
'DateStrに元号が含まれる場合の変換処理（通常は利用されない）
Nen = Int(Nen)
Tsuki = Int(Tsuki)
Hi = Int(Hi)
If Not(IsNumeric(Nen)) Then CheckFlg = false End If
If Not(IsNumeric(Tsuki)) Then CheckFlg = false End If
If Not(IsNumeric(Hi)) Then CheckFlg = false End If
If Nen < 1900 Or 2100 < Nen Then CheckFlg = false End If
If Tsuki < 1 Or 12 < Tsuki Then CheckFlg = false End If
If Hi < 1 Or 31 < Hi Then CheckFlg = false End If
If CheckFlg = false Then
Exit Function
End If
TargetDate = DateSerial(Nen, Tsuki, Hi)
Query = " SELECT * FROM TC9元号M WHERE システムCD = '" & GB_SystemCD & "' ORDER BY 開始日 DESC "
Set Content = OpenQuery(Query)
Do While Not(Content.BOF Or Content.EOF)
If "" & Content.Fields("元号") <> "" And "" & Content.Fields("開始日") <> "" Then
If TargetDate >= Content.Fields("開始日") Then
SetGengo = "" & Content.Fields("元号")
Exit Do
End If
End If
Content.MoveNext
Loop
End If
End Function
'元号から西暦年のみを取得
Function SetYearGengo(F_Target)
Dim Query
Dim Content
If F_Target <> "" Then
Query = " SELECT * FROM TC9元号M WHERE システムCD = '" & GB_SystemCD & "' AND 元号 = '" & F_Target & "' "
Set Content = OpenQuery(Query)
If Not(Content.BOF Or Content.EOF) Then
If "" & Content.Fields("開始日") <> "" Then
SetYearGengo = Year(Content.Fields("開始日"))
End If
End If
End If
End Function
' --------------------------------------------------------------------
' 00. 日付をYY/MM/DD HH:MMに変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 : YYYY/MM/DD HH:MM
' 引数
' F_DateTime :日付
' --------------------------------------------------------------------
Function SetTimeYYMMDDHHMM(F_DateTime)
Dim y1
Dim m1
Dim d1
Dim h1
Dim m2
y1 = CStr(Year (F_DateTime))
m1 = CStr(Month (F_DateTime))
d1 = CStr(Day (F_DateTime))
h1 = CStr(Hour (F_DateTime))
m2 = CStr(Minute(F_DateTime))
If Len(m1) = 1 Then m1 = "0" & m1 End If
If Len(d1) = 1 Then d1 = "0" & d1 End If
If Len(h1) = 1 Then h1 = "0" & h1 End If
If Len(m2) = 1 Then m2 = "0" & m2 End If
SetTimeYYMMDDHHMM = y1 & "/" & m1 & "/" & d1 & " " & h1 & ":" & m2
End Function
' --------------------------------------------------------------------
' 00. 日付をYYMMDDHHMMに変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 : YYYYMMDDHHMM
' 引数
' F_DateTime :日付
' --------------------------------------------------------------------
Function SetTimeYYMMDDHHMM2(F_DateTime)
Dim y1
Dim m1
Dim d1
Dim h1
Dim m2
y1 = CStr(Year (F_DateTime))
m1 = CStr(Month (F_DateTime))
d1 = CStr(Day (F_DateTime))
h1 = CStr(Hour (F_DateTime))
m2 = CStr(Minute(F_DateTime))
If Len(m1) = 1 Then m1 = "0" & m1 End If
If Len(d1) = 1 Then d1 = "0" & d1 End If
If Len(h1) = 1 Then h1 = "0" & h1 End If
If Len(m2) = 1 Then m2 = "0" & m2 End If
SetTimeYYMMDDHHMM2 = y1 & m1 & d1 & h1 & m2
End Function
' --------------------------------------------------------------------
' 00. 日付をMMDD変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 : MMDD
' 引数
' F_DateTime :日付
' --------------------------------------------------------------------
Function SetTimeMMDD(F_DateTime)
Dim y1
Dim m1
Dim d1
Dim h1
Dim m2
If IsNull(F_DateTime) Then
Exit Function
End If
If F_DateTime = "" Then
Exit Function
End If
y1 = CStr(Year (F_DateTime))
m1 = CStr(Month (F_DateTime))
d1 = CStr(Day (F_DateTime))
h1 = CStr(Hour (F_DateTime))
m2 = CStr(Minute(F_DateTime))
If Len(m1) = 1 Then m1 = "0" & m1 End If
If Len(d1) = 1 Then d1 = "0" & d1 End If
If Len(h1) = 1 Then h1 = "0" & h1 End If
If Len(m2) = 1 Then m2 = "0" & m2 End If
SetTimeMMDD = m1 & "/" & d1
End Function
' --------------------------------------------------------------------
' 00. 日付をYYYY年MM月DD日HH時MM分に変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 : YYYY年MM月DD日HH時MM分
' 引数
' F_DateStr :日付
' --------------------------------------------------------------------
Function SetTimeYYMMDDHHMM2Rev(F_DateStr)
SetTimeYYMMDDHHMM2Rev = Left(F_DateStr, 4) & "年" & Mid(F_DateStr, 5, 2) & "月" & Mid(F_DateStr, 7, 2) & "日" & Mid(F_DateStr, 9, 2) & "時" & Mid(F_DateStr, 11, 2) & "分"
End Function
' --------------------------------------------------------------------
' 00. 日付をYYYY/MM/DDに変換
' --------------------------------------------------------------------
' 日付が「MM/DD/YYYY」で出力されてしまう場合の対処のため（システム設定に依存するようだが再現せずはっきりとした原因は不明）（140425小野）
' 引数
' F_DateTime :日付（Dateオブジェクト）
' --------------------------------------------------------------------
Function SetTimeYYYYMMDD(F_DateTime)
If "" & F_DateTime <> "" Then
SetTimeYYYYMMDD = Year(F_DateTime) & "/" & Right("0" & Month(F_DateTime), 2) & "/" & Right("0" & Day(F_DateTime), 2)
'SetTimeYYYYMMDD = Year(F_DateTime) & "/" & Right("" & Month(F_DateTime), 2) & "/" & Right("" & Day(F_DateTime), 2)
End If
End Function
' --------------------------------------------------------------------
' 00. 日付を指定の形式に変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' obj :式
' dtype :
' --------------------------------------------------------------------
Function SetDateStr(obj, dtype)
Dim Year1
Dim Year2
Dim Month1
Dim Day1
Dim Hour1
Dim Minute1
Dim Second1
'式を日付に変換できるかどうか判定
If Not(IsDate(obj)) Then
Exit Function
End If
Year1 = Year(obj)
Year2 = Year1 - 2000
Month1 = Month(obj)
Day1 = Day(obj)
Hour1 = Hour(obj)
Minute1 = Minute(obj)
Second1 = Second(obj)
'取得した値が1桁ならば0を付加
If Year2 < 10 Then Year2 = "0" & Year2 End If
If Month1 < 10 Then Month1 = "0" & Month1 End If
If Day1 < 10 Then Day1 = "0" & Day1 End If
If Hour1 < 10 Then Hour1 = "0" & Hour1 End If
If Minute1 < 10 Then Minute1 = "0" & Minute1 End If
If Second1 < 10 Then Second1 = "0" & Second1 End If
'引数dtypeを置換
dtype = Replace(dtype, "YYYY", Year1)
dtype = Replace(dtype, "YY", Year2)
dtype = Replace(dtype, "MM", Month1)
dtype = Replace(dtype, "DD", Day1)
dtype = Replace(dtype, "hh", Hour1)
dtype = Replace(dtype, "mm", Minute1)
dtype = Replace(dtype, "ss", Second1)
SetDateStr = dtype
End Function
Function GetYYYYMMDD()
Dim TmpYMD
TmpYMD = Now()
GetYYYYMMDD = Year(TmpYMD)
GetYYYYMMDD = GetYYYYMMDD & "/" & Right("0" & Month(TmpYMD), 2)
GetYYYYMMDD = GetYYYYMMDD & "/" & Right("0" & Day(TmpYMD), 2)
End Function
' --------------------------------------------------------------------
' 00. 金額の文字列を解析・指定書式に変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' F_Target :
' F_Yenmark :
' F_Zeronull :
' --------------------------------------------------------------------
Function SetMoney(F_Target, F_Yenmark, F_Zeronull)
SetMoney = ConvIntToMoney(ConvMoneyToInt(F_Target), F_Yenmark, F_Zeronull)
End Function
' --------------------------------------------------------------------
' 00. 金額の文字列を解析・通貨型に変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 : 通貨型
' 引数
' F_Target :解析対象文字列
' 修正履歴
'2002/8/9:Yamazaki :CLng を CCur に修正
'2002/9/6:Yamazaki :F_Target が Nullにも対応するように修正
' --------------------------------------------------------------------
Function ConvMoneyToInt(F_Target)
Dim Target
Target = ""
If Not(IsNull(F_Target)) Then
'文字列から","を取り除く
Target = Replace(F_Target,",","")
'文字列から"\"を取り除く
Target = Replace(Target,"\","")
If Target <> "" Then
'文字型から通貨型に変換
Target = CCur(Target)
End If
End If
ConvMoneyToInt = Target
End Function
' --------------------------------------------------------------------
' 00. 金額の文字列を解析・整数の書式に変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' F_Target :
' F_Yenmark :
' F_Zeronull :
' 修正履歴
'2002/08/09:Yamazaki :-100 が -,100 と出るのを修正
'2002/08/27:Yamazaki :F_Target が Nullにも対応するように修正
' --------------------------------------------------------------------
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
' --------------------------------------------------------------------
' 00. 整数の文字列を解析・金額の書式に変換（負は△表示）
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' F_Target :
' F_Yenmark :
' F_Zeronull :
' 修正履歴
'2002/08/09:Yamazaki :-100 が -,100 と出るのを修正
'2002/08/27:Yamazaki :F_Target が Nullにも対応するように修正
'2007/01/26:小野 :△表示用にクローン
' --------------------------------------------------------------------
Function ConvIntToMoneySankaku(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
If Left(return1, 1) = "-" Then
return1 = "△" + Mid(return1, 2, Len(return1)-1)
End If
ConvIntToMoneySankaku = return1
End Function
' --------------------------------------------------------------------
' 00. 数字の入力文字列を解析・指定の書式に変換
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' F_Target :
' F_Zeronull :
' --------------------------------------------------------------------
Function SetNumber(F_Target, F_Zeronull)
SetNumber = NumComma(ConvMoneyToInt(F_Target), F_Zeronull)
End Function
' --------------------------------------------------------------------
' 00. 整数に区切り文字をセット
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' F_Target :
' F_Zeronull :
' --------------------------------------------------------------------
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
' --------------------------------------------------------------------
' 00. 引数の文字列内のスペースを削除
' --------------------------------------------------------------------
' 戻り値
' 負 : 変換不能
' 正 :
' 引数
' F_Target :
' --------------------------------------------------------------------
Function ReplaceSpace(F_Target)
Dim Target
If Not(IsNull(F_Target)) Then
Target = F_Target
'半角スペース変換
Target = Replace(Target," ","")
'全角スペース変換
Target = Replace(Target," ","")
End If
ReplaceSpace = Target
End Function
' --------------------------------------------------------------------
' 00. 勘定科目名称へ１文字おきに全角スペースを挿入
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' F_Target :
' 備考
' 勘定科目は5文字
' --------------------------------------------------------------------
Function SetStringFixWidth(F_Target)
Dim ii
Dim jj
Dim aa
Dim bb
If Not(IsNull(F_Target)) Then
'文字列から既存のスペースを削除
F_Target = Replace(F_Target, " ", "")
F_Target = Replace(F_Target, " ", "")
aa = 5
For ii = 1 To Len(F_Target)
SetStringFixWidth = SetStringFixWidth + Mid(F_Target, ii, 1)
If ii <> Len(F_Target) Then
For jj = 1 To CInt((aa - Len(F_Target)) / (Len(F_Target) - 1))
SetStringFixWidth = SetStringFixWidth + " "
Next
End If
Next
End If
End Function
' --------------------------------------------------------------------
' 00. 文字列へ１文字おきに全角スペースを挿入
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' F_Target :
' 備考
' 勘定科目は5文字
' --------------------------------------------------------------------
Function SetStringInsertSpace(F_Target)
Dim ii
For ii = 1 To Len(F_Target)
SetStringInsertSpace = SetStringInsertSpace + Mid(F_Target, ii, 1)
If ii <> Len(F_Target) Then
SetStringInsertSpace = SetStringInsertSpace + " "
End If
Next
End Function
' --------------------------------------------------------------------
' 00. 文字列へ１文字おきに半角スペースを挿入
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' F_Target :
' 備考
' 勘定科目は5文字
' --------------------------------------------------------------------
Function SetStringInsertSpaceH(F_Target)
Dim ii
For ii = 1 To Len(F_Target)
SetStringInsertSpaceH = SetStringInsertSpaceH + Mid(F_Target, ii, 1)
If ii <> Len(F_Target) Then
SetStringInsertSpaceH = SetStringInsertSpaceH + " "
End If
Next
End Function
' --------------------------------------------------------------------
' 00. 文字列の頭に0を挿入
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' F_Target :
' --------------------------------------------------------------------
Function SetStringZeroFil(F_Target,F_Len)
Dim StrLen
Dim StrTarget
Dim ii
StrTarget = CStr(F_Target)
StrLen = F_Len - LEN(StrTarget)
For ii = 1 TO StrLen
StrTarget = "0" & StrTarget
Next
SetStringZeroFil = StrTarget
End Function
' --------------------------------------------------------------------
' 00. 大小判定
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' a :比較値A
' b :比較値B
' --------------------------------------------------------------------
Function Max(a, b)
If a > b Then
Max = a
Else
Max = b
End If
End Function
' --------------------------------------------------------------------
' 00. basp21を使用してコマンドを実行する
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' cmd : 実行コマンド文
' --------------------------------------------------------------------
Function ExecCmd(cmd)
Dim bobj
Dim command
Dim stdout
Dim rc
Set bobj = Server.CreateObject("basp21")
Response.Write(cmd)
rc = bobj.Execute(cmd,1,stdout)
Response.Write("<br>")
Response.Write("<br>")
Response.Write(rc)
Response.Write("<br>")
Response.Write(Replace(stdout, vbCrLf, "<br>" & vbCrLf))
Set bobj = Nothing
End Function
' --------------------------------------------------------------------
' 00. 文字列のByte数を取得（061027小野）
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' cmd : 実行コマンド文
' --------------------------------------------------------------------
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
' --------------------------------------------------------------------
' 00. 文字列を左から指定Byte数で切り出し(2Byte文字端数は切り捨て)（061031小野）
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' cmd : 実行コマンド文
' --------------------------------------------------------------------
Function AscLeft(p_Str,p_Len)
Dim i
Dim iAscCode
Dim iCount
If Len(p_Str) = 0 Then '文字数が0の場合
AscLeft = ""
Exit Function
End If
If IsNull(Len(p_Str)) Then '文字列がNullの場合
AscLeft = ""
Exit Function
End If
If p_Len = 0 Then '指定Byte数が0の場合
AscLeft = ""
Exit Function
End If
If p_Len >= AscLen(p_Str) Then '文字列が指定Byte数に満たない場合は何もしない
AscLeft = p_Str
Exit Function
End If
AscLeft = "" '文字列初期化
i = 0 '文字数初期化
iCount = 0 'Byte数初期化
Do While iCount < p_Len '指定Byte数までループ
i = i + 1 '1文字シフト
iCount = iCount + 1 '1Byteシフト
iAscCode = Asc(Mid(p_Str, i, 1)) 'Asc関数で文字コード取得
If Len(Hex(iAscCode)) > 2 Then '16進3桁以上なら全角文字と判定
iCount = iCount + 1 '全角文字の場合はByteカウントアップ
if iCount > p_Len Then '全角文字により指定Byte数を
Exit Do ' 超えた場合はここでDoループアウト
End If
End If
AscLeft = AscLeft + Mid(p_Str, i, 1) '1文字追加
Loop
End Function
' --------------------------------------------------------------------
' 00. 西暦0年から経過した時間を1万分の1秒単位で(大まかに)算出する（061107小野）
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' cmd : 実行コマンド文
' --------------------------------------------------------------------
Function TimeUniq()
'セッションを利用し初回のみ取得する
' If "" & Session(HomeAlias & "TimeUniq") = "" Then '更新されないとデバッグにならんので廃止
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
Session(HomeAlias & "TimeUniq") = "TimeUniq=" & ((((Year(TmpNow) - 1) * 365.25 + mtmp + (Day(TmpNow) - 1)) * 24 * 60 * 60 + Timer()) * 10000)
' End If
TimeUniq = Session(HomeAlias & "TimeUniq")
End Function
' --------------------------------------------------------------------
' 00. ウェイト挿入自動ジャンプ（070911小野）
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' cmd : 実行コマンド文
' --------------------------------------------------------------------
Function WaitRedirect(URLStr,WaitTime)
Response.Write("<html>" & vbCrLf)
Response.Write("<head>" & vbCrLf)
Response.Write("<meta http-equiv=""Content-Type"" content=""text/html; charset=shift_jis"">" & vbCrLf)
Response.Write("<meta http-equiv=""Pragma"" content=""no-cache"">" & vbCrLf)
Response.Write("<meta http-equiv=""Cache-Control"" content=""no-cache"">" & vbCrLf)
Response.Write("<meta http-equiv=""Expires"" content=""-1"">" & vbCrLf)
Response.Write("<title>" & AppTitle & "</title>" & vbCrLf)
Response.Write("</head>" & vbCrLf)
Response.Write("<SCRIPT LANGUAGE=""JavaScript"">" & vbCrLf)
Response.Write("<!--" & vbCrLf)
Response.Write("function WaitRedirect() {" & vbCrLf)
Response.Write(" location.href = """ & URLStr & """;" & vbCrLf)
Response.Write("}" & vbCrLf)
Response.Write("setTimeout(""WaitRedirect()""," & WaitTime & ");" & vbCrLf)
Response.Write("// -->" & vbCrLf)
Response.Write("</SCRIPT>" & vbCrLf)
Response.Write("</head>" & vbCrLf)
Response.Write("<body bgcolor=""#CED4E9"" leftmargin=""0"" topmargin=""0"" marginwidth=""0"" marginheight=""0"">" & vbCrLf)
Response.Write("<BR>" & vbCrLf)
Response.Write(" <FONT COLOR=""#000000"">ただいま処理中です。しばらくお待ちください。</FONT>")
Response.Write("</body>" & vbCrLf)
Response.Write("</html>" & vbCrLf)
End Function
' --------------------------------------------------------------------
' 00. CODE39バーコードを表示する（071204小野）
' --------------------------------------------------------------------
' 戻り値
' 負 :
' 正 :
' 引数
' cmd : 実行コマンド文
' --------------------------------------------------------------------
Function BarcodeWriteCODE39(Barcode, Label)
Barcode = UCase(Barcode)
If Label = "" Then
Label = Barcode
End If
Dim TmpStr
TmpStr = ""
'パラメータチェック
Dim TmpBarcode
TmpBarcode = Replace(Barcode, "0","")
TmpBarcode = Replace(TmpBarcode, "1","")
TmpBarcode = Replace(TmpBarcode, "2","")
TmpBarcode = Replace(TmpBarcode, "3","")
TmpBarcode = Replace(TmpBarcode, "4","")
TmpBarcode = Replace(TmpBarcode, "5","")
TmpBarcode = Replace(TmpBarcode, "6","")
TmpBarcode = Replace(TmpBarcode, "7","")
TmpBarcode = Replace(TmpBarcode, "8","")
TmpBarcode = Replace(TmpBarcode, "9","")
TmpBarcode = Replace(TmpBarcode, "A","")
TmpBarcode = Replace(TmpBarcode, "B","")
TmpBarcode = Replace(TmpBarcode, "C","")
TmpBarcode = Replace(TmpBarcode, "D","")
TmpBarcode = Replace(TmpBarcode, "E","")
TmpBarcode = Replace(TmpBarcode, "F","")
TmpBarcode = Replace(TmpBarcode, "G","")
TmpBarcode = Replace(TmpBarcode, "H","")
TmpBarcode = Replace(TmpBarcode, "I","")
TmpBarcode = Replace(TmpBarcode, "J","")
TmpBarcode = Replace(TmpBarcode, "K","")
TmpBarcode = Replace(TmpBarcode, "L","")
TmpBarcode = Replace(TmpBarcode, "M","")
TmpBarcode = Replace(TmpBarcode, "N","")
TmpBarcode = Replace(TmpBarcode, "O","")
TmpBarcode = Replace(TmpBarcode, "P","")
TmpBarcode = Replace(TmpBarcode, "Q","")
TmpBarcode = Replace(TmpBarcode, "R","")
TmpBarcode = Replace(TmpBarcode, "S","")
TmpBarcode = Replace(TmpBarcode, "T","")
TmpBarcode = Replace(TmpBarcode, "U","")
TmpBarcode = Replace(TmpBarcode, "V","")
TmpBarcode = Replace(TmpBarcode, "W","")
TmpBarcode = Replace(TmpBarcode, "X","")
TmpBarcode = Replace(TmpBarcode, "Y","")
TmpBarcode = Replace(TmpBarcode, "Z","")
TmpBarcode = Replace(TmpBarcode, "-","")
TmpBarcode = Replace(TmpBarcode, ".","")
TmpBarcode = Replace(TmpBarcode, " ","")
TmpBarcode = Replace(TmpBarcode, "$","")
TmpBarcode = Replace(TmpBarcode, "/","")
TmpBarcode = Replace(TmpBarcode, "+","")
TmpBarcode = Replace(TmpBarcode, "%","")
'不正文字が存在しなければ処理開始
If TmpBarcode = "" Then
'スタート・ストップキャラクタ追加
Barcode = "*" & Barcode & "*"
'CODE39パターン配列（連想配列）
Dim Code39
Set Code39 = Server.CreateObject("Scripting.Dictionary")
Code39("0") = "00110,0100"
Code39("1") = "10001,0100"
Code39("2") = "01001,0100"
Code39("3") = "11000,0100"
Code39("4") = "00101,0100"
Code39("5") = "10100,0100"
Code39("6") = "01100,0100"
Code39("7") = "00011,0100"
Code39("8") = "10010,0100"
Code39("9") = "01010,0100"
Code39("A") = "10001,0010"
Code39("B") = "01001,0010"
Code39("C") = "11000,0010"
Code39("D") = "00101,0010"
Code39("E") = "10100,0010"
Code39("F") = "01100,0010"
Code39("G") = "00011,0010"
Code39("H") = "10010,0010"
Code39("I") = "01010,0010"
Code39("J") = "00110,0010"
Code39("K") = "10001,0001"
Code39("L") = "01001,0001"
Code39("M") = "11000,0001"
Code39("N") = "00101,0001"
Code39("O") = "10100,0001"
Code39("P") = "01100,0001"
Code39("Q") = "00011,0001"
Code39("R") = "10010,0001"
Code39("S") = "01010,0001"
Code39("T") = "00110,0001"
Code39("U") = "10001,1000"
Code39("V") = "01001,1000"
Code39("W") = "11000,1000"
Code39("X") = "00101,1000"
Code39("Y") = "10100,1000"
Code39("Z") = "01100,1000"
Code39("-") = "00011,1000"
Code39(".") = "10010,1000"
Code39(" ") = "01010,1000"
Code39("$") = "00000,1110"
Code39("/") = "00000,1101"
Code39("+") = "00000,1011"
Code39("%") = "00000,0111"
Code39("*") = "00110,1000"
Dim Column
Dim Column2
Dim BW
'テーブル開始
' TmpStr = TmpStr & "<TABLE border='0' cellpadding='0' cellspacing='0'><TR><TD>"
'クワイエットゾーン(12)
For Column = 1 To 12
TmpStr = TmpStr & "<img border='0' src='/" & HomeAlias & "/images/barcode_w1.bmp?" & GB_STU & "'>"
Next
'キャラクタ
For Column = 1 To Len(Barcode)
'キャラクタ間ギャップ
If Column > 1 Then
TmpStr = TmpStr & "<img border='0' src='/" & HomeAlias & "/images/barcode_w1.bmp?" & GB_STU & "'>"
End If
'連想配列からカンマ区切りで白黒配列に代入
BW = Split(Code39(Mid(Barcode, Column, 1)), ",")
'バー出力
For Column2 = 1 To 5
'黒バー（5本）
TmpStr = TmpStr & "<img border='0' src='/" & HomeAlias & "/images/barcode_B" & CInt(Mid(BW(0), Column2, 1)) + 1 & ".bmp?" & GB_STU & "'>"
If Column2 < 5 Then
'白バー（4本）
TmpStr = TmpStr & "<img border='0' src='/" & HomeAlias & "/images/barcode_W" & CInt(Mid(BW(1), Column2, 1)) + 1 & ".bmp?" & GB_STU & "'>"
End If
Next
Next
'クワイエットゾーン(12)
For Column = 1 To 12
TmpStr = TmpStr & "<img border='0' src='/" & HomeAlias & "/images/barcode_w1.bmp?" & GB_STU & "'>"
Next
'テーブル終了＆コード表記
' TmpStr = TmpStr & "</TD></TR><TR><TD align='center'><TABLE border='0' cellpadding='0' cellspacing='0'><TR><TD><span style='font-size:13px; line-height:14px;'>" & Label & "</span></TD></TR></TABLE></TD></TR></TABLE>" & vbCrLf
' TmpStr = TmpStr & "</TD><TD valign='middle' class='tx1214'><NOBR>" & Label & "</NOBR></TD></TR></TABLE>" & vbCrLf
End If
BarcodeWriteCODE39 = TmpStr
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
'クエリ文字の日本語はプロキシによって送信出来ないケースがあるので
'submit()コマンドでヒストリバックさせるHTML構文を書き出す
Function SubmitHystoryBack(Url)
Dim UrlQueryString
Dim UrlQueryStrAry
Dim TmpCnt
Dim TmpQuery
Dim TmpHTML
TmpHTML = ""
If InStr(Url, "?") > 0 Then
TmpHTML = TmpHTML & "<html>" & vbCrLf
TmpHTML = TmpHTML & "<head>" & vbCrLf
TmpHTML = TmpHTML & "<meta http-equiv=""Content-Type"" content=""text/html; charset=shift_jis"">" & vbCrLf
TmpHTML = TmpHTML & "<meta http-equiv=""Pragma"" content=""no-cache"">" & vbCrLf
TmpHTML = TmpHTML & "<meta http-equiv=""Cache-Control"" content=""no-cache"">" & vbCrLf
TmpHTML = TmpHTML & "<meta http-equiv=""Expires"" content=""-1"">" & vbCrLf
TmpHTML = TmpHTML & "<link href=""/" & HomeAlias & "/binx/sj3web.css?" & TimeUniq() & """ rel=""stylesheet"" type=""text/css"">" & vbCrLf
TmpHTML = TmpHTML & "<title>" & AppTitle & "</title>" & vbCrLf
TmpHTML = TmpHTML & "<script language=""JScript"" src=""/" & HomeAlias & "/include.js?" & TimeUniq() & """></script>" & vbCrLf
TmpHTML = TmpHTML & "<script language=""JScript"" src=""/" & HomeAlias & "/includesj.js?" & TimeUniq() & """></script>" & vbCrLf
TmpHTML = TmpHTML & "<script language=""JScript.Encode"" src=""/" & HomeAlias & "/include_enc.js?" & TimeUniq() & """></script>" & vbCrLf
TmpHTML = TmpHTML & "<script language=""JScript.Encode"" src=""/" & HomeAlias & "/includesj_enc.js?" & TimeUniq() & """></script>" & vbCrLf
TmpHTML = TmpHTML & "</head>" & vbCrLf
TmpHTML = TmpHTML & "<body>" & vbCrLf
TmpHTML = TmpHTML & "<form method=""POST"" name=""form1"" 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
End If
Next
TmpHTML = TmpHTML & "</form>" & vbCrLf
TmpHTML = TmpHTML & "</body>" & vbCrLf
TmpHTML = TmpHTML & "<SCRIPT LANGUAGE=""JavaScript"">" & vbCrLf
TmpHTML = TmpHTML & "<!--" & vbCrLf
TmpHTML = TmpHTML & " HomeAlias = """ & HomeAlias & """;" & vbCrLf
TmpHTML = TmpHTML & " HomeAliasSL = """ & HomeAliasSL & """;" & vbCrLf
TmpHTML = TmpHTML & " SubmitReal(form1);" & vbCrLf
TmpHTML = TmpHTML & "-->" & vbCrLf
TmpHTML = TmpHTML & "</SCRIPT>" & vbCrLf
TmpHTML = TmpHTML & "</html>" & vbCrLf
End If
SubmitHystoryBack = TmpHTML
End Function
'ScriptX構文トグル出力
Function ScriptXObject()
'ブラウザ判定によるScriptXバージョンのトグル
Dim TmpScriptX
TmpScriptX = "ScriptX.cab#Version=5,0,4,185"
If ScriptXver > 7 Then
TmpScriptX = "smsx.cab#Version=6,5,439,12"
'TmpScriptX = "smsx.cab#Version=7,5,0,20"
End If
Dim TmpHTML
TmpHTML = ""
If GB_IEmode = "1" And PrintMarginControl > 0 Then
TmpHTML = TmpHTML & " <OBJECT classid=clsid:1663ed61-23eb-11d2-b92f-008048fdd814 "";" & vbCrLf
TmpHTML = TmpHTML & " codeBase=/" & HomeAlias & "/binx/" & TmpScriptX & " height=14 id=factory "";" & vbCrLf
TmpHTML = TmpHTML & " style='DISPLAY: none' width=14 viewastext>" & vbCrLf
TmpHTML = TmpHTML & " </OBJECT>" & vbCrLf
End If
ScriptXObject = TmpHTML
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 NumChrReject(Str)
Dim TmpHeader
TmpHeader = ""
TmpHeader = TmpHeader & "<html>" & vbCrLf
TmpHeader = TmpHeader & "<head>" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Content-Type"" content=""text/html; charset=shift_jis"">" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Pragma"" content=""no-cache"">" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Cache-Control"" content=""no-cache"">" & vbCrLf
TmpHeader = TmpHeader & "<meta http-equiv=""Expires"" content=""-1"">" & vbCrLf
TmpHeader = TmpHeader & "<title>" & AppTitle & "</title>" & vbCrLf
TmpHeader = TmpHeader & "</head>" & vbCrLf
TmpHeader = TmpHeader & "<SCRIPT LANGUAGE=""JavaScript"">" & vbCrLf
TmpHeader = TmpHeader & "</SCRIPT>" & vbCrLf
TmpHeader = TmpHeader & "<body bgcolor=""#DDDDDD"" leftmargin=""0"" topmargin=""0"" marginwidth=""0"" marginheight=""0"">" & vbCrLf
TmpHeader = TmpHeader & "<BR>" & vbCrLf
NumChrReject = True
If InStr(Str, "&#") > 0 Then
Dim TmpStr
TmpStr = Split(Str, "&#")
Dim Cnt
For Cnt = 0 To UBound(TmpStr)
If InStr(TmpStr(Cnt), ";") > 0 And InStr(TmpStr(Cnt), ";") <= 7 Then
Dim TmpNum
TmpNum = Left(TmpStr(Cnt), InStr(TmpStr(Cnt), ";"))
Response.Write(TmpHeader)
Response.Write(" 特殊な漢字は利用できません。<br><br>")
Response.Write(" 入力された漢字 ： <font size=""+1""><b>&#" & Left(TmpStr(Cnt), InStr(TmpStr(Cnt), ";")) & "</b></font><br><br>")
Response.Write(" <a href=""JavaScript:history.go(-1)"">戻る</a>" & vbCrLf)
Response.Write("</body>" & vbCrLf)
Response.Write("</html>" & vbCrLf)
NumChrReject = False
Exit For
End If
Next
End If
End Function
%>