<% Response.Buffer = false Response.ContentType = "text/html" Response.CharSet = "shift_jis" %> 花火大会 in 2013

カレンダーが新しくなりました

--- 花火大会 in 2013 ---   全データ(XML)

<% Dim i, Yr, Y, Mt, Dy, URL i = Request.QueryString("date") Yr = Year(Now()) Mt = Month(Now()) If i <> "" Then If InStr(i, "/") Then Y = Year(i) Mt = Month(i) Dy = Day(i) ElseIf Len(i) >= 6 Then ' Year(4) + Month(2) (+ Day(2)) On Error Resume Next Y = 0 + Left(CStr(i), 4) Mt = 0 + Mid(CStr(i), 5, 2) Dy = 0 + Mid(CStr(i), 7, 2) On Error Goto 0 End If If Y = Yr+1 Then Yr = Y End If URL = Request.ServerVariables("URL") i = Yr & "/" & Mt & "/" & Dy If IsDate(i) Then DumpDetail i Else Calendar Yr, Mt End If %>
2000 / 2001 / 2002 / 2003 / 2004 / 2005 / 2006 / 2007 / 2008 / 2009 / 2010 / 2011 / 2012 / 2013
<% Function DumpDetail(sdate) Dim i, Yr, Mt, Dy, xmlfile Yr = Year(sdate) Mt = Month(sdate) Dy = Day(sdate) 'If Yr <= 2000 Then ' xmlfile = "fireworks2000.xml" 'Else xmlfile = "fireworks2013.xml" 'End If Dim XMLDom, XSL, FireXML Set XMLDom = Server.CreateObject("Microsoft.XMLDOM") XMLDom.async = false XMLDom.load(Server.MapPath(xmlfile)) XSL = "//花火大会[日にち/@月='" & Mt & "' and 日にち/@日='" & Dy & "']" set FireXML = XMLDom.documentElement.selectNodes(XSL) Response.Write "" Response.Write Yr & "年" & Mt & "月" & Dy & "日" & "の花火大会一覧" Response.Write "" Response.Write "   " Response.Write "カレンダーに戻る" Response.Write "
" & Chr(13) & Chr(10) Response.Write "
" Response.Write "

赤色は尺玉以上、尺玉連発、1万発以上、競技会、コンクールなどの花火大会となっています。

