歯VB강좌5.PDF

Transcription

1 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

2 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"

3 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

4 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 = Text 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

5 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

6 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

7 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= 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

8 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

9 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

10 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 Open Mini Sheet Input Output Input #, Write# Line Input #, Print #, SaveSheet ColSel Clip sheet shtfilename OpenSheet sheet ExecCalc 8 GetExpCalc,,,,, GetToken, EvalExp,, EvalExp 4

11 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

12 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 Power 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

13 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 = "ABCDEFGHIJKLMNOPQRSTUVWXYZ " 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

14 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

15 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))

16 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

17 j = j + 1 Next RowNo = CLng(RowName) s = grdsheettextmatrix(rowno, ColNo) If IsNumeric(s) Then Num = CSng(s) Canceled = False Canceled = True