VBS särskilt datum Tracker (6 / 8 steg)

Steg 6: Koden

' *********************************************
Dim varsel
Dim meddelande
Dim fso
Dim objFile
Dim arrLines
Dim arrList
Dim filnamn
Dim Hol(12)

Ställa in fso = CreateObjectScripting.FileSystemObject("")

Filnamn = "c:\MySpecialDates.txt"

CONST ForReading = 1
CONST ForWriting = 2 "kommer över skriva allt
CONST ForAppending = 8 "kommer att skapa eller lägga till fil

"denna kod kommer att skapa filen Data
Om (fso. FileExists(FileName)) = falskt då
Ange objFile = FSO. OpenTextFile (filnamn, ForAppending, sant)

objFile.Close

Slut om

"Felhantering
På fel återupptas nästa

"Standard Inputbox
Meddelande = "Min speciella datum - idag är" & WeekDayNAme(WeekDay(Date)) & "" & datum
Meddelande = "Vad vill du göra?" & vbcr & vbcr & _
"1 - Visa datum för denna månad" & vbcr & _
"2 - Visa datum för nästa månad" & vbcr & _
"3 - lägga till ett datum och namn i listan" & vbCr & _
"4 - ta bort ett datum och namn från din lista" & vbcr & vbcr & _
"Ange numret på ditt val."

"InputBox resultat
Fråga = InputBox(message,Notice)
' Kontrollera om Null eller tomma inputbox sedan avbryter
OM IsEmpty(Question) sedan
WScript.quit()

ELSEIF Len(Question) = 0 då
WScript.quit()

ELSEIF fråga = 0 då
WScript.quit()

ANNAT
Välj ärende fråga
Fall 1 Run(1)
Fall 2 Run(2)
Fall 3 Run(3)
Fall 4 Run(4)
END SELECT

SLUT OM

"Case uttalanden för resultatet
Sub Run(var)
Ställa in WS = CreateObject("WScript.shell")

' Januari
"Detta kontrollerar om aktuella månaden är december besluta vilket semester datum att använda
OM Month(date) = "12" då
Hol (0) = "01/01 /" & Right(DateSerial(Year(Date)+1,1,1),4) & "New Year's Day"
Hol(1) = "0" & DateSerial(Year(Date)+1,1,22) - Weekday(DateSerial(Year(Date)+1,1,22),3) & "MLK dag"
ANNAT
Hol (0) = "01/01 /" & Right(DateSerial(Year(Date),1,1),4) & "New Year's Day"
Hol(1) = "0" & DateSerial(Year(Date),1,22) - Weekday(DateSerial(Year(Date),1,22),3) & "MLK dag"
SLUT OM

"Februari
Hol(2) = "02/14 /" & Year(Date) & "Alla hjärtans dag"
Hol(3) = "0" & DateSerial(Year(Date),3,1) - Weekday(DateSerial(Year(Date),3,1),3) - 7 & "presidentens dag"

"Kan
Hol(4) = "0" & DateSerial(Year(Date),6,1) - Weekday(DateSerial(Year(Date),6,1),3) & "Memorial Day"

"Juli
Hol(5) = "07/04 /" & Year(Date) & "Independence Day"

"September
Hol(6) = "09/0" & Mid(DateSerial(Year(Date),9,8) - Weekday(DateSerial(Year(Date),9,8),3),3,1) & "/" & Year(Date) & "Labor Day"

"Oktober
Hol(7) = DateSerial(Year(Date),10,15) - Weekday(DateSerial(Year(Date),10,15),3) & "Columbus Day"

"November
Hol(8) = DateSerial(Year(Date),11,11) & "Veterans' Day"
Hol(9) = DateSerial(Year(Date),11,29) - Weekday(DateSerial(Year(Date),11,29),6) & "Thanksgiving Day"

"December
Hol(10) = DateSerial(Year(Date),12,25) & "Christmas Day"
Hol(11) = DateSerial(Year(Date),12,31) & "New Year's Eve"

Välj mål var
Fall 1' Visa aktuell månad

Ange objRegEx = CreateObject("VBScript.RegExp")
DateSearch = Right(String(2,"0") & Month(Date), 2)
objRegEx.Pattern = "^" & DateSearch

Ange objFile = fso. OpenTextFile (filnamn, ForReading)
Ange arrLines = CreateObject("System.Collections.ArrayList")

