Imports System Imports System.IO Public Class WeekCLN ''Change name comment on 2023 ''====================================================== '' '' Project Making WeekCLN For Windows10 '' From 2018 January to April '' And Brushed up in August '' '' Added new functions in 2019June '' BlushUp from 2022November-2023January '' '' CopyRight MIYAMA. 2018-2023 '' www.geocities.jp/kaz_kimijima '' (geocities was closed servius) '' KazutomiMiyama@outlook.jp '' ''====================================================== '' '' event memo outline (only mainly) '' '' *form load '' global parameters declear '' controls declear '' configurational file read and init '' controls location font tune '' decide now week''s sundaydate '' weekread '' '' *textbox lostfocus event '' this one text box content write '' if expence pay-window, tune number and calculation '' '' *paging function button click(back and next ,fix) '' [weekwrite] '' now contents write '' this week sum file write(now week, textbox contents > sumfile) '' with separate store name logic (for pay windows) '' '' new weeks' sunday's date calcuration '' (without FixBTN Event) '' '' [weekread] '' new weeks contents read '' new week sum file write(new week,each small weekdayfiles > sumfile) '' '' *Fix btn is no sunday calcurational pagemoving '' weekwrite '' weekread '' '' *page jump button click '' input new date (input by message box) '' new date logical check and sundaydate calcuration '' weekread '' '' *form close '' weekwrite '' *configrational renewal tune '' input parameters '' controls location font tune '' configrational file write '' (config file on c:\dayly_folder default.) ''====================================================== '' '' Prameters declear '' ''====================================================== ''--Component------------------------------------------- '' xxx() style as array Private DefTXT() As TextBox 'Default Text Box Private WeeksCalcSumTXT As TextBox Private ColorAndFontBaseTXT As TextBox Private FuncBTN() As Button Private ExitBTN As Button Private FontAndBackcolorBTN As Button Private FixPitchFontCHK As CheckBox Private ColorCNFGInitBTN As Button Private DispLongDayNameCHK As CheckBox Private MSGJPNChangeCHK As CheckBox Private JumpPageBTN As Button ''2019June Private YearYYYYPermitCHK As CheckBox ''2019June ''--For Component Composition, Initializing Parametors-- Private TXTBOXKindName(5 - 1) As String Private BTNKindName(3 - 1) As String Private SevenTXTsTotalHeight As Integer ''TotalHeight Private FBTNH As Integer ''FuncBTN height Private TXTH As Integer ''TXT height Private labelTXTH As Integer ''labelTXTHeight Private TW As Integer ''Total width Private labelTXTW As Integer ''TXT width Private TXTW As Integer ''TXT width Private FBTNW As Integer ''Func BTN width Private SundayColor As Color Private SaturdayColor As Color Private WeekDayColor As Color Private LabelTXTWidthRate As Double Private WeekDaysKindSTR(7 - 1) As String ''--For logic parameter--------------------------------- Private DEFTXT_Write_Read_OperationContinueFlag As Boolean Private TextNameTrunk As String ''--For Separating store name string logical zone------- ''added on 2019June Private tmpStoreNameGlobal As String Private DisCoverStoreNameFlagGlobal As Boolean ''--Char mark to avoid to miss-type--------------------- Private SlushCHR As String = "/" Private BSlushCHR As String = "\" ''back slush Private CummaCHR As String = "," Private VacantCHR As String = "" Private PeriodCHR As String = "." Private SpaceCHR As String = " " Private ZeroCHR As String = "0" Private EqualCHR As String = "=" Private MinusCHR As String = "-" ''--For date calculation-------------------------------- ''Private tmpTodayGlobal As Date Private tmpTodayGlobal As Date ''2019June Private ThisWeeksSundayDate As Date Private DayFileNameTrunk(7 - 1) As String ''--For calcTXTfiles------------------------------------ Private TodaysCalcSumBuf(7 - 1) As Double Private tmpTodaysCalcSumBUFGlobal As Double Private WeeksCalcSumBUFGlobal As Double ''--FileName system string------------------------------ Private DirPath As String ''Private TXTKindSTR_wcpt(2 - 1) As String ''--FileName''s STRparts--------------------------------- Private TailFileName_dot_ExtentionSTR(2 - 1) As String '' day filename as each local string no needs existence on global zone ''--Week StakeSTR and calc sum filename --- Private TailStakeFileName_dot_ExtentionSTR(2 - 1) As String Private WeekStakeFileName(2 - 1) As String Private WeekStakeFile_StreamWriter As StreamWriter Private TotalSumFileName(2 - 1) As String Private DayFileNameTrunkForDisplayWithSlush(7 - 1) As String ''--For color and font tune--- Private FontDialog_WeekCLN As New FontDialog Private CNFGFileName As String Private FormBackColorItemNameSTR As String = "FormBackColor" Private TextBackColorItemNameSTR As String = "TextBackColor" Private TextForeColorItemNameSTR As String = "TextForeColor" Private SundayColorItemNameSTR As String = "SundayColor" Private SaturdayColorItemNameSTR As String = "SaturdayColor" Private WeekdayColorItemNameSTR As String = "WeekdayColor" Private FormBackColorVALSTR As String = "FFFFF4" ''Light lemon yellow ''"D0D0D0" ''System-Gray Private TextBackColorVALSTR As String = "FFFFFF" Private TextForeColorVALSTR As String = "000000" Private SundayColorVALSTR As String = "FFF0F0" Private SaturdayColorVALSTR As String = "F4F4FF" Private WeekdayColorVALSTR As String = "D0D0D0" Private FixedPitchOnlyItemNameSTR As String = "FixedPitchOnly" Private FontNameItemNameSTR As String = "Font.Name" Private FontSizeItemNameSTR As String = "Font.Size" Private FormWidthItemNameSTR As String = "Form.Width" Private FormHeightItemNameSTR As String = "Form.Height" Private LabelTXTWidthRateItemNameSTR As String = "LabelTXTWidthRate" Private DispLongDayNameSTR As String = "DispLongDayName" Private MSGJPNChaSTR As String = "MSGJPN" Private YearYYYYPermitSTR As String = "YearYYYYPermit" ''--per form width etc... ------------------------------ Private FormWidthVALSTR As String = "650" Private FormHeightVALSTR As String = "1000" Private LabelTXTWidthRateVALSTR As String = "0.16" ''--MSG ENG/JPN----------------------------------------- Private MSGSTR As String ''------------------------------------------------------ ''====================================================== ''====================================================== '' '' Sub and Function '' ''====================================================== ''====================================================== ''====================================================== '' '' Zone of First Event And Initialize '' ''====================================================== Private Sub Form_Load( ByVal sender As Object, ByVal e As EventArgs) Handles MyBase.Load With Me ''no meaning with tablet mode .WindowState = FormWindowState.Normal .ControlBox = True End With GetFirstFormPer() InitGlobalPer() InitFormControls() CHKExistWorkingDIR() GetThisWeeksSundayDate() ''YearYYYYPermitCHK.CheckState = 1 ''this active selection confusion, ''I donot know this reason, ReadPerFromCNFG() FileNameTuneFromYYYYMode() ''2019June WeekdaysNameTune() MakeFileNameTrunk() ChangeToValFromVALSTR() ReflectFromColorAndFontBaseTXT() RetuneComponentLocation() OneWeekRead() ''-------------------------- With MSGJPNChangeCHK MSGSTR = VacantCHR Select Case .CheckState Case 0 MSGSTR = " Having to form-size-tuning function, " + vbCrLf + "Please make it is worked on not tablet mode." + vbCrLf + "Resize-function and width parameters " + vbCrLf + "are no meaning on tablet mode." Case 1 MSGSTR = "フォームのサイズを任意に変更する機能はwindows10のタブレットモードでは使用できません。" + vbCrLf + "デスクトップモードに変更する必要があります。" End Select MessageBox.Show(MSGSTR, Me.Text) End With ''-------------------------- DefTXT(2 * 7 + 0).SelectionLength = 0 End Sub Private Sub GetFirstFormPer() ''This permeters will be overwrited ''By CNFG data. With Me .Width = 650 .Height = 1000 End With FormBackColorVALSTR = "FFFFF4" TextBackColorVALSTR = "FFFFFF" TextForeColorVALSTR = "000000" SundayColorVALSTR = "FFF0F0" SaturdayColorVALSTR = "F4F4FF" FormWidthVALSTR = "650" FormHeightVALSTR = "1000" LabelTXTWidthRateVALSTR = "0.16" End Sub Private Sub InitGlobalPer() Dim i As Integer DirPath = "C:\daily_folder" ''TXTKindSTR_wcpt(0) = "wc"''2019June ''TXTKindSTR_wcpt(1) = "pt" ''For i = 0 To 2 - 1 ''TailFileName_dot_ExtentionSTR(i) = ''TXTKindSTR_wcpt(i) + ".txt" ''Next i TotalSumFileName(0) = "Daily.TXT" TotalSumFileName(1) = "SumSheet.CSV" CNFGFileName = DirPath + "\CNFG.TXT" DEFTXT_Write_Read_OperationContinueFlag = False End Sub Private Sub InitFormControls() With Me .Text = "WeekCLN For Win10 R 2023" .DefTXT = New TextBox(7 * 5 - 1) {} .FuncBTN = New Button(3 - 1) {} End With Me.SuspendLayout() ''------ Dim WeekDaysKindNumber As Integer Dim TXTKindNumber As Integer Dim BTNNumber As Integer Dim NowMemberNum As Integer Dim tmpSTR As String tmpSTR = VacantCHR AddHandler Me.Click, AddressOf Me.FormSizeTune For TXTKindNumber = 0 To 5 - 1 Select Case TXTKindNumber Case 0 tmpSTR = "DayNameTXT" Case 1 tmpSTR = "DayKindNameTXT" Case 2 tmpSTR = "DailyTXT" Case 3 tmpSTR = "CalcTXT" Case 4 tmpSTR = "CalcSumTXT" End Select TXTBOXKindName(TXTKindNumber) = tmpSTR For WeekDaysKindNumber = 0 To 7 - 1 ''(from sun to sat) NowMemberNum = TXTKindNumber * 7 + WeekDaysKindNumber DefTXT(NowMemberNum) = New TextBox With DefTXT(NowMemberNum) .Name = WeekDaysKindNumber.ToString + tmpSTR ''actional id .Text = vbCrLf ''avoid null err.. .TextAlign = HorizontalAlignment.Right ''^ only daily DEFTXTKindINT=2 case of it,left ''.Font.Size = New Size(16) If TXTKindNumber = 0 Then ''DayNameTXT ''remain logic End If If TXTKindNumber = 2 Then ''DailyTXT .Multiline = True .ScrollBars = ScrollBars.Both .TextAlign = HorizontalAlignment.Left End If If TXTKindNumber = 3 Then ''CalcTXT .Multiline = True .ScrollBars = ScrollBars.Both End If If TXTKindNumber = 4 Then ''CalcSumTXT ''remain logic End If ''AddHandler .Click, AddressOf Me.FormSizeTune ''no need really AddHandler .LostFocus, AddressOf Me.DefTXT_LostFocus AddHandler .KeyUp, AddressOf Me.TextSelectSteelCondition ''AddHandler .TextChanged, AddressOf Me.DefTXT_TextChanged ''eventing loop is so fragier, '' for actual error End With Next WeekDaysKindNumber Next TXTKindNumber TXTTabIndexTune() ''TabIndex rule''comment on 2023 '' ''DefTXT array--- ''weekdaykind '' Date '' Day Pey sum ''<- 5 kinds TXTBOX touse-> ''| 0 || || || || | A ''| 1 || || || || | | ''| 2 || || || || | ''| 3 || || || || | ''| 4 || || || || | 7 weekdays ''| 5 || || || || | | ''| 6 || || || || | V '' ^=5*7-1 :tabindex '' 5*7=35, '' ''FunBTN() is array, 3kinds '' ''BackBTN 35+0=35 ''FixBTN 35+1=36 ''NextBTN 35+2=37 '' ''WeeksCalcSumTXT 38 ''ExitBTN 39 ''FontAndBackcolorBTN 40 ''FixPitchFontCHK 41 '' ''ColorAndFontBaseTXT Hidden Object unvisible '' ''ColorCNFGInitBTN 42 ''DispLongDayNameCHK 43 ''MSGJPNChangeCHK 44 ''JumpPageBTN 45 ''YearYYYYPermitCHK 46 =37+10-1 For BTNNumber = 0 To 3 - 1 tmpSTR = VacantCHR Select Case BTNNumber Case 0 tmpSTR = "BackWeekBTN" Case 1 tmpSTR = "FixBTN" Case 2 tmpSTR = "NextWeekBTN" End Select BTNKindName(BTNNumber) = tmpSTR FuncBTN(BTNNumber) = New Button With FuncBTN(BTNNumber) .Name = BTNNumber.ToString + tmpSTR .TabIndex = 35 + BTNNumber ''action id Select Case BTNNumber Case 0 .Text = "BackWeek &B" Case 1 .Text = "FiX &F" Case 2 .Text = "NextWeek &N" End Select AddHandler Me.FuncBTN(BTNNumber).Click, AddressOf Me.FuncBTN_Click End With Next BTNNumber ''37 is 35 + 2 ''=5*7+3-1 deftxt & funcbtn item number. WeeksCalcSumTXT = New TextBox With WeeksCalcSumTXT .TextAlign = HorizontalAlignment.Right .TabIndex = 37 + 1 End With ExitBTN = New Button With ExitBTN .Text = "Exit &X" .TabIndex = 37 + 2 AddHandler Me.ExitBTN.Click, AddressOf Me.ExitBTN_Click End With FontAndBackcolorBTN = New Button With FontAndBackcolorBTN .Text = "Tune &T" .TabIndex = 37 + 3 AddHandler .Click, AddressOf Me.TuneFontAndColor_Click End With FixPitchFontCHK = New CheckBox With FixPitchFontCHK .Text = "FixPitF &I" .CheckState = 0 .TabIndex = 37 + 4 AddHandler .Click, AddressOf Me.FixPitchFontCHK_Click End With ColorAndFontBaseTXT = New TextBox With ColorAndFontBaseTXT .Visible = False End With ColorCNFGInitBTN = New Button With ColorCNFGInitBTN .Text = "ColorCLR &C" .TabIndex = 37 + 5 AddHandler .Click, AddressOf Me.ColorCNFGInitBTN_Click End With DispLongDayNameCHK = New CheckBox With DispLongDayNameCHK .Text = "LongDayName &L" .CheckState = 0 .TabIndex = 37 + 6 AddHandler .Click, AddressOf Me.DispLongDayNameCHK_Click End With MSGJPNChangeCHK = New CheckBox With MSGJPNChangeCHK .Text = "MSGJPN &M" ''J"2019June .CheckState = 0 .TabIndex = 37 + 7 AddHandler .Click, AddressOf Me.MSGJPNChangeCHK_Click End With JumpPageBTN = New Button ''2019June With JumpPageBTN .Text = "JumpPage &J" .TabIndex = 37 + 8 AddHandler .Click, AddressOf Me.JumpPageBTN_Click End With YearYYYYPermitCHK = New CheckBox ''2019June With YearYYYYPermitCHK .Text = "10^4YearsPermit &Y" ''.CheckState = 0 ''1 .TabIndex = 37 + 10 - 1 AddHandler .Click, AddressOf Me.YearYYYYPermitCHK_Click End With AddHandler Me.FormClosed, AddressOf Me.FormClose With Me.Controls .AddRange(Me.DefTXT) ''range'' for array .AddRange(Me.FuncBTN) .Add(Me.WeeksCalcSumTXT) .Add(Me.ExitBTN) .Add(Me.FontAndBackcolorBTN) .Add(Me.FixPitchFontCHK) .Add(Me.ColorAndFontBaseTXT) .Add(Me.ColorCNFGInitBTN) .Add(Me.DispLongDayNameCHK) .Add(Me.MSGJPNChangeCHK) .Add(Me.JumpPageBTN) ''2019june .Add(Me.YearYYYYPermitCHK) ''2019June End With Me.ResumeLayout(False) ''----- With FontDialog_WeekCLN .Font = ColorAndFontBaseTXT.Font .Color = ColorAndFontBaseTXT.ForeColor .MaxSize = 24 .MinSize = 9 .FontMustExist = True .ShowColor = True .ShowHelp = True .ShowApply = True .ScriptsOnly = True ''only choice for cnfg .FixedPitchOnly = False ''True /change on 2019June, End With With DefTXT(2 * 7 + 0) .Focus() .SelectionLength = 0 End With End Sub '' Private Sub TXTTabIndexTune() Dim i, j, KindInt, index, DailyCulcTXTIndex As Integer ''total init For i = 0 To 5 * 7 - 1 DefTXT(i).TabIndex = i Next i ''DailyCulc Index Tuning DailyCulcTXTIndex = 2 * 7 - 1 For j = 0 To 7 - 1 For KindInt = 2 To 3 index = KindInt * 7 + j DailyCulcTXTIndex += 1 DefTXT(index).TabIndex = DailyCulcTXTIndex Next KindInt Next j End Sub Private Sub FormSizeTune() ''to get now size of form''comment on 2023 FormWidthVALSTR = Me.Width.ToString FormHeightVALSTR = Me.Height.ToString RetuneComponentLocation() WritePerToCNFG() End Sub Private Sub RetuneComponentLocation() Dim DEFTXTKindINT As Integer Dim i, BTNNumber As Integer Dim FuncBTNHeightRate As Double = 0.07 ''0.05 Dim labelTXTHeightRate As Double = 0.25 ''Dim labelTXTWidthRate As Double = 0.16 ''globalized ''will change to tunable mode, With Me .Size = New Size( Val(FormWidthVALSTR), Val(FormHeightVALSTR)) LabelTXTWidthRate = Val(LabelTXTWidthRateVALSTR) End With ''20 pixels for margin''comment on 2023 FBTNH = (Me.Height - 20) * FuncBTNHeightRate SevenTXTsTotalHeight = (Me.Height - 20) - FBTNH TXTH = Int(SevenTXTsTotalHeight / (7 * 1.03)) ''7 days labelTXTH = Int(TXTH * labelTXTHeightRate) ''labelTXT is small than normal TXTs''comment on 2023 TW = Me.Width FBTNW = Int(TW / 3) ''3 pieces buttons. labelTXTW = Int(TW * LabelTXTWidthRate) TXTW = Int(TW * (0.5 - LabelTXTWidthRate) * 0.95) ''This equation is correct??''comment on 2023 For DEFTXTKindINT = 0 To 5 - 1 ''DefTXT's kind is 5''comment on 2023 For i = 0 To 7 - 1 With DefTXT(DEFTXTKindINT * 7 + i) .Width = labelTXTW .Height = labelTXTH ''Day & Pay TXT''comment on 2023 If DEFTXTKindINT = 2 Or DEFTXTKindINT = 3 Then .Width = TXTW .Height = TXTH End If ''Controlls' composition''comment on 2023 '' ''[ 0 ]| || | A ''[ 1 ]| 2 || 3 |[ 4 ] V oneweekdayBlock. '' ''0 weekdaykind ''1 dayname ''2 daycommenttxt ''3 expencepaytxt ''4 todayssumindicate '' number is "DEFTXTKindINT" Select Case DEFTXTKindINT Case 0 .Left = 0 .Top = i * TXTH Case 1 .Left = 0 .Top = i * TXTH + labelTXTH Case 2 .Left = labelTXTW .Top = i * TXTH Case 3 .Left = labelTXTW + TXTW .Top = i * TXTH Case 4 .Left = labelTXTW + TXTW * 2 .Top = i * TXTH + labelTXTH * 3 End Select End With Next i Next DEFTXTKindINT With WeeksCalcSumTXT .Size = New Size(labelTXTW, labelTXTH) .Left = 0 .Top = 6 * TXTH + labelTXTH * 3 End With ExitBTN.Size = New Size(labelTXTW, labelTXTH) FontAndBackcolorBTN.Size = New Size(labelTXTW, labelTXTH) FixPitchFontCHK.Size = New Size(labelTXTW, labelTXTH) ColorCNFGInitBTN.Size = New Size(labelTXTW, labelTXTH) DispLongDayNameCHK.Size = New Size(labelTXTW, labelTXTH) MSGJPNChangeCHK.Size = New Size(labelTXTW, labelTXTH) JumpPageBTN.Size = New Size(labelTXTW, labelTXTH) ''2019June YearYYYYPermitCHK.Size = New Size(labelTXTW, labelTXTH) ''2019June Dim RightGroupLeftVAL As Double = labelTXTW + TXTW * 2 ExitBTN.Left = RightGroupLeftVAL FontAndBackcolorBTN.Left = RightGroupLeftVAL FixPitchFontCHK.Left = RightGroupLeftVAL ColorCNFGInitBTN.Left = RightGroupLeftVAL DispLongDayNameCHK.Left = RightGroupLeftVAL MSGJPNChangeCHK.Left = RightGroupLeftVAL JumpPageBTN.Left = RightGroupLeftVAL ''2019June YearYYYYPermitCHK.Left = RightGroupLeftVAL ''2019June ExitBTN.Top = labelTXTH * 0 FontAndBackcolorBTN.Top = labelTXTH * 1 FixPitchFontCHK.Top = labelTXTH * 2 ColorCNFGInitBTN.Top = labelTXTH * 4 DispLongDayNameCHK.Top = labelTXTH * 5 MSGJPNChangeCHK.Top = labelTXTH * 6 JumpPageBTN.Top = labelTXTH * 8 ''2019June YearYYYYPermitCHK.Top = labelTXTH * (10 - 1) ''2019June ColorAndFontBaseTXT.Visible = False ''All TXTBOX color & font parameter's ''reference base TXTBOX(invisible) ''Especially it is needed Font parameters' copied ''for using to copy Font-Object structure whole. ''comment on 2023 ''Week paging BTNs and Fix date btn for wow week ''(paging btns also alwayd this weeks data)''comment on 2023 For BTNNumber = 0 To 3 - 1 With FuncBTN(BTNNumber) .Size = New Size(FBTNW, FBTNH) .Location = New Point( FBTNW * BTNNumber, TXTH * 7) End With Next BTNNumber End Sub Private Sub WeekdaysNameTune() Dim i As Integer Dim tmpDayName As String = VacantCHR With DispLongDayNameCHK For i = 0 To 7 - 1 If .CheckState = 0 Then Select Case i Case 0 tmpDayName = "SUN" Case 1 tmpDayName = "MON" Case 2 tmpDayName = "THU" Case 3 tmpDayName = "WED" Case 4 tmpDayName = "THR" Case 5 tmpDayName = "FRI" Case 6 tmpDayName = "SAT" End Select End If If .CheckState = 1 Then Select Case i Case 0 tmpDayName = "Sunday" Case 1 tmpDayName = "Monday" Case 2 tmpDayName = "Thusday" Case 3 tmpDayName = "Wednesday" Case 4 tmpDayName = "Thursday" Case 5 tmpDayName = "Friday" Case 6 tmpDayName = "Saturday" End Select End If WeekDaysKindSTR(i) = tmpDayName DefTXT(1 * 7 + i).Text = tmpDayName Next i End With End Sub ''====================================================== '' '' Color and Font Tuning '' ''====================================================== Private Sub ReflectColorAndFont() '' ReflectColorToBaseTXT() ReflectFontToBaseTXT() ReflectFromColorAndFontBaseTXT() End Sub Private Sub ReflectFontOnly() ''it was called only from fixpichfont selection chkbox ''comment on 2023 ReflectFontToBaseTXT() ReflectFromColorAndFontBaseTXT() End Sub Private Sub ReflectColorToBaseTXT() InputDialogueForPer() ChangeToValFromVALSTR() ''global End Sub Private Sub InputDialogueForPer() Dim EJ As Integer = 0 ''ENG/JPN_CHKint E=0,J=1 EJ = MSGJPNChangeCHK.CheckState MSGSTR = VacantCHR Select Case EJ''Changed 2023 Case 0 MSGSTR = "Color tuning will be started, Please donot click calcel button" + vbCrLf + "Then, Each color mode will became to Gray Mode." Case 1 MSGSTR = "色彩とフォントの設定を調整します。色彩調整時キャンセルボタンを押し下すと色彩は灰色に調整されます" End Select MessageBox.Show(MSGSTR, Me.Text) ''-------------------------- MSGSTR = VacantCHR Select Case EJ Case 0 MSGSTR = "Please input Form BackGround Color" Case 1 MSGSTR = "フォームの色彩を入力してください" End Select FormBackColorVALSTR = CHKenoughColor(InputBox( FormBackColorItemNameSTR, MSGSTR, FormBackColorVALSTR)) Select Case EJ Case 0 MSGSTR = "Please input Text BackGround Color" Case 1 MSGSTR = "テキストの背景色を入力してください" End Select TextBackColorVALSTR = CHKenoughColor(InputBox( TextBackColorItemNameSTR, MSGSTR, TextBackColorVALSTR)) Select Case EJ Case 0 MSGSTR = "Please input Text-Letter Color" Case 1 MSGSTR = "テキストの文字の色を入力してください" End Select TextForeColorVALSTR = CHKenoughColor(InputBox( TextForeColorItemNameSTR, MSGSTR, TextForeColorVALSTR)) Select Case EJ Case 0 MSGSTR = "Please input Sunday's BackGround Color" Case 1 MSGSTR = "日曜日の背景色を入力してください" End Select SundayColorVALSTR = CHKenoughColor(InputBox( SundayColorItemNameSTR, MSGSTR, SundayColorVALSTR)) Select Case EJ Case 0 MSGSTR = "Please input Saturday's BackGround Color" Case 1 MSGSTR = "土曜日の背景色を入力して下さい" End Select SaturdayColorVALSTR = CHKenoughColor(InputBox( SaturdayColorItemNameSTR, MSGSTR, SaturdayColorVALSTR)) Select Case EJ Case 0 MSGSTR = "Please input Form Width by Pixel unit" Case 1 MSGSTR = "フォームの幅をピクセル単位で入力してください" End Select FormWidthVALSTR = Trim(InputBox(FormWidthItemNameSTR, MSGSTR, FormWidthVALSTR)) Select Case EJ Case 0 MSGSTR = "Please input Form Height by Pixel unit" Case 1 MSGSTR = "フォームの高さをピクセル単位で入力してください" End Select FormHeightVALSTR = Trim(InputBox(FormHeightItemNameSTR, MSGSTR, FormHeightVALSTR)) Select Case EJ Case 0 MSGSTR = "Please input Rate for label-text to form width, enough rate is 0.1-0.16" Case 1 MSGSTR = "ラベル用テキストの幅を調整します。推奨0.1-0.16" End Select LabelTXTWidthRateVALSTR = Trim(InputBox(LabelTXTWidthRateItemNameSTR, MSGSTR, LabelTXTWidthRateVALSTR)) End Sub Private Sub ChangeToValFromVALSTR() Me.BackColor = MakeRealColor(FormBackColorVALSTR) With ColorAndFontBaseTXT .BackColor = MakeRealColor(TextBackColorVALSTR) .ForeColor = MakeRealColor(TextForeColorVALSTR) End With SundayColor = MakeRealColor(SundayColorVALSTR) SaturdayColor = MakeRealColor(SaturdayColorVALSTR) With Me .Width = Val(Trim(FormWidthVALSTR)) .Height = Val(Trim(FormHeightVALSTR)) End With LabelTXTWidthRate = Val(Trim(LabelTXTWidthRateVALSTR)) End Sub Private Sub ReflectFontToBaseTXT() With FontDialog_WeekCLN If .ShowDialog() = DialogResult.OK Then ColorAndFontBaseTXT.Font = .Font End If End With End Sub Private Function CHKenoughColor(tmpSTR As String) As String Dim SuitChrBool As Boolean Dim SuitSTRStakeINT As Integer Dim ChrASC As Integer SuitSTRStakeINT = 0 SuitChrBool = False If Not tmpSTR.Length = 6 Then ''-------------------------- With MSGJPNChangeCHK MSGSTR = VacantCHR Select Case .CheckState Case 0 MSGSTR = " Strings length is not suitable" + vbCrLf + "It is needed as 6 charactors ,for example 'FFFFFF'" Case 1 MSGSTR = "文字列の長さが適切ではありません文字列はFFFFFFのように半角6文字で入力してください" End Select MessageBox.Show(MSGSTR, Me.Text) End With ''-------------------------- SuitSTRStakeINT = 1 Else Dim StakeSTR As String = VacantCHR Dim tmpCHR As String = VacantCHR For i = 1 To 6 SuitChrBool = False tmpCHR = Mid(tmpSTR, i, 1) ChrASC = Asc(tmpCHR) If Asc("0") <= ChrASC And ChrASC <= Asc("9") Then SuitChrBool = True End If If Asc("A") <= ChrASC And ChrASC <= Asc("F") Then SuitChrBool = True End If If Asc("a") <= ChrASC And ChrASC <= Asc("f") Then SuitChrBool = True ChrASC = ChrASC - Asc("a") + Asc("A") tmpCHR = Chr(ChrASC) End If If SuitChrBool = False Then SuitSTRStakeINT += 1 End If StakeSTR += tmpCHR Next i tmpSTR = StakeSTR End If If Not SuitSTRStakeINT = 0 Then ''-------------------------- With MSGJPNChangeCHK MSGSTR = VacantCHR Select Case .CheckState Case 0 MSGSTR = "it was no suitable strings, " + vbCrLf + "the color-mode will be tuned to gray" Case 1 MSGSTR = "文字列の内容が適切ではありません指定色彩は灰色に設定されます" End Select MessageBox.Show(MSGSTR, Me.Text) End With ''-------------------------- tmpSTR = "D0D0D0" End If CHKenoughColor = tmpSTR End Function Private Function MakeRealColor(SuitableSTR As String) As Color Dim tmpVal As Double = Val("&HFF" + SuitableSTR) MakeRealColor = Color.FromArgb(tmpVal) End Function Private Sub ReflectFromColorAndFontBaseTXT() Dim i As Integer Dim DEFTXTKindINT As Integer Dim j As Integer Dim BH As Color '' BackColor-Holded Dim tmpBKColor As Color Dim ST As TextBox ''Sample TEXTBOX ST = ColorAndFontBaseTXT With ST BH = .BackColor End With For DEFTXTKindINT = 0 To 5 - 1 For i = 0 To 7 - 1 j = DEFTXTKindINT * 7 + i ''whole coplied With DefTXT(j) tmpBKColor = BH Select Case i Case 0 tmpBKColor = SundayColor Case 7 - 1 tmpBKColor = SaturdayColor End Select .BackColor = tmpBKColor .ForeColor = ST.ForeColor .Font = ST.Font End With Next i Next DEFTXTKindINT With WeeksCalcSumTXT .BackColor = ST.BackColor .ForeColor = ST.ForeColor .Font = ST.Font End With End Sub ''====================================================== '' '' CNFG Reading and writting '' comment on 2023 '' ''====================================================== Private Sub ReadPerFromCNFG() Dim CNFGRS As StreamReader Dim tmpSTR As String Dim EleSTR As String Dim tmpBool As Boolean Dim tmpFontName As String = VacantCHR Dim tmpFontSize As Single Dim tmpINT As Integer ''Nexr CHRs are not global ''comment on 2023 Dim CheckedSTR As String = "Checked" Dim UnCheckedSTR As String = "UnChecked" '' CNFG.txt style ''<-- ARR length = 2 - --> ''| |crlf ''|[itemSTR]=[Parametor]|crlf ''| |crlf '' ''1* ReadLine Function reads on one linestep ''2* Split Function uses equal chr as delimitor '' ArrayIndix 0 is itmelement's kind. '' '' ArrayIndex 1 is parametor '' (Index Over 2 is throw off '' therefore, it isnot permitted CNFG.txt '' is edited by manual method generally. '' the reading method desolved only '' configurational files auto-generated basical '' on first planning.)''comment on 2023 tmpFontSize = 1 If File.Exists(CNFGFileName) = True Then CNFGRS = New StreamReader(CNFGFileName) While CNFGRS.EndOfStream = False tmpSTR = Trim(CNFGRS.ReadLine()) If 0 < InStr(tmpSTR, EqualCHR) Then Dim tmpARR() As String = tmpSTR.Split(EqualCHR) If tmpARR.Length = 2 Then EleSTR = tmpARR(1) Select Case tmpARR(0) Case FormBackColorItemNameSTR FormBackColorVALSTR = EleSTR Me.BackColor = MakeRealColor( CHKenoughColor(EleSTR)) Case TextBackColorItemNameSTR TextBackColorVALSTR = EleSTR ColorAndFontBaseTXT.BackColor = MakeRealColor( CHKenoughColor(EleSTR)) Case TextForeColorItemNameSTR TextForeColorVALSTR = EleSTR ColorAndFontBaseTXT.ForeColor = MakeRealColor( CHKenoughColor(EleSTR)) Case SundayColorItemNameSTR SundayColorVALSTR = EleSTR Case SaturdayColorItemNameSTR SaturdayColorVALSTR = EleSTR Case FixedPitchOnlyItemNameSTR tmpBool = False tmpINT = 0 If EleSTR = "True" Then tmpINT = 1 tmpBool = True End If FixPitchFontCHK.CheckState = tmpINT FontDialog_WeekCLN.FixedPitchOnly = tmpBool Case FontNameItemNameSTR tmpFontName = EleSTR Case FontSizeItemNameSTR tmpFontSize = Val(EleSTR) Case FormWidthItemNameSTR FormWidthVALSTR = EleSTR Case FormHeightItemNameSTR FormHeightVALSTR = EleSTR Case LabelTXTWidthRateItemNameSTR LabelTXTWidthRateVALSTR = EleSTR Dim tmpRate = Val(EleSTR) If tmpRate <= 0 Or 1 <= tmpRate Then ''-------------------------- With MSGJPNChangeCHK MSGSTR = VacantCHR Select Case .CheckState Case 0 MSGSTR = "It is not suitable value, it will be fixed to 0.16" Case 1 MSGSTR = "入力された値は適切ではありません値は0.16に設定されます。" End Select MessageBox.Show(MSGSTR, Me.Text) End With ''------------------------- LabelTXTWidthRateVALSTR = Trim("0.16") End If Case DispLongDayNameSTR With DispLongDayNameCHK If EleSTR = CheckedSTR Then .CheckState = 1 End If If EleSTR = UnCheckedSTR Then .CheckState = 0 End If End With Case MSGJPNChaSTR With MSGJPNChangeCHK If EleSTR = CheckedSTR Then .CheckState = 1 End If If EleSTR = UnCheckedSTR Then .CheckState = 0 End If End With Case YearYYYYPermitSTR ''MessageBox.Show(EleSTR) With YearYYYYPermitCHK If EleSTR = CheckedSTR Then .CheckState = 1 End If If EleSTR = UnCheckedSTR Then .CheckState = 0 End If End With ''Call FileNameTuneFromYYYYMode() End Select Dim tmpFont As Font = New Font(tmpFontName, tmpFontSize) FontDialog_WeekCLN.Font = tmpFont ColorAndFontBaseTXT.Font = tmpFont ''ReflectFromPerBaseTXT() End If End If End While CNFGRS.Close() End If End Sub Private Sub FileNameTuneFromYYYYMode() With YearYYYYPermitCHK Select Case .CheckState Case 0 TailFileName_dot_ExtentionSTR(0) = "wc.txt" TailFileName_dot_ExtentionSTR(1) = "pt.txt" TailStakeFileName_dot_ExtentionSTR(0) = PeriodCHR + "wc" TailStakeFileName_dot_ExtentionSTR(1) = PeriodCHR + "pt" Case 1 TailFileName_dot_ExtentionSTR(0) = PeriodCHR + "day" TailFileName_dot_ExtentionSTR(1) = PeriodCHR + "pay" TailStakeFileName_dot_ExtentionSTR(0) = PeriodCHR + "1wd" TailStakeFileName_dot_ExtentionSTR(1) = PeriodCHR + "1wp" End Select End With End Sub Private Sub WritePerToCNFG() Dim CNFGSW As StreamWriter CNFGSW = New StreamWriter(CNFGFileName) CNFGSW.WriteLine(FormBackColorItemNameSTR + EqualCHR + FormBackColorVALSTR) CNFGSW.WriteLine(SundayColorItemNameSTR + EqualCHR + SundayColorVALSTR) CNFGSW.WriteLine(SaturdayColorItemNameSTR + EqualCHR + SaturdayColorVALSTR) With ColorAndFontBaseTXT CNFGSW.WriteLine( TextBackColorItemNameSTR + EqualCHR + TextBackColorVALSTR) CNFGSW.WriteLine( TextForeColorItemNameSTR + EqualCHR + TextForeColorVALSTR) CNFGSW.WriteLine( FixedPitchOnlyItemNameSTR + EqualCHR + FontDialog_WeekCLN.FixedPitchOnly.ToString) CNFGSW.WriteLine( FontNameItemNameSTR + EqualCHR + .Font.Name.ToString) CNFGSW.WriteLine( FontSizeItemNameSTR + EqualCHR + .Font.Size.ToString) End With CNFGSW.WriteLine( FormWidthItemNameSTR + EqualCHR + FormWidthVALSTR) CNFGSW.WriteLine( FormHeightItemNameSTR + EqualCHR + FormHeightVALSTR) CNFGSW.WriteLine( LabelTXTWidthRateItemNameSTR + EqualCHR + LabelTXTWidthRateVALSTR) CNFGSW.WriteLine( DispLongDayNameSTR + EqualCHR + DispLongDayNameCHK.CheckState.ToString) CNFGSW.WriteLine( MSGJPNChaSTR + EqualCHR + MSGJPNChangeCHK.CheckState.ToString) CNFGSW.WriteLine( YearYYYYPermitSTR + EqualCHR + YearYYYYPermitCHK.CheckState.ToString) CNFGSW.Close() End Sub ''====================================================== '' '' Click Event ''comment on 2023 '' ''====================================================== Private Sub TuneFontAndColor_Click() ReflectColorAndFont() RetuneComponentLocation() WritePerToCNFG() End Sub Private Sub FixPitchFontCHK_Click() FontDialog_WeekCLN.FixedPitchOnly = FixPitchFontCHK.CheckState ReflectFontOnly() WritePerToCNFG() End Sub Private Sub ColorCNFGInitBTN_Click() GetFirstFormPer() ChangeToValFromVALSTR() ReflectFromColorAndFontBaseTXT() RetuneComponentLocation() WritePerToCNFG() End Sub Private Sub DispLongDayNameCHK_Click() WeekdaysNameTune() MakeFileNameTrunk() WritePerToCNFG() End Sub Private Sub MSGJPNChangeCHK_Click() WritePerToCNFG() End Sub Private Sub YearYYYYPermitCHK_Click() ''2019June OneWeekWrite() TextBoxClear() ''--msg logic--- MSGSTR = VacantCHR With YearYYYYPermitCHK Select Case .CheckState Case 0 With MSGJPNChangeCHK Select Case .CheckState Case 0 MSGSTR = "Year Expression Style FileName is" + vbCrLf + "YY 00-99 as XX00-XX99 for example 2000-2099" Case 1 MSGSTR = "ファイル形式を一世紀モードに変更します" + vbCrLf + "２０００年から２０９９年までのファイルを管理できます。" End Select End With Case 1 With MSGJPNChangeCHK Select Case .CheckState Case 0 MSGSTR = "Year Expression Style FileName is" + vbCrLf + "YYYY is 0001 to 9999." Case 1 MSGSTR = "ファイル形式を万年モードに変更します" + vbCrLf + "西暦元年から９９９９年までのファイルを管理できます。" End Select End With End Select End With MessageBox.Show(MSGSTR, Me.Text) ''-------------- FileNameTuneFromYYYYMode() MakeFileNameTrunk() OneWeekRead() WritePerToCNFG() End Sub ''====================================================== '' '' load and close and read and write '' contents and config imformation '' ''====================================================== ''------------------------------------------------------ '' contents write and config imformation saving '' when form closng... ''------------------------------------------------------ Private Sub ExitBTN_Click() '' Close Logic ReNewal on2023 Me.Close() End Sub Private Sub FormClose() MakeFileNameTrunk() OneWeekWrite() WritePerToCNFG() End Sub ''====================================================== '' '' event driven logic readinig and saving and '' number culcuration '' ''====================================================== Private Sub DefTXT_LostFocus(ByVal sender As Object, ByVal e As EventArgs) ''safety function odd close Dim LogicSwitch As Boolean = True If LogicSwitch = True Then If DEFTXT_Write_Read_OperationContinueFlag = False Then Dim tstSTR As String = CType(sender, TextBox).Name Dim i As Integer = Val(Mid(tstSTR, 1, 1)) Dim DEFTXTKindINT As Integer = -1 Dim FullPathFileName As String = VacantCHR ''important! do not remove this comment---- ''Daily field If 0 < InStr(tstSTR, TXTBOXKindName(2)) Then DEFTXTKindINT = 2 End If ''Calc field If 0 < InStr(tstSTR, TXTBOXKindName(3)) Then DEFTXTKindINT = 3 End If If Not DEFTXTKindINT = -1 Then FullPathFileName = DirPath + BSlushCHR + DayFileNameTrunk(i) + TailFileName_dot_ExtentionSTR( DEFTXTKindINT - 2) With sender DEFTXT_Write_Read_OperationContinueFlag = True Select Case DEFTXTKindINT Case 2 .text = RMVOverSeqCRLF(.text) Case 3 .text = StoreNameDelimitorPolicy(.text) ''2019June .text = RMVOverSeqZeroCMCRLF( TuneNumGenerator(.text)) TodaysCalcSumBuf(i) = tmpTodaysCalcSumBUFGlobal DefTXT(4 * 7 + i).Text = tmpTodaysCalcSumBUFGlobal.ToString End Select DEFTXT_Write_Read_OperationContinueFlag = False End With SimpleWrite( FullPathFileName, sender, i, DEFTXTKindINT, True) End If End If End If sender.selectionlength = 0 End Sub Private Sub TextSelectSteelCondition(ByVal sender As Object, e As KeyEventArgs) If e.KeyCode = Keys.Tab Then sender.selectionlength = 0 MakeWeeksCalcSum() End If End Sub Private Sub FuncBTN_Click(ByVal sender As Object, ByVal e As EventArgs) Dim tstSTR As String = CType(sender, Button).Name Dim tstINT As Integer = CInt(Mid(tstSTR, 1, 1)) OneWeekWrite() TextBoxClear() Select Case tstINT Case 0 Minus7Days() Case 2 Plus7Days() End Select MakeFileNameTrunk() OneWeekRead() End Sub Public Sub JumpPageBTN_Click() ''madein 2019 moving Location 2023 JumpPageUnderLogic() WritePerToCNFG() End Sub Public Sub JumpPageUnderLogic() ''2019June Dim tmpSTR As String = VacantCHR Dim NewDate As Date Dim Y, M, D As Integer ''Dim ASCintZeroCHR_1byte Dim A1b = 48 ''Dim ASCintZeroCHR_2byte Dim A2b = -32177 Dim StakeSTR As String '' Dim i As Integer Dim tmpCHR As String Dim AscCode As Integer Dim ChkOK As Boolean ''Dim Space4 As String = VacantCHR ''For I = 1 To 4 ''Space4 += SpaceCHR ''Next NewDate = New Date With MSGJPNChangeCHK Select Case .CheckState Case 0 MSGSTR = "Please input Day next Calender style" Case 1 MSGSTR = "移動する日付を西暦の次の形式で入力してください。" End Select End With tmpSTR = InputBox(MSGSTR + vbCrLf + vbCrLf + "yyyy/mm/dd", Me.Text) tmpSTR = StoreNameDelimitorPolicy(tmpSTR) tmpSTR = Replace(tmpSTR, SlushCHR, VacantCHR) ''The pre process removed slush chr. ''Therefore, it acts with no slush style :yyyymmdd. ''and, Not Num CHK with using ASC code. StakeSTR = VacantCHR For I = 1 To Len(tmpSTR) tmpCHR = Mid(tmpSTR, I, 1) AscCode = Asc(tmpCHR) If A2b <= AscCode And AscCode <= A2b + 10 - 1 Then AscCode = AscCode - A2b + A1b tmpCHR = Chr(AscCode) Else ''do nothing End If StakeSTR += tmpCHR Next tmpSTR = StakeSTR ChkOK = False If Len("yyyymmdd") = Len(tmpSTR) Then Y = Val(Mid(tmpSTR, 1, 4)) M = Val(Mid(tmpSTR, 5, 2)) D = Val(Mid(tmpSTR, 7, 2)) If 0 <= Y And Y <= 9999 Then If 1 <= M And M <= 12 Then Select Case M Case 2 If 1 <= D And D <= 29 Then ChkOK = True ''If D = 29 Then D = 28 as old logic Case 1, 3, 5, 7, 8, 10, 12 If 1 <= D And D <= 31 Then ChkOK = True Case 4, 6, 9, 11 If 1 <= D And D <= 30 Then ChkOK = True End Select End If End If End If If ChkOK = False Then With MSGJPNChangeCHK Select Case .CheckState Case 0 MSGSTR = "no suitable day style, please try again" Case 1 MSGSTR = "日付の形式が適切ではありません。再入力してください。" End Select End With MessageBox.Show(MSGSTR, Me.Text) Else tmpSTR = VacantCHR tmpSTR += Trim(CStr(Y)) + SlushCHR ''tmpSTR += vbTab + Space4''test?''comment on 2023 If 1 <= M And M <= 9 Then tmpSTR += "0" tmpSTR += Trim(CStr(M)) + SlushCHR ''tmpSTR += vbTab + Space4 If 1 <= D And D <= 9 Then tmpSTR += "0" tmpSTR += Trim(CStr(D)) ''donot understand 4 space indent reason ...?'' With MSGJPNChangeCHK Select Case .CheckState Case 0 MSGSTR = "Day Inputted was recognided, will go to jump" Case 1 MSGSTR = "入力された日付を解析しました。ジャンプします。" End Select End With MessageBox.Show(MSGSTR + vbCrLf + vbCrLf + tmpSTR, Me.Text) OneWeekWrite() ''Now week contents writting TextBoxClear() NewDate = tmpTodayGlobal With NewDate ''reback to AD 0 year and plus days inputted ''comment on 2023 NewDate = .AddYears(- .Year + Y) NewDate = .AddMonths(- .Month + M) NewDate = .AddDays(- .Day + D) ''leap day&year check If M = 2 And D = 29 Then If Val(NewDate.Month) = 3 Then With MSGJPNChangeCHK Select Case .CheckState Case 0 MSGSTR = "This year is not Leap Year, 2/29 is reflected as 3/01" Case 1 MSGSTR = "該当年はうるう年ではありません。２月２９日は３月１日として処理されました。" End Select End With MessageBox.Show(MSGSTR, Me.Text) End If End If ThisWeeksSundayDate = .AddDays(- .DayOfWeek) End With MakeFileNameTrunk() OneWeekRead() End If End Sub Private Sub TextBoxClear() Dim i As Integer Dim TXTBOXKindINT As Integer For TXTBOXKindINT = 0 To 5 - 1 For i = 0 To 7 - 1 DefTXT(i).Text = vbCrLf If TXTBOXKindINT = 1 Then DefTXT(i).Text = WeekDaysKindSTR(i) End If Next i Next TXTBOXKindINT End Sub ''====================================================== '' '' calc functional logic zone '' '' Add Minus Number Solutional Logic (2022) '' ''====================================================== Private Function TuneNumGenerator(tmpSTR As String) As String TuneNumGenerator = ValluizeNumSTR( TuneNumandDelimitor( StoreNameDelimitorPolicy(tmpSTR))) '' StoreNameDelimitorPolicy()... 2023 added End Function Private Function TuneNumandDelimitor( tmpSTR As String) As String ''2022 new, FullScratch '' '' Minus Number was realised to use (EXpencePaymentWindow) ''Style: '' ''CHRs Nums CHRs Nums ... '' ^ ^ ^ ^ '' cumma CRLF cumma CRLF Dim StakeSTR As String Dim tmpCHR As String Dim i As Integer Dim Length As Integer Dim ASCint As Integer Dim JustBeforeNumFlag As Boolean = False Dim NowNumFlag As Boolean = False Dim MinusCHRDiscoveredFlag As Boolean = False Dim MVChr As String = VacantCHR If tmpSTR = VacantCHR Then tmpSTR = SpaceCHR End If tmpSTR = PreTune(tmpSTR) Length = Len(tmpSTR) For i = 1 To Length tmpCHR = Mid(tmpSTR, i, 1) '------ tmpCHR = Num2to1Byte(tmpCHR) '----- ASCint = Asc(tmpCHR) NowNumFlag = False If 48 <= ASCint Then If ASCint <= 48 + 10 - 1 Then NowNumFlag = True End If End If If tmpCHR = PeriodCHR Then NowNumFlag = True End If '----- 'need init MVChr = VacantCHR If tmpCHR = MinusCHR Then MinusCHRDiscoveredFlag = True tmpCHR = VacantCHR MVChr = VacantCHR End If If MinusCHRDiscoveredFlag = True Then If Not tmpCHR = VacantCHR Then MVChr = MinusCHR MinusCHRDiscoveredFlag = False End If End If '----------- If JustBeforeNumFlag = False Then If NowNumFlag = False Then tmpCHR = MVChr + tmpCHR End If If NowNumFlag = True Then tmpCHR = CummaCHR + MVChr + tmpCHR End If End If If JustBeforeNumFlag = True Then If NowNumFlag = False Then tmpCHR = vbCrLf + MVChr + tmpCHR End If If NowNumFlag = True Then tmpCHR = tmpCHR End If End If '----- 'named period tuning If tmpCHR = PeriodCHR Then If JustBeforeNumFlag = False Then tmpCHR = ZeroCHR + tmpCHR End If End If JustBeforeNumFlag = NowNumFlag '----- StakeSTR += tmpCHR Next i If tmpCHR = PeriodCHR Then StakeSTR = StakeSTR + ZeroCHR End If StakeSTR += vbCrLf TuneNumandDelimitor = StakeSTR End Function Private Function PreTune(tmpSTR As String) As String ''2022 new Dim Length As Integer Dim i As Integer Dim tmpCHR As String Dim StakeSTR As String = VacantCHR Dim PF As Boolean 'DiscoverPeriod_flag Dim RMVF As Boolean PF = False Length = Len(tmpSTR) If Length = 0 Then 'not doing Else For i = 1 To Length tmpCHR = Mid(tmpSTR, i, 1) RMVF = False If PF = True Then If tmpCHR = PeriodCHR Then tmpCHR = VacantCHR Else ''tmpCHR = tmpCHR PF = False End If End If Select Case tmpCHR Case vbCr RMVF = True Case vbLf RMVF = True Case CummaCHR RMVF = True End Select If RMVF = True Then tmpCHR = VacantCHR StakeSTR += tmpCHR Next i End If PreTune = StakeSTR End Function Private Function Num2to1Byte(tmpCHR As String) As String ''2022 new Dim ASC0_1b As Integer = 48 Dim ASC0_2b As Integer = -32177 Dim ASCint As Integer If Not Len(tmpCHR) = 1 Then 'nothing tmpCHR = VacantCHR Else ASCint = Asc(tmpCHR) If ASC0_2b <= ASCint Then If ASCint <= ASC0_2b + 10 - 1 Then ASCint += -ASC0_2b + ASC0_1b tmpCHR = Chr(ASCint) End If End If End If Num2to1Byte = tmpCHR End Function Private Function ValluizeNumSTR(ContentsSTR As String) As String Dim tmpSTR As String Dim LineBUF() As String Dim TwinBUF(2 - 1) As String Dim StakeSTR As String Dim NumVallue As Double Dim i As Integer StakeSTR = VacantCHR tmpSTR = Replace(ContentsSTR, vbCrLf, vbCr) ''2022 tmpSTR = Replace(ContentsSTR, vbLf, VacantCHR) ''2022 LineBUF = tmpSTR.Split(vbCr) tmpTodaysCalcSumBUFGlobal = 0 For i = 0 To LineBUF.Length - 1 Dim tmpCummaBUF() = LineBUF(i).Split(CummaCHR) TwinBUF(0) = SpaceCHR ''avoid null err. TwinBUF(1) = ZeroCHR With tmpCummaBUF If 1 <= .Length Then TwinBUF(0) = tmpCummaBUF(0) If 2 <= .Length Then TwinBUF(1) = tmpCummaBUF(1) End With NumVallue = Val(TwinBUF(1)) tmpTodaysCalcSumBUFGlobal += NumVallue StakeSTR += TwinBUF(0) + CummaCHR + NumVallue.ToString + vbCrLf Next i ValluizeNumSTR = StakeSTR End Function Private Sub MakeWeeksCalcSum() Dim i As Integer WeeksCalcSumBUFGlobal = 0 For i = 0 To 7 - 1 WeeksCalcSumBUFGlobal += TodaysCalcSumBuf(i) Next i WeeksCalcSumTXT.Text = WeeksCalcSumBUFGlobal End Sub ''====================================================== '' '' File System Area '' ''====================================================== Private Sub CHKExistWorkingDIR() ''system, fileio are needed import If Directory.Exists(DirPath) = False Then Directory.CreateDirectory(DirPath) End If End Sub ''====================================================== '' '' Write Logic '' ''====================================================== '' '' WeekWriteSYStem(General digest) '' '' StakeFile's WriteStream for one week contsnts '' On Global Area '' '' sub subOneWeekWrite() global area '' | '' > One Week StakeSTR [open] '' sun to sat loop | '' | | '' | call > simplewrite() | '' | | '' | TextBoxWindow's contents '' | is written to File Stream '' | by one line step | '' | | '' | > each day file[open&write] '' | ------------------->write to one week Stake '' | < each day file [close] '' | end sub | '' week loop close | '' < One Week Stake[close] '' end sub '' ''comment on 2023 Private Sub OneWeekWrite() DEFTXT_Write_Read_OperationContinueFlag = True subOneWeekWrite(2) ''DailyTXT subOneWeekWrite(3) ''CalcTXT MakeWeeksCalcSum() MakeTotalSumTXT(2) MakeTotalSumTXT(3) DEFTXT_Write_Read_OperationContinueFlag = False End Sub Private Sub subOneWeekWrite(DEFTXTKindINT As Integer) Dim TailFileName_dot_ExtentionSTRLocal = VacantCHR Dim DEFTXTNum As Integer Dim FullPathFileName As String Dim i As Integer FullPathFileName = VacantCHR If DEFTXTKindINT = 2 Or DEFTXTKindINT = 3 Then ''DEFTXTKindINT is ''2 DailyTXT ''3 CalcTXT TailFileName_dot_ExtentionSTRLocal = TailFileName_dot_ExtentionSTR(-2 + DEFTXTKindINT) ''2,3 > 0,1 DEFTXTKindINT to TailName_ArrayIndex''comment on 2023 ''WeekStakeFileOperation week1_MakeStakeFileNameAndOpen(DEFTXTKindINT) '' Day Pay :DEFTXTnum(Index) '' 2*7 3*7 +0 '' | | '' | | '' V V +6 =7-1 '' For i = 0 To 7 - 1 ''WeekStakeFileOperation week2_WriteEachDayFileNametoStakeFile(i) DEFTXTNum = DEFTXTKindINT * 7 + i FullPathFileName = DirPath + BSlushCHR + DayFileNameTrunk(i) + TailFileName_dot_ExtentionSTRLocal With DefTXT(DEFTXTNum) Select Case DEFTXTKindINT Case 2 .Text = RMVOverSeqCRLF(.Text) Case 3 .Text = RMVOverSeqZeroCMCRLF( TuneNumGenerator(.Text)) TodaysCalcSumBuf(i) = tmpTodaysCalcSumBUFGlobal.ToString DefTXT(4 * 7 + i).Text = tmpTodaysCalcSumBUFGlobal.ToString End Select End With If DEFTXTKindINT = 2 Or DEFTXTKindINT = 3 Then SimpleWrite(FullPathFileName, DefTXT(DEFTXTNum), i, DEFTXTKindINT, False) End If ''If DEFTXTKindINT = 2 Then ''do nothing ''End If If DEFTXTKindINT = 3 Then With DefTXT(DEFTXTNum) ''.Text = TuneNumGenerator(.Text) ''WeekStakeFileOperation week3_WriteTodaysCalcSumToStakeFile(i) End With End If Next i ''WeekStakeFileOperation If DEFTXTKindINT = 3 Then week4_WriteThisWeekCalcSumToStakeFile() End If ''WeekStakeFileOperation week5_WriteStakeFileStreamClose() End If End Sub Private Sub AddStoreNameSplittedToWeekItemTXT(WeekDateIndex As Integer) ''no use End Sub Private Sub SimpleWrite(FullPathFilename As String, WriteTextBOX As TextBox, ID7 As Integer, DEFTXTKindINT As Integer, MonoFileWriteMode As Boolean) Dim SW As StreamWriter Dim tmpBuf As String = VacantCHR Dim LineARR() As String Dim LineBuf As String Dim CHKLineBUF As String Dim i As Integer tmpBuf = WriteTextBOX.Text ''2022 tmpBuf = Replace(tmpBuf, vbLf, VacantCHR) LineARR = tmpBuf.Split(vbCr) SW = New StreamWriter(FullPathFilename) If DEFTXTKindINT = 3 Then tmpStoreNameGlobal = VacantCHR DisCoverStoreNameFlagGlobal = False End If For Each LineBuf In LineARR SW.Write(LineBuf + vbCrLf) If MonoFileWriteMode = False Then ''WeekStakeFileOperation ''it needs this remover, textbox contents including any trash chips CHKLineBUF = LineBuf For i = 1 To 20 CHKLineBUF = Replace(CHKLineBUF, CummaCHR, VacantCHR) CHKLineBUF = Replace(CHKLineBUF, ZeroCHR, VacantCHR) CHKLineBUF = Replace(CHKLineBUF, vbCr, VacantCHR) CHKLineBUF = Replace(CHKLineBUF, vbLf, VacantCHR) Next i ''2022 '' This logic, it was for NO contents is NO writting '' After all kinds of delimitors, only no contents condition there, ''(including,pulely 0 chr only) the logic no acts ''StakeSTR file for one week action. If Not Trim(CHKLineBUF) = VacantCHR Then weekUnder1_WriteOneLineToStakeFile(LineBuf, DEFTXTKindINT, ID7) ''chked 2022 End If End If Next SW.Close() End Sub ''====================================================== '' '' Read Logic '' ''====================================================== Private Sub OneWeekRead() DEFTXT_Write_Read_OperationContinueFlag = True subOneWeekRead(2) ''DailyTXT subOneWeekRead(3) ''CalcTXT MakeWeeksCalcSum() MakeTotalSumTXT(2) MakeTotalSumTXT(3) DEFTXT_Write_Read_OperationContinueFlag = False End Sub Private Sub subOneWeekRead(DEFTXTKindINT As Integer) Dim TailFileName_dot_ExtentionSTRLocal As String = VacantCHR Dim DEFTXTNum As Integer Dim FullPathFileName As String = VacantCHR Dim i As Integer If DEFTXTKindINT = 2 Or DEFTXTKindINT = 3 Then ''DEFTXTKindINT is ''2 is DailyTXT ''3 is CalcTXT TailFileName_dot_ExtentionSTRLocal = TailFileName_dot_ExtentionSTR(-2 + DEFTXTKindINT) ''WeekStakeFileOperation week1_MakeStakeFileNameAndOpen(DEFTXTKindINT) For i = 0 To 7 - 1 ''WeekStakeFileOperation week2_WriteEachDayFileNametoStakeFile(i) DEFTXTNum = DEFTXTKindINT * 7 + i FullPathFileName = DirPath + BSlushCHR + DayFileNameTrunk(i) + TailFileName_dot_ExtentionSTRLocal If DEFTXTKindINT = 2 Or DEFTXTKindINT = 3 Then SimpleRead( FullPathFileName, DefTXT(DEFTXTNum), DEFTXTKindINT, i) End If With DefTXT(DEFTXTNum) Select Case DEFTXTKindINT Case 2 .Text = RMVOverSeqCRLF(.Text) Case 3 .Text = RMVOverSeqZeroCMCRLF( TuneNumGenerator(.Text)) TodaysCalcSumBuf(i) = tmpTodaysCalcSumBUFGlobal DefTXT(4 * 7 + i).Text = tmpTodaysCalcSumBUFGlobal.ToString() ''WeekStakeFileOperation week3_WriteTodaysCalcSumToStakeFile(i) End Select End With Next i ''WeekStakeFileOperation If DEFTXTKindINT = 3 Then week4_WriteThisWeekCalcSumToStakeFile() End If ''WeekStakeFileOperation week5_WriteStakeFileStreamClose() End If End Sub Private Sub SimpleRead(FullPathFilename As String, TextBOXReaded As TextBox, DEFTXTKindINT As Integer, ID7 As Integer) Dim SR As StreamReader Dim LineSTR As String Dim StakeSTR As String With TextBOXReaded .Text = vbCrLf LineSTR = VacantCHR StakeSTR = VacantCHR If File.Exists(FullPathFilename) = True Then SR = New StreamReader(FullPathFilename) If DEFTXTKindINT = 3 Then tmpStoreNameGlobal = VacantCHR DisCoverStoreNameFlagGlobal = False End If While SR.EndOfStream = False LineSTR = SR.ReadLine StakeSTR = StakeSTR + LineSTR + vbCrLf ''WeekStakeFileOperation ''by one line read, vacant line insert fenominum, ''?unknown reason ''Desolved ''comment on 2023 If Not LineSTR = VacantCHR Then weekUnder1_WriteOneLineToStakeFile( LineSTR, DEFTXTKindINT, ID7) End If End While SR.Close() .Text = StakeSTR End If End With End Sub Private Function RMVOverSeqCRLF(BlockSTR As String) As String Dim i As Integer Dim tmpSTR As String = VacantCHR For i = 1 To 20 tmpSTR = Replace(BlockSTR, vbCrLf + vbCrLf, vbCrLf) Next i If tmpSTR = VacantCHR Then tmpSTR = vbCrLf End If RMVOverSeqCRLF = tmpSTR End Function Private Function RMVOverSeqZeroCMCRLF(BlockSTR As String) As String Dim i As Integer Dim tmpSTR As String = VacantCHR For i = 1 To 20 tmpSTR = Replace(BlockSTR, vbCrLf + CummaCHR + ZeroCHR + vbCrLf, vbCrLf) Next i If tmpSTR = VacantCHR Then tmpSTR = CummaCHR + ZeroCHR + vbCrLf End If RMVOverSeqZeroCMCRLF = tmpSTR End Function ''====================================================== '' '' make Week StakeSTR File operation '' ''====================================================== Private Sub week1_MakeStakeFileNameAndOpen( DEFTXTKindINT As Integer) Dim FullPathWeekStakeFileName As String FullPathWeekStakeFileName = DirPath + BSlushCHR + WeekStakeFileName( DEFTXTKindINT - 2) WeekStakeFile_StreamWriter = New StreamWriter( FullPathWeekStakeFileName) End Sub Private Sub week2_WriteEachDayFileNametoStakeFile( ID7 As Integer) WeekStakeFile_StreamWriter.Write( DayFileNameTrunkForDisplayWithSlush(ID7) + vbCrLf) '' End Sub Private Sub week3_WriteTodaysCalcSumToStakeFile(ID7 As Integer) Dim TodaysCalcSumBufSTRLocal As String = TodaysCalcSumBuf(ID7).ToString ''only calc textbox case WeekStakeFile_StreamWriter.Write( CummaCHR +''day cell indent CummaCHR +''item cell indent CummaCHR +''each price cell indent TodaysCalcSumBufSTRLocal + vbCrLf) End Sub Private Sub week4_WriteThisWeekCalcSumToStakeFile() ''only calc textbox case WeekStakeFile_StreamWriter.Write( CummaCHR +''day cell indent CummaCHR +''item cell indent CummaCHR +''each price cell indent CummaCHR +''day sum cell indent WeeksCalcSumBUFGlobal.ToString + vbCrLf) End Sub Private Sub week5_WriteStakeFileStreamClose() WeekStakeFile_StreamWriter.Close() End Sub Private Sub weekUnder1_WriteOneLineToStakeFile( LineSTR As String, DEFTXTKindINT As Integer, ID7 As Integer) Dim tmpSTR As String = VacantCHR If LineSTR = VacantCHR Then ''nothing Else Select Case DEFTXTKindINT Case 2 tmpSTR = LineSTR + vbCrLf Case 3 ''linestr = item , each price tmpSTR = DayFileNameTrunkForDisplayWithSlush(ID7) + CummaCHR + LineSTR + CummaCHR +''day sum cell indent CummaCHR +''week''s sum cell indent CummaCHR + MakeStoreNamedLineSTR(LineSTR) + vbCrLf ''2019June End Select End If WeekStakeFile_StreamWriter.Write(tmpSTR) End Sub Private Function MakeStoreNamedLineSTR(LineSTR As String) As String ''2019June '' need on global, tmpStoreNameGlobal DisCoverStoreNameFlagGlobal '' '' '' NoExist "/" *---> CHRs all to ItemName '' | '' CHRs Nums | '' ^ --> CHRs = CHRsA "/" CHRsB '' cumma split V V slush split '' StoreName ItemName '' | '' V '' save hold global <--> reference from operation '' A ''Memory off or overwrite | '' | '' New StoreName '' or "//" switch discover Dim StoreNamedLineSTR As String = VacantCHR Dim tmpSTR As String = VacantCHR Dim ItemName As String = LineSTR Dim NumSTR As String = ZeroCHR Dim FirstPointLocation As Integer Dim RemainPointLocation As Integer ''Global SlushCHR = "/" If Not Trim(LineSTR) = VacantCHR Then LineSTR = StoreNameDelimitorPolicy(LineSTR) '' separete primitive item name and numstr FirstPointLocation = InStr(LineSTR, CummaCHR) If 0 < FirstPointLocation Then tmpSTR = Mid(LineSTR, 1, FirstPointLocation - 1) ItemName = tmpSTR RemainPointLocation = Len(LineSTR) - FirstPointLocation If 0 < RemainPointLocation Then NumSTR = Mid(LineSTR, FirstPointLocation + 1, RemainPointLocation) End If End If '' discover end point "//" in storename logic zone If 0 < InStr(tmpSTR, SlushCHR + SlushCHR) Then DisCoverStoreNameFlagGlobal = False tmpSTR = Replace(tmpSTR, SlushCHR + SlushCHR, VacantCHR) ItemName = tmpSTR tmpStoreNameGlobal = VacantCHR ''End If'' Else '' split storename by "/" FirstPointLocation = InStr(tmpSTR, SlushCHR) If 0 < FirstPointLocation Then DisCoverStoreNameFlagGlobal = True tmpStoreNameGlobal = Mid(tmpSTR, 1, FirstPointLocation - 1) RemainPointLocation = Len(tmpSTR) - FirstPointLocation If 0 < RemainPointLocation Then ItemName = Mid(tmpSTR, FirstPointLocation + 1, RemainPointLocation) ItemName = Replace(ItemName, SlushCHR, VacantCHR) End If End If End If If ItemName = VacantCHR And NumSTR = ZeroCHR Then ''nodoing StoreNamedLineSTR = VacantCHR Else StoreNamedLineSTR = tmpStoreNameGlobal + CummaCHR + ItemName + CummaCHR + NumSTR End If ''If DisCoverStoreNameFlagGlobal = False Then ''tmpStoreNameGlobal = VacantCHR ''End If End If MakeStoreNamedLineSTR = StoreNamedLineSTR End Function Public Function StoreNameDelimitorPolicy(InputSTR As String) As String ''2019June ''2023 function renamed InputSTR = Replace(InputSTR, "／", SlushCHR) InputSTR = Replace(InputSTR, "、", SlushCHR) StoreNameDelimitorPolicy = InputSTR End Function ''====================================================== '' '' Day imfomational number tune And '' Make day-filename base trunk. '' ''====================================================== Private Sub Minus7Days() ThisWeeksSundayDate = ThisWeeksSundayDate.AddDays(-7) End Sub Private Sub Plus7Days() ThisWeeksSundayDate = ThisWeeksSundayDate.AddDays(+7) End Sub Private Sub GetThisWeeksSundayDate() ''initialize Dim tmpToday As Date tmpTodayGlobal = DateTime.Today ''2019June tmpToday = tmpTodayGlobal ''2019June ThisWeeksSundayDate = tmpToday.AddDays(-Today.DayOfWeek) ''minus day operation, ''to reach for this week sunday End Sub Private Sub MakeFileNameTrunk() ''2019June Dim FT As String ''FileNameTrunk Dim DayFileNameTrunkForDisplayWithSlush_local As String Dim i As Integer Dim tmpToday As Date Dim YYYY As String Dim MM As String Dim DD As String Dim j As Integer Dim DDName As String ''DistinguishLongOrShortDispDayName For i = 0 To 7 - 1 FT = VacantCHR tmpToday = ThisWeeksSundayDate.AddDays(i) YYYY = TuneZeroCHR_Degit(CStr(tmpToday.Year), 4) ''2019June MM = TuneZeroCHR_Degit(CStr(tmpToday.Month), 2) DD = TuneZeroCHR_Degit(CStr(tmpToday.Day), 2) With YearYYYYPermitCHK Select Case .CheckState Case 0 FT += Mid(YYYY, 3, 2) ''2018 > 18 for example Case 1 FT += Mid(YYYY, 1, 4) End Select End With ''If CInt(MM) < 10 Then ''2 > 02 '' MM = ZeroCHR + MM ''End If ''If CInt(DD) < 10 Then ''8 > 08 ''DD = ZeroCHR + DD ''End If''2019June CommentOut FT = FT + MM + DD DDName = "test" With DispLongDayNameCHK If .CheckState = 0 Then ''"UnChecked" DDName = VacantCHR End If If .CheckState = 1 Then ''"Checked" DDName = YYYY + SlushCHR End If End With DayFileNameTrunkForDisplayWithSlush_local = DDName + MM + SlushCHR + DD DayFileNameTrunk(i) = FT DefTXT(0 * 7 + i).Text = DayFileNameTrunkForDisplayWithSlush_local DayFileNameTrunkForDisplayWithSlush(i) = DayFileNameTrunkForDisplayWithSlush_local If i = 0 Then ''on the Sunday-mode case, ''make week StakeSTR contents filename. For j = 0 To 1 WeekStakeFileName(j) = YYYY + MM + DD + TailStakeFileName_dot_ExtentionSTR(j) ''2019June ''for example, 20180218.wc/pt ''comment on 2023 '' 20180218.1wd/1wp Next j End If Next i End Sub Private Function TuneZeroCHR_Degit(NumSTR As String, DegitNum As Integer) As String Dim tmpSTR As String Dim Length As Integer Dim I As Integer tmpSTR = NumSTR Length = Len(NumSTR) If Length < DegitNum Then For I = 1 To DegitNum - Length tmpSTR = ZeroCHR + tmpSTR Next End If TuneZeroCHR_Degit = tmpSTR End Function Private Sub WeeksCalcFromCalcTxt(WeekDayNum As Integer) ''This Logic is a Function Practically. ''-------------------------------------------------- '' a days'' calclational sum '' from yymmddpt.txt contents imformation ''-------------------------------------------------- Dim ReadCalcFileName As String Dim tmpArr(2 - 1) As String ReadCalcFileName = DirPath + BSlushCHR + DayFileNameTrunk(WeekDayNum) + TailFileName_dot_ExtentionSTR(1) Dim SR = New StreamReader(ReadCalcFileName) Dim lineSTR As String Dim tmpSum As Single tmpSum = 0 While SR.EndOfStream = False lineSTR = SR.ReadLine tmpSum += Val(tmpArr(1)) ''second element End While TodaysCalcSumBuf(WeekDayNum) = tmpSum ''^this is sum buffers are 7 pieces, ''from sunday to Saturday End Sub Private Sub MakeTotalSumTXT(DEFTXTKindINT As Integer) '' To be Called from OneWeekWrite and '' OneWeekRead ''comment on 2023 ''DEFTXTKindINT is TXTKindINT, ''DEFTXTKindINT 2 is DailyTXT ''DEFTXTKindINT 3 as CalcTXT Dim FileName_S() As String ''Array Dim FileName As String ''Element Dim SR As StreamReader Dim SW As StreamWriter Dim SWBufSTR As String REM no using Dim LineSTR As String = VacantCHR Dim TotalSumFileNameLocal As String ''-------------------------------------------------- ''TotalSumFileName Is the weeks sundayname, ''for example, '' ''sun 180218 20180218.wc/pt :this filename ''mon 180219 total stake ''thu 180220 filename. ''wed 180221 ''thr 180222 20180218.1wd/1wp on YYYY mode ''fri 180223 ''sut 180224 ''-------------------------------------------------- TotalSumFileNameLocal = DirPath + BSlushCHR + TotalSumFileName(DEFTXTKindINT - 2) ''TotalSumFileName are 0 Or 1 ''DEFTXTKindINT are 2 or 3 FileName_S = Directory.GetFiles( DirPath, "*" + TailStakeFileName_dot_ExtentionSTR(DEFTXTKindINT - 2)) REM SW = New StreamWriter(TotalSumFileNameLocal) ''over write mode SWBufSTR = VacantCHR For Each FileName In FileName_S REM SW.WriteLine(FileName) SWBufSTR = SWBufSTR + FileName + vbCrLf SR = New StreamReader(FileName) ''While SR.EndOfStream = False ''LineSTR = VacantCHR ''LineSTR = SR.ReadLine() ''+ vbCrLf REM SW.Write(LineSTR) ''SWBufSTR = SWBufSTR + LineSTR ''End While SWBufSTR = SWBufSTR + SR.ReadToEnd ''+vbcrlf SR.Close() Next SW = New StreamWriter(TotalSumFileNameLocal) ''over writemode SW.Write(SWBufSTR) SW.Close() End Sub ''====================================================== '' '' Logic end. '' ''====================================================== End Class