home *** CD-ROM | disk | FTP | other *** search
/ DOS/V Power Report 2001 December (DVD) / VPR0112A.ISO / OLS / NIKKI / nikki.lzh / nikki / MkIndex.vbs < prev    next >
Text File  |  2001-06-14  |  9KB  |  239 lines
  1. Option Explicit
  2. Dim WshShell, FS, SShell, ListF, ULFlag, FileName, HistFolder
  3. Dim Dsktop, MyDoc, DiaryFolder, Header, IfName
  4. Dim NikkiIcon, BusyIcon, TodayF, YDWeek, YDR, TMFold, Flist(1000), Fcount
  5. Dim HConfig, Tagchg, MyComp, Scop, Posit, Width1, Width2, Height1, Extens, sortZ
  6.  
  7.     YDR = CStr(DateAdd("d", -1, Date))
  8.  
  9.     Set WshShell = Wscript.CreateObject("WScript.Shell")
  10.     Set FS = WScript.CreateObject("Scripting.FileSystemObject")
  11.     
  12.     Dsktop = WshShell.SpecialFolders("Desktop")
  13.     MyDoc = WshShell.SpecialFolders("MyDocuments")
  14.     DiaryFolder = MyDoc & "\IDiary"
  15.     
  16.     If Not FS.FolderExists(DiaryFolder) Then FS.CreateFolder (DiaryFolder)
  17.     
  18.     RdConfig
  19.    
  20. Header = "<HTML><HEAD><META HTTP-EQUIV=" & ADQ("Content-Type") & " CONTENT=" & ADQ("text/html;CHARSET=x-sjis") & ">"
  21.  
  22.     MkFrameSet
  23.     mkDmenu
  24.     mkCopyright
  25.  
  26. '-----------(ここからサブルーチン)-------------------------
  27. '----(MStrの両側にダブルクオーテーションを付加する)----
  28. Function ADQ(MStr)
  29.     ADQ = Chr(34) & MStr & Chr(34)
  30. End Function
  31. '------(今日の日付の文字列の/を削除する)---------------
  32. Function TDAY()
  33.   Dim DD, DA, DB
  34.   DA = DatePart("yyyy", Date): DD = Right(CStr(DA), 2)
  35.   DA = DatePart("m", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & DB
  36.   DA = DatePart("d", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & DB
  37.   TDAY = DD
  38. End Function
  39. '------------(2000/00/00形式の日付を返す)--------------
  40. Function DATE2()
  41.   Dim DD, DA, DB
  42.   DA = DatePart("yyyy", Date): DD = CStr(DA)
  43.   DA = DatePart("m", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & "/" & DB
  44.   DA = DatePart("d", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & "/" & DB
  45.   DATE2 = DD
  46. End Function
  47. '---------------(read config)------------------------
  48. Sub RdConfig()
  49.     Const ForReading = 1
  50.     Dim FRname, HConfig, TXT, P1
  51.     Tagchg = "全角": MyComp = "yes": Scop = "all"
  52.     Posit = "L": Extens = "": sortZ = "D"
  53.     Width1 = 1000: Width2 = 120: Height1 = 700
  54.     
  55.     FRname = "hconfig.txt"
  56.     If Not FS.FileExists(FRname) Then Exit Sub
  57.     
  58.     Set HConfig = FS.OpenTextFile(FRname, ForReading, False)
  59.     Do While HConfig.AtEndOfStream <> True
  60.       TXT = HConfig.ReadLine: P1 = InStr(TXT, "=")
  61.       If InStr(TXT, "tagchange=") > 0 Then Tagchg = Mid(TXT, P1 + 2)
  62.       If InStr(TXT, "mycomp=") > 0 Then MyComp = Mid(TXT, P1 + 2)
  63.       If InStr(TXT, "scope=") > 0 Then Scop = Mid(TXT, P1 + 2)
  64.       If InStr(TXT, "position=") > 0 Then Posit = Mid(TXT, P1 + 2)
  65.       If InStr(TXT, "extension=") > 0 Then Extens = Mid(TXT, P1 + 2, 1)
  66.       If InStr(TXT, "width1=") > 0 Then Width1 = CInt(Mid(TXT, P1 + 2))
  67.       If InStr(TXT, "width2=") > 0 Then Width2 = CInt(Mid(TXT, P1 + 2))
  68.       If InStr(TXT, "height1=") > 0 Then Height1 = CInt(Mid(TXT, P1 + 2))
  69.       If InStr(TXT, "sortZ=") > 0 Then sortZ = Mid(TXT, P1 + 2, 1)
  70.       If InStr(TXT, "ifname=") > 0 Then IfName = Mid(TXT, P1 + 2)
  71.     Loop
  72.     HConfig.Close
  73. End Sub
  74. '------------------------------------------------------
  75. Sub MkFrameSet()
  76.     If Posit = "L" Then MkFrameL
  77.     If Posit = "R" Then MkFrameR
  78.     If Posit = "A" Then MkFrameA
  79. End Sub
  80. '---------------------
  81. Sub MkFrameL()
  82.     Dim Fname, FRset
  83.     If IfName = "" Then IfName = "IDiary.htm"
  84.     Fname = MyDoc & "\" & IfName
  85.     Set FRset = FS.CreateTextFile(Fname, True)
  86. '
  87.     FRset.writeline (Header)
  88.     FRset.writeline ("<TITLE>インターネット日記</TITLE>")
  89.     FRset.writeline ("<Script language=vbscript>")
  90.     FRset.writeline ("Window.resizeto " & CStr(Width1) & "," & CStr(Height1))
  91.     FRset.writeline ("</Script></HEAD>")
  92.     FRset.writeline ("<FRAMESET FRAMEBORDER=1 COLS=" & ADQ(CStr(Width2) & ",*") & ">")
  93.     FRset.writeline ("<FRAME SRC=" & ADQ("IDiary/Lmenu.htm") & " NAME=" & ADQ("L") & ">")
  94.     FRset.writeline ("<FRAME SRC=" & ADQ("IDiary/D" & TDAY & Extens & ".htm") & " NAME=" & ADQ("R") & ">")
  95.     FRset.writeline ("<NOFRAMES><BODY>フレームを表示できるブラウザが必要です｡</BODY></NOFRAMES>")
  96.     FRset.writeline ("</FRAMESET></HTML>")
  97.     FRset.Close
  98. End Sub
  99. '--------------------
  100. Sub MkFrameR()
  101.     Dim Fname, FRset
  102.     Fname = MyDoc & "\IDiary.htm"
  103.     Set FRset = FS.CreateTextFile(Fname, True)
  104. '
  105.     FRset.writeline (Header)
  106.     FRset.writeline ("<TITLE>インターネット日記</TITLE>")
  107.     FRset.writeline ("<Script language=vbscript>")
  108.     FRset.writeline ("Window.resizeto " & CStr(Width1) & "," & CStr(Height1))
  109.     FRset.writeline ("</Script></HEAD>")
  110.     FRset.writeline ("<FRAMESET FRAMEBORDER=1 COLS=" & ADQ("*," & CStr(Width2)) & ">")
  111.     FRset.writeline ("<FRAME SRC=" & ADQ("IDiary/D" & TDAY & Extens & ".htm") & " NAME=" & ADQ("R") & ">")
  112.     FRset.writeline ("<FRAME SRC=" & ADQ("IDiary/Lmenu.htm") & " NAME=" & ADQ("L") & ">")
  113.     FRset.writeline ("<NOFRAMES><BODY>フレームを表示できるブラウザが必要です｡</BODY></NOFRAMES>")
  114.     FRset.writeline ("</FRAMESET></HTML>")
  115. '
  116.     FRset.Close
  117. End Sub
  118. Sub MkFrameA()
  119.     Dim Fname, FRset, Fmsg, Fmp
  120.     Fname = MyDoc & "\IDiary.htm"
  121.     Set FRset = FS.CreateTextFile(Fname, True)
  122. '
  123.     FRset.writeline (Header)
  124.     FRset.writeline ("<TITLE>Index</TITLE>")
  125.     FRset.writeline ("<Script language=vbscript>")
  126.     FRset.writeline ("Window.resizeto " & CStr(Width2) & "," & CStr(Height1))
  127.     FRset.writeline ("Window.moveto 0,0")
  128.     FRset.writeline ("Window.navigate" & ADQ("IDiary/Lmenu.htm"))
  129.     Fmp = "height=" & CStr(Height1 - 120) & ",width=" & CStr(Width1 - Width2) & ",left=" & CStr(Width2) & ",top=0,status=yes,toolbar=yes,menubar=yes,location=yes,resizable=yes,scrollbars=yes"
  130.     Fmsg = "open " & ADQ("IDiary/D" & TDAY & Extens & ".htm") & "," & ADQ("R") & "," & ADQ(Fmp)
  131.     FRset.writeline (Fmsg)
  132.     FRset.writeline ("</Script></HEAD>")
  133.     FRset.writeline ("<BODY> </BODY></HTML>")
  134. '
  135.     FRset.Close
  136. End Sub
  137.  
  138. '-----------------------------------------------------------
  139. Sub mkDmenu()
  140.     Dim Fname, FRset, Diary, OBJ, NN, DT, MM, A1
  141.     
  142.     mkList
  143.     
  144.     Fname = MyDoc & "\IDiary\Lmenu.htm"
  145.     Set FRset = FS.CreateTextFile(Fname, True)
  146. '
  147.     FRset.writeline (Header)
  148.     FRset.writeline ("<TITLE>日記Index</TITLE>")
  149.     FRset.writeline ("<script language=vbscript>")
  150.     FRset.writeline ("Sub resz()")
  151.     FRset.writeline ("Window.resizeto " & CStr(Width1) & "," & CStr(Height1))
  152.     FRset.writeline ("End Sub")
  153.     FRset.writeline ("</script>")
  154.     FRset.writeline ("</HEAD>")
  155.     FRset.writeline ("<BODY BGCOLOR=" & ADQ("#ffffff") & " onbeforeunload=resz() >")
  156.     For A1 = 1 To Fcount
  157.         NN = Flist(A1)
  158.         DT = "20" + Mid(NN, 2, 2) + "/" + Mid(NN, 4, 2) + "/" + Mid(NN, 6, 3)
  159.     If InStr(NN, "(") > 0 Then DT = NN
  160.         If Right(DT, 1) = "." Then DT = Left(DT, Len(DT) - 1)
  161.         MM = "<P><A HREF=" & ADQ(NN) & " TARGET=" & ADQ("R") & ">"
  162.         MM = MM & "<FONT SIZE=" & ADQ("-1") & ">" & DT & "</FONT></A></P>"
  163.         FRset.writeline (MM)
  164.     Next
  165.  
  166.     FRset.writeline ("</BODY></HTML>")
  167.     FRset.Close
  168. End Sub
  169. '--------------------------------------------------
  170. Sub QSort1(LT, RT)
  171.     Dim Temp, Base, K1, K2
  172.     Base = Flist(LT): K1 = LT + 1: K2 = RT
  173.  
  174.     Do While K1 <= K2
  175.         Do Until Flist(K1) > Base Or K1 >= K2
  176.             K1 = K1 + 1
  177.         Loop
  178.         Do Until Flist(K2) < Base Or K2 <= K1
  179.             K2 = K2 - 1
  180.         Loop
  181.         If K1 = K2 Then Exit Do
  182.         Temp = Flist(K1): Flist(K1) = Flist(K2): Flist(K2) = Temp
  183.         K1 = K1 + 1: K2 = K2 - 1
  184.     Loop
  185.     If Flist(K1) <= Base Then Flist(LT) = Flist(K1): Flist(K1) = Base: K1 = K1 - 1
  186.     If Flist(K1) > Base Then Flist(LT) = Flist(K1 - 1): Flist(K1 - 1) = Base: K1 = K1 - 2
  187.     
  188.     If K1 > LT Then Call QSort1(LT, K1)
  189.     If K2 < RT Then Call QSort1(K2, RT)
  190. End Sub
  191. '----------------------------------------
  192. Sub QSort2(LT, RT) '昇順
  193.     Dim Temp, Base, K1, K2
  194.     Base = Flist(LT): K1 = LT + 1: K2 = RT
  195.  
  196.     Do While K1 <= K2
  197.         Do Until Flist(K1) < Base Or K1 >= K2
  198.             K1 = K1 + 1
  199.         Loop
  200.         Do Until Flist(K2) > Base Or K2 <= K1
  201.             K2 = K2 - 1
  202.         Loop
  203.         If K1 = K2 Then Exit Do
  204.         Temp = Flist(K1): Flist(K1) = Flist(K2): Flist(K2) = Temp
  205.         K1 = K1 + 1: K2 = K2 - 1
  206.     Loop
  207.     If Flist(K1) >= Base Then Flist(LT) = Flist(K1): Flist(K1) = Base: K1 = K1 - 1
  208.     If Flist(K1) < Base Then Flist(LT) = Flist(K1 - 1): Flist(K1 - 1) = Base: K1 = K1 - 2
  209.     
  210.     If K1 > LT Then Call QSort2(LT, K1)
  211.     If K2 < RT Then Call QSort2(K2, RT)
  212. End Sub
  213.  
  214. '-----------------------------------------------------------
  215. Sub mkList()
  216.     Dim Diary, OBJ, A1
  217.     Set Diary = FS.GetFolder(DiaryFolder)
  218.     For Each OBJ In Diary.Files
  219.         If Left(OBJ.Name, 1) = "D" Then
  220.             Fcount = Fcount + 1
  221.             Flist(Fcount) = OBJ.Name
  222.         End If
  223.     Next
  224.     A1 = 1
  225.     If sortZ = "D" Then Call QSort2(A1, Fcount) Else Call QSort1(A1, Fcount)
  226. End Sub
  227.  
  228. '----------------------------------------------------
  229. Sub mkCopyright()
  230.     Dim Fname, FRset
  231.     Fname = MyDoc & "\IDiary\Copyright.txt"
  232.     Set FRset = FS.CreateTextFile(Fname, True)
  233.     FRset.writeline ("インターネット日記 v1.4")
  234.     FRset.writeline ("Copyright.  ssx336@geocities.co.jp")
  235.     FRset.writeline ("http://www.geocities.co.jp/Technopolis/3096/")
  236.     FRset.writeline ("http://users.goo.ne.jp/ssx336/")
  237.     FRset.Close
  238. End Sub
  239.