Spread Sheet ActiveX ActiveX 100 AcriveX MSFlexGrid MSFlexGrid, Spread sheet Spread sheet sheet MDI 1 Spread sheet MDI (Name) MDI From frmminisheet Caption Mini sheet CommonDialog cdlfile 1 Spread sheet MDI 1 Spread sheet MDI 2 Menu 1 Spread sheet MDI 2 CommonDialog Ctrl-T Microsoft Common Dialog Control sheet MDIChild 2 Sheet MDIChild Project Caption (Name) &File mnufile &New sheet mnunew &Open sheet mnuopen - mnusep1 &Save sheet mnusave Save sheet &as mnusaveas - mnusep2 &Exit mnuexit &Edit &Tools mnuedit &Copy mnucopy Shortcut Ctrl+C &Paste mnupaste Shortcut Crtl+V &Graph mnutools mnugraph (Name) Form frmsheet MDIChild True MSFlexGrid grdsheet Top 0 Left 0 Text Box txtrec 3 Spread sheet MDI 2 Sheet MDIChild 3 MSFlexGrid Spread sheet MSFlexGrid Sheet Project-Add module ExpCalc MiniSheet
frmminisheet frmminisheet MDI 1 frmminisheet 1 frmminisheet Option Explicit Public SheetNo As Integer Private Sub MDIForm_Load() InitCalc SheetNo = 0 mnunew_click Private Sub MDIForm_Unload(Cancel As Integer) End SheetNo Sheet MDIChild MDIForm Load Load mnunew_click Sheet MDIForm Unload 2 New Sheet MDIChild frmsheet frmnewsheet Show frmsheet New Set Open cdlfile Sheet MDIChild OpenSheet ActiveForm Form MDIForm (MDI MDIChild ) MDI MDIChild ActiveForm 2 Private Sub mnunew_click() Dim frmnewsheet As Form Set frmnewsheet = New frmsheet frmnewsheetshow Private Sub mnuopen_click() cdlfileflags = cdlofnexplorer cdlfilefilter = "Sheet file(*sht) *sht All files(**) **" On Error GoTo FileSelectCancel cdlfilecancelerror = True cdlfileshowopen On Error GoTo 0 mnunew_click MeActiveFormOpenSheet cdlfilefilename MeActiveFormCaption = cdlfilefiletitle & " [Sheet]" Exit Sub FileSelectCancel: If ErrNumber <> cdlcancel Then MsgBox "Unexpected error", _ vbexclamation, "Error"
On Error GoTo 0 Public Sub mnusave_click() If MeActiveForm Is Nothing Then Exit Sub If MeActiveFormshtFilename = "" Then mnusaveas_click MeActiveFormSaveSheet Private Sub mnusaveas_click() If MeActiveForm Is Nothing Then Exit Sub cdlfileflags = cdlofnexplorer + cdlofnoverwriteprompt cdlfilefilter = "Sheet file(*sht) *sht All files(**) **" cdlfiledefaultext = "sht" On Error GoTo FileSelectCancel cdlfilecancelerror = True cdlfileshowsave On Error GoTo 0 MeActiveFormshtFilename = cdlfilefilename MeActiveFormSaveSheet MeActiveFormCaption = cdlfilefiletitle & " [Sheet]" Exit Sub FileSelectCancel: If ErrNumber <> cdlcancel Then MsgBox "Unexpected error", _ vbexclamation, "Error" On Error GoTo 0 Private Sub mnuexit_click() Unload Me Private Sub mnucopy_click() If MeActiveForm Is Nothing Then Exit Sub MeActiveFormCopy Private Sub mnupaste_click() If MeActiveForm Is Nothing Then Exit Sub MeActiveFormPaste SaveAs Open MDIChild SaveSheet Sheet Sheet Sheet ActiveForm Nothing Is If ActiveForm = Nothing Then If ActiveForm Is Nothing Then cdlfile DefaultExt Save Sheet MDIChild shtfilename
SaveAs MDIChild SaveSheet Sheet shtfilename Sheet New Sheet SaveAs Exit MDI Unload Copy Paste MDIChild Copy Paste Sheet Sheet frmsheet Mini Sheet frmsheet MDIChild MSFlexGrid MSFlexGrid FixedCols = 1 0 1 2 1 Text 2 3 4 Cols = 3 3 MSFlexGrid FixedRows = 1 Rows = 5 Col = 1 Row = 1 Text = Text MSFlexGrid 3 Cols Rows FixedCols FixedRows Col Row Text Col, Row ColSel, RowSel Clip CellAlignment CellForeColor, CellBackColor 3 MDIChild 3 MDIChild Option Explicit Const shtnewname = "Untitled" Const shtmaxcol = 30 Const shtmaxrow = 1000 Dim shtnotsaved As Boolean Public shtfilename As String Private Sub Form_Load() Dim i As Long shtnotsaved = False shtfilename = "" frmminisheetsheetno = frmminisheetsheetno + 1 MeCaption = shtnewname & " - " & frmminisheetsheetno & " [Sheet]" grdsheetredraw = False
grdsheetallowuserresizing = flexresizecolumns grdsheetallowbigselection = True grdsheetcols = shtmaxcol grdsheetrows = shtmaxrow grdsheetrow = 0 For i = 1 To shtmaxcol - 1 grdsheetcol = i grdsheettext = ColNo2ColName(i) grdsheetfixedalignment(i) = flexaligncentercenter Next grdsheetcol = 0 For i = 1 To shtmaxrow - 1 grdsheetrow = i grdsheettext = i Next grdsheetcol = 1 grdsheetrow = 1 grdsheetredraw = True txtrecborderstyle = vbbsnone txtrecvisible = False Private Sub Form_Resize() grdsheetwidth = MeScaleWidth grdsheetheight = MeScaleHeight Private Sub Form_Unload(Cancel As Integer) Dim Canceled As Integer If shtnotsaved Then Canceled = MsgBox("Sheet is not saved Do you want to save the sheet?", vbyesnocancel + vbinformation, "Not saved") If Canceled = vbyes Then frmminisheetmnusave_click If Canceled = vbcancel Then Cancel = 1 Private Function ColNo2ColName(ByVal Col As Long) As String Dim name As String Dim digit As Integer name = "" Col = Col - 1 Do digit = Col Mod 26 Col = Col \ 26 name = Chr(Asc("A") + digit) & name If Col = 0 Then Exit Do Col = Col - 1 Loop ColNo2ColName = name
shtmaxcol shtmaxrow Sheet shtnotsaved sheet shtfilename Sheet frmsheet Public frmsheet Load grdsheet Redraw False MSFlexGrid MSFlexGrid MSFlexGrid Redraw False AllowUserResizing AllowBigSelection grdsheet ColNo2ColName, (Col) 1 A, 2 B, 3 C ColNo2ColName FixedAlignment txtrec BorderStyle vbbsnoe Visible False frmsheet MSFlexGrid Resize 3 frmsheet Unload sheet, shtnotsaved True MsgBox sheet MsgBox vbyes(6), vbno(7), vbcancel(2) Yes frmminisheet MDI Save_Click Save No frmsheet Cancel Cancel 0 frmsheet Sheet MSFlexGrid MSFlexGrid 50 MSFlexGrid 4 grdsheet, txtrec Private Sub grdsheet_dblclick() grdedit 32 Private Sub grdsheet_gotfocus() grdtext2cell Private Sub grdsheet_keypress(keyascii As Integer) grdedit KeyAscii Private Sub grdsheet_leavecell() grdtext2cell Private Sub txtrec_keydown(keycode As Integer, Shift As Integer) EditKeyCode KeyCode, Shift
Private Sub txtrec_keypress(keyascii As Integer) If KeyAscii = Asc(vbCr) Then KeyAscii = 0 Private Sub txtrec_lostfocus() grdtext2cell 4 grdsheet txtrec grdsheet KeyPress txtrec grdedit grdsheet txtrec txtrec txtrec KeyDown txtrec grdsheet EditKeyCode txtrec (LostFocus) txtrec grdsheet grdtext2cell grdsheet (GotFocus), (LeaveCell) grdtext2cell txtrec KeyPress KeyAscii=0 5 4 5 Private Sub grdedit(keyascii As Integer) Select Case KeyAscii Case 32 txtrectext = grdsheettext txtrecselstart = 1 txtrecsellength = Len(txtRecText) Case txtrectext = Chr(KeyAscii) txtrecselstart = 1 shtnotsaved = True End Select txtrecmove grdsheetcellleft, grdsheetcelltop + grdsheettop, _ grdsheetcellwidth, grdsheetcellheight txtrecvisible = True txtrecsetfocus Private Sub EditKeyCode(KeyCode As Integer, Shift As Integer) Select Case KeyCode Case vbkeyescape txtrecvisible = False grdsheetsetfocus Case vbkeyreturn grdsheetsetfocus grdmovenextcell Case vbkeyup grdsheetsetfocus If grdsheetrow > grdsheetfixedrows Then _ grdsheetrow = grdsheetrow - 1 Case vbkeydown grdsheetsetfocus If grdsheetrow < grdsheetrows - 1 Then _ grdsheetrow = grdsheetrow + 1 End Select
Private Sub grdtext2cell() Dim s As String If Not txtrecvisible Then Exit Sub s = Trim(txtRecText) If Mid(s, 1, 1) = "=" Then s = Mid(s, 2, Len(s) - 1) GetExpCalc Me, s If IsNumeric(s) Then grdsheetcellalignment = flexalignrightcenter grdsheetcellalignment = flexalignleftcenter grdsheettext = s txtrecvisible = False Private Sub grdmovenextcell() grdtext2cell If grdsheetcol < grdsheetcols - 1 Then grdsheetcol = grdsheetcol + 1 grdtext2cell grd2text2cell txtrec Sheet = txtrectext = GetExpCalc GetExpCalc ExpCalc s CellAlignment grdsheettext s txtrec Sheet Copy & Paste Copy & Paste 6 6 Copy & Paste Public Sub Copy() grdsheetredraw = False ClipboardSetText grdsheetclip grdsheetredraw = True Public Sub Paste() Dim ColSel As Long, RowSel As Long grdsheetredraw = False ColSel = grdsheetcolsel RowSel = grdsheetrowsel grdsheetcolsel = grdsheetcols - 1 grdsheetrowsel = grdsheetrows - 1 grdsheetclip = ClipboardGetText grdsheetcolsel = ColSel grdsheetrowsel = RowSel grdsheetredraw = True
Copy Clipboard ClipboardSetText ClipboardGetText SetData GetData MSFlexGrid Clip Paste ColSel RowSel MSFlexGrid Clip MSFlexGrid Save & Open 7 Save Open 7 Save & Open Public Sub SaveSheet() Dim Row As Long, Col As Long Dim saverow As Long, savecol As Long If shtfilename = "" Then Exit Sub Open shtfilename For Output As #1 grdsheetredraw = False saverow = grdsheetrow savecol = grdsheetcol For Row = 1 To grdsheetrows - 1 grdsheetrow = Row grdsheetcol = 1 grdsheetcolsel = grdsheetcols - 1 Print #1, grdsheetclip Next grdsheetrow = saverow grdsheetcol = savecol grdsheetredraw = True Close #1 shtnotsaved = False Public Sub OpenSheet(filename As String) Dim Row As Long Dim saverow As Long, savecol As Long Dim s As String If filename = "" Then Exit Sub Open filename For Input As #1 grdsheetredraw = False Row = 0 Do While Not EOF(1) Row = Row + 1 grdsheetrow = Row grdsheetcol = 1 grdsheetcolsel = grdsheetcols - 1 Line Input #1, s grdsheetclip = s
Loop grdsheetrow = 1 grdsheetcol = 1 grdsheetredraw = True Close #1 shtfilename = filename, /, 3 Open Open pathname For mode As [#]filenumber pathname path mode Append, Binary, Input, Output, Random 4 Mode mode access Text/Binary Append Text Binary / Binary Input Text Output Text Random / Text/Binary 4 filenumber 1 511 Open Mini Sheet Input Output Input #, Write# Line Input #, Print #, SaveSheet ColSel Clip sheet shtfilename OpenSheet sheet ExecCalc 8 GetExpCalc,,,,, GetToken, EvalExp,, EvalExp 4
8 Public Sub GetExpCalc(ExpStr) Buff = ExpStr GetToken dop ExpStr = EvalExp(dOP) Private Function EvalExp(dOP) Opr1 = EvalExp2(dOP) Do While (dop = idadd) Or (dop = idsub) OP = dop GetToken dop Opr1 = Calc(Opr1, EvalExp2(dOP), OP) Loop EvalExp = Opr1 Private Function EvalExp2(dOP) Opr1 = EvalExp3(dOP) Do While (dop = idmul) Or (dop = iddiv) OP = dop GetToken dop Opr1 = Calc(Opr1, EvalExp3(dOP), OP) Loop EvalExp2 = Opr1 Private Function EvalExp3(dOP) Opr1 = EvalExp4(dOP) Do While dop = idpow OP = dop GetToken dop Opr1 = Calc(Opr1, EvalExp4(dOP), OP) Loop EvalExp3 = Opr1 Private Function EvalExp4(dOP) Select Case dop Case idminus GetToken dop Opr1 = - EvalExp4(dOP) Case idsin GetToken dop Opr1 = Sin(EvalExp4(dOP)) Case idlpar GetToken dop Opr1 = EvalExp(dOP) If dop = idrpar Then GetToken dop Case idnumber Opr1 = CSng(dOP) GetToken dop End Select EvalExp4 = Opr1 EvalExp, dop EvalExp2 dop Opr1 dop GetToken Calc (A,B,OP) A OP B
OP = + A + B Opr1 dop dop EvalExp2(dOP) EvalExp2 dop Opr1 EvalExp2 EvalExp3 EvalExp EvalExp4 EvalExp4 EvalExp4 EvalExp4 (recursive call) Private Function Power2(n) If n = 0 then Power2 = 1 Power2 = 2 * Power2( n 1 ) 2 n n = 3 Power(3) Power(0) 5 n = 0 Power2 1 2 3 Power(3) Power(3) Power(3) Power(3) Power(3) Power(3) 2*2*2*1 2*Power(2) 2*Power(2) 2*Power(2) 2*Power(2) 2*(2*2*1) 2*Power(1) 2*Power(1) 2*Power(1) 2*(2*1) 2*Power(0) 2*(1) 5 Stack A + B A B Add(A,B) A (C + D) + B C + D Add( Add( C, D ), B ), 9 8 sin, cos A1, A2 Sheet spread sheet Copy & Paste spread sheet spread sheet spread sheet 9 ExpCalc Option Explicit
Const idnum = "0", iderr = "ERR", iddot = "", ideol = "EOL" Const idadd = "+", idsub = "-", idmul = "*", iddiv = "/" Const idpow = "^", idminus = "-" Const idsin = "sin", idcos = "cos", idtan = "tan" Const idsqrt = "sqrt", idexp = "exp" Const idln = "ln" Const idlpar = "(", idrpar = ")" Const CellNameStr = "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" Const CellNameStr2 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ" Const NoOfCmd = 17 Dim cmdlist(noofcmd) As String Dim frmcallsheet As Form Dim Buff As String, idx As Integer Public Sub InitCalc() cmdlist(1) = idadd: cmdlist(2) = idsub cmdlist(3) = idmul: cmdlist(4) = iddiv cmdlist(5) = idpow: cmdlist(6) = idminus cmdlist(7) = idsin: cmdlist(8) = idcos cmdlist(9) = idtan: cmdlist(10) = idsqrt cmdlist(11) = idexp: cmdlist(12) = idln cmdlist(13) = idlog: cmdlist(14) = idasin cmdlist(15) = idacos: cmdlist(16) = idlpar cmdlist(17) = idrpar Public Sub GetExpCalc(frm As Form, ExpStr As String) Dim Attr As String Dim Num As Single Set frmcallsheet = frm Buff = Trim(ExpStr) idx = 1 If Attr = iderr Then ExpStr = "Error" Num = EvalExp(Attr) If Attr = iderr Then ExpStr = "Error" ExpStr = Num Private Sub GetToken(ByRef Attr As String) Dim s As String, ss As String Dim i As Integer If idx > Len(Buff) Then Attr = ideol Exit Sub Do While Mid(Buff, idx, 1) = " " idx = idx + 1 Loop
s = Mid(Buff, idx, 1) If IsNumeric(s) Or (s = iddot) Then ss = "" Do ss = ss + s idx = idx + 1 If idx > Len(Buff) Then Exit Do s = Mid(Buff, idx, 1) Loop Until Not (IsNumeric(s) Or (s = iddot)) If IsNumeric(ss) Then Attr = ss Attr = iderr For i = 1 To NoOfCmd If InStr(idx, UCase(Buff), UCase(cmdList(i))) = idx Then Attr = cmdlist(i) idx = idx + Len(Attr) Exit Sub Next If InStr(1, CellNameStr2, UCase(s)) > 0 Then ss = "" Do ss = ss + s idx = idx + 1 If idx > Len(Buff) Then Exit Do s = Mid(Buff, idx, 1) Loop While InStr(1, CellNameStr, UCase(s)) > 0 Attr = ss Attr = iderr Private Function Calc(OP1 As Single, OP2 As Single, OP As String) As Single Dim sop1 As Single, sop2 As Single sop1 = CSng(OP1) sop2 = CSng(OP2) Select Case OP Case idadd Calc = sop1 + sop2 Case idsub Calc = sop1 - sop2 Case idmul Calc = sop1 * sop2 Case iddiv Calc = sop1 / sop2 Case idpow Calc = sop1 ^ sop2 End Select Private Function EvalExp(ByRef Attr As String) As Single Dim Num As Single Dim OP As String
Num = EvalExp2(Attr) Do While (Attr = idadd) Or (Attr = idsub) OP = Attr Num = Calc(Num, EvalExp2(Attr), OP) Loop EvalExp = Num Private Function EvalExp2(ByRef Attr As String) As Single Dim Num As Single Dim OP As String Num = EvalExp3(Attr) Do While (Attr = idmul) Or (Attr = iddiv) OP = Attr Num = Calc(Num, EvalExp3(Attr), OP) Loop EvalExp2 = Num Private Function EvalExp3(ByRef Attr As String) As Single Dim Num As Single Dim OP As String Num = EvalExp4(Attr) Do While Attr = idpow OP = Attr Num = Calc(Num, EvalExp4(Attr), OP) Loop EvalExp3 = Num Private Function EvalExp4(ByRef Attr As String) As Single Dim Num As Single Dim Canceled As Boolean Select Case Attr Case idminus Num = -EvalExp4(Attr) Case idsin Num = Sin(EvalExp4(Attr)) Case idcos Num = Cos(EvalExp4(Attr)) Case idtan Num = Tan(EvalExp4(Attr)) Case idexp Num = Exp(EvalExp4(Attr)) Case idsqrt Num = Sqr(EvalExp4(Attr)) Case idln Num = Log(EvalExp4(Attr))
Case idlpar Num = EvalExp(Attr) If Attr = idrpar Then EvalExp4 = Num Exit Function Case If IsNumeric(Attr) Then Num = CSng(Attr) frmcallsheetgetcellval Num, Attr, Canceled If Canceled Then Attr = iderr End Select EvalExp4 = Num : GetCellVal frmsheet MDIChild Public Sub GetCellVal(Num As Single, CellName As String, _ Canceled As Boolean) Dim ColName As String, RowName As String Dim s As String, idx As Integer Dim ColNo As Long, RowNo As Long Dim j As Integer ColName = "" RowName = "" idx = 1 Do s = UCase(Mid(CellName, idx, 1)) If (s < "A") Or (s > "Z") Then Exit Do idx = idx + 1 ColName = ColName + s Loop Until idx > Len(CellName) If idx > Len(CellName) Then Canceled = True Exit Sub Do s = UCase(Mid(CellName, idx, 1)) If (s < "0") Or (s > "9") Then Exit Do idx = idx + 1 RowName = RowName + s Loop Until idx > Len(CellName) ColNo = Asc(Right(ColName, 1)) - Asc("A") + 1 j = 1 For idx = Len(ColName) - 1 To 1 Step -1 ColNo = ColNo + (Asc(Mid(ColName, idx, 1)) - Asc("A") + 1) * 26 ^ j
j = j + 1 Next RowNo = CLng(RowName) s = grdsheettextmatrix(rowno, ColNo) If IsNumeric(s) Then Num = CSng(s) Canceled = False Canceled = True