Inte förrän objFile.AtEndOfStream
strSearchString = objFile.ReadLine
Ange colMatches = objRegEx.Execute(strSearchString)
IF colMatches.Count > 0 då
För varje strMatch i colMatches
arrLines.Add(strSearchString)
Nästa

SLUT OM

Loop

"Filter, Lägg till & Sortera helgdagar för kalendermånad
För i = 0 till 11
Ange colMatches = objRegEx.Execute(hol(i))
IF colMatches.Count > 0 då
För varje strMatch i colMatches
arrLines.Add(hol(i))

arrLines.sort()

Nästa

SLUT OM

Nästa

"Skriva alla speciella datum till ny fil så veckodag kan läggas
Dim TempFile
tempfile = "c:\Dates.txt"
Ange objFile = FSO. OpenTextFile (TempFile, ForAppending, sant)
objFile.Close

"Gå med matrisen med Line feed
Dim strNewFile: strNewFile = koppling (arrLines.ToArray, vbCrLf)
"Åter öppna filen för läsning
Ange objFile = fso. OpenTextFile (TempFile, ForWriting, falskt)
"Skriv den nya texten
objFile.Write strNewFile
objFile.Close

"Öppna tempfile läsa, lägga till dagen i veckan sedan bort tempfile
Ange objFile = fso. OpenTextFile (TempFile, ForReading)

