Option Explicit Dim WshShell, FS, SShell, ListF, ULFlag, FileName, HistFolder Dim Dsktop, MyDoc, DiaryFolder, Header, IfName Dim NikkiIcon, BusyIcon, TodayF, YDWeek, YDR, TMFold, Flist(1000), Fcount Dim HConfig, Tagchg, MyComp, Scop, Posit, Width1, Width2, Height1, Extens, sortZ YDR = CStr(DateAdd("d", -1, Date)) Set WshShell = Wscript.CreateObject("WScript.Shell") Set FS = WScript.CreateObject("Scripting.FileSystemObject") Dsktop = WshShell.SpecialFolders("Desktop") MyDoc = WshShell.SpecialFolders("MyDocuments") DiaryFolder = MyDoc & "\IDiary" If Not FS.FolderExists(DiaryFolder) Then FS.CreateFolder (DiaryFolder) RdConfig Header = "" MkFrameSet mkDmenu mkCopyright '-----------(ここからサブルーチン)------------------------- '----(MStrの両側にダブルクオーテーションを付加する)---- Function ADQ(MStr) ADQ = Chr(34) & MStr & Chr(34) End Function '------(今日の日付の文字列の/を削除する)--------------- Function TDAY() Dim DD, DA, DB DA = DatePart("yyyy", Date): DD = Right(CStr(DA), 2) DA = DatePart("m", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & DB DA = DatePart("d", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & DB TDAY = DD End Function '------------(2000/00/00形式の日付を返す)-------------- Function DATE2() Dim DD, DA, DB DA = DatePart("yyyy", Date): DD = CStr(DA) DA = DatePart("m", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & "/" & DB DA = DatePart("d", Date): DB = Right("0" & LTrim(CStr(DA)), 2): DD = DD & "/" & DB DATE2 = DD End Function '---------------(read config)------------------------ Sub RdConfig() Const ForReading = 1 Dim FRname, HConfig, TXT, P1 Tagchg = "全角": MyComp = "yes": Scop = "all" Posit = "L": Extens = "": sortZ = "D" Width1 = 1000: Width2 = 120: Height1 = 700 FRname = "hconfig.txt" If Not FS.FileExists(FRname) Then Exit Sub Set HConfig = FS.OpenTextFile(FRname, ForReading, False) Do While HConfig.AtEndOfStream <> True TXT = HConfig.ReadLine: P1 = InStr(TXT, "=") If InStr(TXT, "tagchange=") > 0 Then Tagchg = Mid(TXT, P1 + 2) If InStr(TXT, "mycomp=") > 0 Then MyComp = Mid(TXT, P1 + 2) If InStr(TXT, "scope=") > 0 Then Scop = Mid(TXT, P1 + 2) If InStr(TXT, "position=") > 0 Then Posit = Mid(TXT, P1 + 2) If InStr(TXT, "extension=") > 0 Then Extens = Mid(TXT, P1 + 2, 1) If InStr(TXT, "width1=") > 0 Then Width1 = CInt(Mid(TXT, P1 + 2)) If InStr(TXT, "width2=") > 0 Then Width2 = CInt(Mid(TXT, P1 + 2)) If InStr(TXT, "height1=") > 0 Then Height1 = CInt(Mid(TXT, P1 + 2)) If InStr(TXT, "sortZ=") > 0 Then sortZ = Mid(TXT, P1 + 2, 1) If InStr(TXT, "ifname=") > 0 Then IfName = Mid(TXT, P1 + 2) Loop HConfig.Close End Sub '------------------------------------------------------ Sub MkFrameSet() If Posit = "L" Then MkFrameL If Posit = "R" Then MkFrameR If Posit = "A" Then MkFrameA End Sub '--------------------- Sub MkFrameL() Dim Fname, FRset If IfName = "" Then IfName = "IDiary.htm" Fname = MyDoc & "\" & IfName Set FRset = FS.CreateTextFile(Fname, True) ' FRset.writeline (Header) FRset.writeline ("インターネット日記") FRset.writeline ("") FRset.writeline ("") FRset.writeline ("") FRset.writeline ("") FRset.writeline ("<BODY>フレームを表示できるブラウザが必要です｡</BODY>") FRset.writeline ("") FRset.Close End Sub '-------------------- Sub MkFrameR() Dim Fname, FRset Fname = MyDoc & "\IDiary.htm" Set FRset = FS.CreateTextFile(Fname, True) ' FRset.writeline (Header) FRset.writeline ("インターネット日記") FRset.writeline ("") FRset.writeline ("") FRset.writeline ("") FRset.writeline ("") FRset.writeline ("<BODY>フレームを表示できるブラウザが必要です｡</BODY>") FRset.writeline ("") ' FRset.Close End Sub Sub MkFrameA() Dim Fname, FRset, Fmsg, Fmp Fname = MyDoc & "\IDiary.htm" Set FRset = FS.CreateTextFile(Fname, True) ' FRset.writeline (Header) FRset.writeline ("Index") FRset.writeline ("") FRset.writeline (" ") ' FRset.Close End Sub '----------------------------------------------------------- Sub mkDmenu() Dim Fname, FRset, Diary, OBJ, NN, DT, MM, A1 mkList Fname = MyDoc & "\IDiary\Lmenu.htm" Set FRset = FS.CreateTextFile(Fname, True) ' FRset.writeline (Header) FRset.writeline ("日記Index") FRset.writeline ("") FRset.writeline ("") FRset.writeline ("") For A1 = 1 To Fcount NN = Flist(A1) DT = "20" + Mid(NN, 2, 2) + "/" + Mid(NN, 4, 2) + "/" + Mid(NN, 6, 3) If InStr(NN, "(") > 0 Then DT = NN If Right(DT, 1) = "." Then DT = Left(DT, Len(DT) - 1) MM = "

" MM = MM & "" & DT & "

" FRset.writeline (MM) Next FRset.writeline ("") FRset.Close End Sub '-------------------------------------------------- Sub QSort1(LT, RT) Dim Temp, Base, K1, K2 Base = Flist(LT): K1 = LT + 1: K2 = RT Do While K1 <= K2 Do Until Flist(K1) > Base Or K1 >= K2 K1 = K1 + 1 Loop Do Until Flist(K2) < Base Or K2 <= K1 K2 = K2 - 1 Loop If K1 = K2 Then Exit Do Temp = Flist(K1): Flist(K1) = Flist(K2): Flist(K2) = Temp K1 = K1 + 1: K2 = K2 - 1 Loop If Flist(K1) <= Base Then Flist(LT) = Flist(K1): Flist(K1) = Base: K1 = K1 - 1 If Flist(K1) > Base Then Flist(LT) = Flist(K1 - 1): Flist(K1 - 1) = Base: K1 = K1 - 2 If K1 > LT Then Call QSort1(LT, K1) If K2 < RT Then Call QSort1(K2, RT) End Sub '---------------------------------------- Sub QSort2(LT, RT) '昇順 Dim Temp, Base, K1, K2 Base = Flist(LT): K1 = LT + 1: K2 = RT Do While K1 <= K2 Do Until Flist(K1) < Base Or K1 >= K2 K1 = K1 + 1 Loop Do Until Flist(K2) > Base Or K2 <= K1 K2 = K2 - 1 Loop If K1 = K2 Then Exit Do Temp = Flist(K1): Flist(K1) = Flist(K2): Flist(K2) = Temp K1 = K1 + 1: K2 = K2 - 1 Loop If Flist(K1) >= Base Then Flist(LT) = Flist(K1): Flist(K1) = Base: K1 = K1 - 1 If Flist(K1) < Base Then Flist(LT) = Flist(K1 - 1): Flist(K1 - 1) = Base: K1 = K1 - 2 If K1 > LT Then Call QSort2(LT, K1) If K2 < RT Then Call QSort2(K2, RT) End Sub '----------------------------------------------------------- Sub mkList() Dim Diary, OBJ, A1 Set Diary = FS.GetFolder(DiaryFolder) For Each OBJ In Diary.Files If Left(OBJ.Name, 1) = "D" Then Fcount = Fcount + 1 Flist(Fcount) = OBJ.Name End If Next A1 = 1 If sortZ = "D" Then Call QSort2(A1, Fcount) Else Call QSort1(A1, Fcount) End Sub '---------------------------------------------------- Sub mkCopyright() Dim Fname, FRset Fname = MyDoc & "\IDiary\Copyright.txt" Set FRset = FS.CreateTextFile(Fname, True) FRset.writeline ("インターネット日記 v1.4") FRset.writeline ("Copyright. ssx336@geocities.co.jp") FRset.writeline ("http://www.geocities.co.jp/Technopolis/3096/") FRset.writeline ("http://users.goo.ne.jp/ssx336/") FRset.Close End Sub