" & Chr(13) & Chr(10) BeginCenter BeginTable BeginRow Response.Write "大会名(場所)" Response.Write "時間" EndRow for i = 0 to FireXML.length-1 Dim color if FireXML.Item(i).getAttribute("mark") <> "" then color = "red" else color = "yellow" end if On Error Resume Next BeginRow BeginCell color, "left", "" Response.Write FireXML.Item(i).selectNodes("大会名").Item(0).text Response.Write "(" Response.Write FireXML.Item(i).selectNodes("場所").Item(0).text Response.Write ")" EndCell BeginCell color, "left", "" Response.Write FireXML.Item(i).selectNodes("時間").Item(0).text EndCell EndRow BeginRow BeginCellSpan "", "left", 2 Response.Write Replace(FireXML.Item(i).selectNodes("詳細").Item(0).text, "\n", "
") EndCell EndRow On Error Goto 0 Next EndTable EndCenter Response.Write "
" & Chr(13) & Chr(10) End Function Function Calendar(Yr, Mt) Dim Months, WeekDays Months = Split("January February March April May June July August September October November December") WeekDays = Split("Sun Mon Tue Wed Thu Fri Sat") Dim color, i, j, Dy Dim XMLDom Set XMLDom = Server.CreateObject("Microsoft.XMLDOM") XMLDom.async = false XMLDom.load(Server.MapPath("fireworks2013.xml")) Response.Write "" Response.Write Yr & "年" & Mt & "月" & "の花火大会カレンダー" Response.Write "
" & Chr(13) & Chr(10) Response.Write "
" & Chr(13) & Chr(10) Response.Write "○は花火大会が開催される日
" & Chr(13) & Chr(10) Response.Write "◎は尺玉以上、尺玉連発、1万発以上、競技会、コンクールなどの花火大会が開催される日となっています。" & Chr(13) & Chr(10) Response.Write "
" & Chr(13) & Chr(10) Dy = Yr & "/" & Mt & "/1" i = DateAdd("m", -1, Dy) j = DateAdd("m", +1, Dy) BeginCenter Response.Write "" Response.Write "" Response.Write "" Response.Write "
<< " If Yr <= Year(i) Then BeginLink URL & "?date=" & Year(i) & Right("0" & Month(i), 2), "" Response.Write Months(Month(i)-1) EndLink Else Response.Write Months(Month(i)-1) End If Response.Write "" If Yr >= Year(j) Then BeginLink URL & "?date=" & Year(j) & Right("0" & Month(j), 2), "" Response.Write Months(Month(j)-1) EndLink Else Response.Write Months(Month(j)-1) End If Response.Write " >>
" BeginTable BeginRow BeginCellSpan "yellow", "center", "7" Response.Write Months(Mt-1) & ", " & Yr 'MonthName(Mt) EndCell EndRow BeginRow For i=1 to 7 Select Case i Case 1,7 color = "#FF6060" Case Else color = "#90EE90" End Select BeginCell color, "center", "50" Response.Write WeekDays(i-1) 'WeekDayName(i) EndCell Next EndRow Dy = 1 j = Weekday(Yr & "/" & Mt & "/1") Do while Dy <= 31 BeginRow For i = 1 to j-1 BeginCell "#ADD8E6", "center", "" EndCell Next For i = j to 7 If IsDate(Yr & "/" & Mt & "/" & Dy) Then Dim XSL, FireXML, FireXML2 BeginCell "#ADD8E6", "center", "" XSL = "//花火大会[日にち/@月='" & Mt & "' and 日にち/@日='" & Dy & "']" Set FireXML = XMLDom.documentElement.selectNodes(XSL) if FireXML.length then Response.Write "" BeginLink URL & "?date=" & Yr & Right("0" & Mt, 2) & Right("0" & Dy, 2), "" Response.Write Dy EndLink Response.Write "
" Response.Write "
" XSL = "//花火大会[@mark and 日にち/@月='" & Mt & "' and 日にち/@日='" & Dy & "']" set FireXML2 = XMLDom.documentElement.selectNodes(XSL) if FireXML2.length then BeginColor color Response.Write "◎" & FireXML2.length EndColor Response.Write "/" else Response.Write "○" end if Response.Write FireXML.length & "
" else Response.Write "" Response.Write Dy Response.Write "
" Response.Write " " end if '' Response.Write XSL & " (" & FireXML.length & ")" EndCell End If Dy = Dy + 1 Next EndRow j = 1 Loop EndTable EndCenter Response.Write "
" End Function Sub BeginBlockQuote Dim Temp Temp = "
" + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub EndBlockQuote Dim Temp Temp = "
" + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub BeginCell( Color, Align, Width ) Dim Temp Temp = "" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub BeginCellSpan( Color, Align, ColSpan ) Dim Temp Temp = " "" then Temp = Temp + " colspan=" + chr(34) + CStr(ColSpan) + chr(34) If Color <> "" then Temp = Temp + " bgcolor=" + chr(34) + Color + chr(34) If Align <> "" then Temp = Temp + " align=" + chr(34) + Align + chr(34) Temp = Temp + ">" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub EndCell Dim Temp Temp = "" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub BeginCenter Dim Temp Temp = "
" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub EndCenter Dim Temp Temp = "
" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub BeginColor( Color ) Dim Temp Temp = "" Response.Write( Temp ) End Sub Sub EndColor Dim Temp Temp = "" Response.Write( Temp ) End Sub Sub BeginLink( Link, Target ) Dim Temp Temp = "" Response.Write( Temp ) End Sub Sub EndLink Dim Temp Temp = "" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub BeginRow Dim Temp Temp = "" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub EndRow Dim Temp Temp = "" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub BeginTable Dim Temp Temp = "" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub Sub EndTable Dim Temp Temp = "
" Temp = Temp + chr(13) + chr(10) Response.Write( Temp ) End Sub %>