Inte förrän objFile.AtEndOfStream
strSearchString = objFile.ReadLine
Ange colMatches = objRegEx.Execute(strSearchString)
Om colMatches.Count > 0 då
För varje strMatch i colMatches
"Veckodag visningsnamn för semestrar och AnnvYear med innevarande år
Om året (vänster (strSearchString, InStr (strSearchString,"")-1))=Year(DATE) sedan
strSearchString = WeekDayName(WeekDay(mid(strSearchString,1,2) & "/" & Mid(strSearchString,4,2) & "/" & (year(Date))) & ":" & strSearchString
"Visa veckodag namn och år räkna
Annat
strSearchString = WeekDayName(WeekDay(mid(strSearchString,1,2) & "/" & Mid(strSearchString,4,2) & "/" & (year(Date))) & ":" & strSearchString & ":" & DateDiff("y",year(Left(strSearchString,10)),Year(Date)) & "År"
SLUT OM

msg1 = msg1 & strsearchstring & vbcrlf
Nästa

SLUT OM

Loop
objFile.Close

"Skapa kalender för att lägga till i meddelande rutan tack lba
m = Month(date)
y = Year(Date)

w = veckodag (DateSerial (y, m, 1), w1) -1
l = dag (DateSerial (y, m + 1, 0)) + w

"Första raden dag namn
För i = 1 till 7
o = o & "" & WeekdayName (i, True) & ""
Nästa

' Datum nummer
o = o & vbCrLf
För i = 1 till l
d = i - w
OM d < 1 sedan
o = o & "--"
ANNARS om Len(d) = 1 då
o = o & "" & d & ""
ANNAT
o = o & "" & d & ""
SLUT OM
SLUT OM

Om (i-1) Mod 7 = 6 sedan
o = o & vbCrLf
Slut om

Nästa
"Visa resultat
MsgBox Msg1 & vbCrLf & o,,"speciella dagar av" & MonthName(Month(Date)) & "" & Year(Date)

"Ta bort Tempfile
fso. DeleteFile(Tempfile)

Fall 2' Visa nästa månad
Ange objRegEx = CreateObject("VBScript.RegExp")
DateSearch = Right(String(2,"0") & Month(DateAdd("M",1,date)), 2)
objRegEx.Pattern = "^" & DateSearch

Ange objFile = fso. OpenTextFile (filnamn, ForReading)
Ange arrLines = CreateObject("System.Collections.ArrayList")

Inte förrän objFile.AtEndOfStream
strSearchString = objFile.ReadLine
Ange colMatches = objRegEx.Execute(strSearchString)
Om colMatches.Count > 0 då
För varje strMatch i colMatches
arrLines.Add(strSearchString)
Nästa

SLUT OM

Loop

"Filter, Lägg till & Sortera helgdagar för kalendermånad
För i = 0 till 11
Ange colMatches = objRegEx.Execute(hol(i))
Om colMatches.Count > 0 då
För varje strMatch i colMatches
arrLines.Add(hol(i))
arrLines.sort()

Nästa

Slut om

Nästa

"Skriva alla speciella datum till ny fil så veckodag kan läggas
Dim TempFile2
tempfile2 = "c:\Dates.txt"
Ange objFile = FSO. OpenTextFile (TempFile2, ForAppending, sant)
objFile.Close

"Gå med matrisen med Line feed
Dim strNewFile2: strNewFile2 = koppling (arrLines.ToArray, vbCrLf)
"Åter öppna filen för läsning
Ange objFile = fso. OpenTextFile (TempFile2, ForWriting, falskt)
"Skriv den nya texten
objFile.Write strNewFile2
objFile.Close

"Öppna tempfile läsa, lägga till dagen i veckan sedan bort tempfile
Ange objFile = fso. OpenTextFile (TempFile2, ForReading)

Inte förrän objFile.AtEndOfStream
strSearchString = objFile.ReadLine
Ange colMatches = objRegEx.Execute(strSearchString)
Om colMatches.Count > 0 då
För varje strMatch i colMatches
"Display vardag namn för januari semester
Om året (vänster (strSearchString, InStr (strSearchString,"")-1))=DateAdd("Y",1,Year(DATE)) sedan
strSearchString = WeekDayName(WeekDay(DateAdd("yyyy",1,(mid(strSearchString,1,2) & "/" & Mid(strSearchString,4,2) & "/" & (Year(Date))) & ":" & strSearchString
"Aktuell månad är 12, AnnvMonth 01 display vardag och totalt år för nästa år
ElseIf månad (datum) = "12" och Left(strSearchString,2) = "01" och Mid(strSearchString,6,1) = "/" då
strSearchString = WeekDayName(WeekDay(DateAdd("yyyy",1,(mid(strSearchString,1,2) & "/" & Mid(strSearchString,4,2) & "/" & (Year(Date))) & ":" & strSearchString & ":" & DateDiff("y",year(Left(strSearchString,10)),Year(Date)) + 1 & "År"
"Aktuell månad 12, AnnvMonth är 01 utan AnnvYear då diplay korrekt veckodag namn
ElseIf månad (datum) = "12" och Left(strSearchString,2) = "01" och Mid(strSearchString,6,1) = "" sedan
strSearchString = WeekDayName(WeekDay(DateAdd("yyyy",1,(mid(strSearchString,1,2) & "/" & Mid(strSearchString,4,2) & "/" & (Year(Date))) & ":" & strSearchString
"Nuvarande vardag visningsnamnet för Annv datum utan semester eller år
ElseIf år (vänster (strSearchString, InStr (strSearchString,"")-1))=Year(DATE) sedan
strSearchString = WeekDayName(WeekDay(mid(strSearchString,1,2) & "/" & Mid(strSearchString,4,2) & "/" & (year(Date())) & ":" & strSearchString
"Visa vardag namn och beräkna år
Annat
strSearchString = WeekDayName(WeekDay(mid(strSearchString,1,2) & "/" & Mid(strSearchString,4,2) & "/" & (year(Date())) & ":" & strSearchString & ":" & DateDiff("y",year(Left(strSearchString,10)),Year(Date)) & "År"
SLUT OM

msg1 = msg1 & strsearchstring & vbcrlf
Nästa

SLUT OM
Loop
objFile.Close

"Skapa kalender för nästa månad för att lägga till i meddelande rutan tack lba
m = Month(DateAdd("M",1,date))
"Om aktuella månaden är december, vill visa nästa månad och år kalender
Om Month(date) = "12" då
Y =Year(DateAdd("YYYY",1,date))
ANNAT
Y = Year(Date)
SLUT OM

w = veckodag (DateSerial (y, m, 1), w1) -1
l = dag (DateSerial (y, m + 1, 0)) + w

"Första raden dag namn
För i = 1 till 7
o = o & "" & WeekdayName (i, True) & ""
Nästa

' Datum
o = o & vbCrLf
För i = 1 till l
d = i - w
Om d < 1 sedan
o = o & "--"
annat om Len(d) = 1 då
o = o & "" & d & ""
Annat
o = o & "" & d & ""
Slut om
Slut om

Om (i-1) Mod 7 = 6 sedan
o = o & vbCrLf
Slut om

Nästa
"Visa resultat
MsgBox Msg1 & vbCrLf & o,,"speciella dagar av" & MonthName(Month(DateAdd("M",1,date))) & "" & Y

"Ta bort Tempfile
fso. DeleteFile(Tempfile2)

Fall 3' Lägg till nytt datum
Meddelande = "Lägg till speciella datum till listan"

Fråga = InputBox ("Ange datum och namn som" & vbCR & vbCR & "MM/DD/ÅÅÅÅ namn ''''" & vbCR & "eller" & vbCR & "MM/DD namn ''''", meddelande)

' Kontrollera om Null eller tomma inputbox sedan avbryter
OM IsEmpty(Question) sedan
WScript.quit()

ELSEIF Len(Question) = 0 då
WScript.quit()

ANNAT
Om (fso. FileExists(FileName)) sedan
Ange objFile = FSO. OpenTextFile (filnamn, ForAppending, sant)
objFile.WriteLine (vbCrLf & fråga)
Annat
Ange objFile = FSO. OpenTextFile (filnamn, ForAppending, sant)
objFile.WriteLine (fråga)

objFile.Close

Slut om

Ange arrLines = CreateObject("System.Collections.ArrayList")
"Öppna filen
Ange objFile = fso. OpenTextFile (filnamn, ForReading, falskt)
' Loopa igenom och lägga till varje rad i matrisen
Inte förrän objFile.AtEndOfStream
strLine = Trim(objFile.ReadLine)
Om Len(strLine) > 0 då
' Kontrollera att matrisen inte redan har posten
Om inte arrLines.Contains(strLine) sedan arrLines.Add(strLine)
Slut om
Loop
objFile.Close
"Sortera (stigande) för estetik
arrLines.Sort()
"Gå med matrisen med vbCrLf (transport tillbaka eller ange)
Dim strNewFile1: strNewFile1 = koppling (arrLines.ToArray, vbCrLf)
"Åter öppna filen för läsning
Ange objFile = fso. OpenTextFile (filnamn, ForWriting, falskt)
"Skriv den nya texten
objFile.Write strNewFile1
objFile.Close

MsgBox "Speciella datum och namn anges", meddelande
SLUT OM

Fall 4' ta bort datum
Ställa in fso = CreateObjectScripting.FileSystemObject("")
Meddelande = "Vilken månad?"
Fråga = InputBox ("Skriv in antalet månaden vill du Visa?" & vbCrLf & vbCrLf & "Enter som ett nummer 1-12", märker)

Ange objRegEx = CreateObject("VBScript.RegExp")
DateSearch = Right(String(2,"0") & fråga, 2)
objRegEx.Pattern = "^" & DateSearch

Ange objFile = fso. OpenTextFile (filnamn, ForReading)
"Hitta datum i listan
Inte förrän objFile.AtEndOfStream
strSearchString = objFile.ReadLine
Ange colMatches = objRegEx.Execute(strSearchString)
Om colMatches.Count > 0 då
För varje strMatch i colMatches
MSG = Msg & "" & strSearchString & vbCrLf
Nästa

Slut om
Loop

objFile.Close

OM Len(Msg) = 0 då
MsgBox "Det finns inga datum i" & MonthName(Question) & "",,"speciella dagar"
Annat
Meddelande = "Skriv datum, namn eller båda skall avlägsnas."
Ange objFile = fso. OpenTextFile (filnamn, ForReading)

"Sätta matrisen in i InputBox
Fråga = InputBox ("The datum och namn är skiftlägeskänslig!" & vbCrLf & "vara specifik desto mindre du skriver desto mer kommer att matchas och tas bort." & vbCrLf & vbCrLf & Msg, meddelande)

' Kontrollera om Inputbox är tom, Avbryt om Tom
OM IsEmpty(Question) sedan
WScript.quit()
ELSEIF Len(Question) = 0 då
WScript.quit()
ANNAT
"Ta bort objekt i fråga
Ange objFile = fso. OpenTextFile (filnamn, ForReading)

Inte förrän objFile.AtEndOfStream
strLine = objFile.ReadLine
Om InStr (strLine, fråga) = 0 då
strNewContents = strNewContents & strLine & vbCrLf
Slut om
Loop
Slut om

objFile.Close

"Skriv om återstående objekt på fil
Ställa in fso = CreateObjectScripting.FileSystemObject("")
Ange objFile = FSO. OpenTextFile (filnamn, ForWriting)
objFile.Write strNewContents
objFile.Close
slut om
END SELECT
End Sub

"Felhantering meddelande
OM Err.Number <> 0 sedan
MsgBox "du angett något felaktigt. Försök igen. ", 0 + 16," Ooopps... "
WScript.quit()
SLUT OM