$TYPECHECK ON '### MULTI LEVEL UNDO/REDO BOX VERSION 1.0a ###' CONST CR$ = chr$(13):CONST LF$ = chr$(10) CONST NEWLINE$ = chr$(13)+chr$(10):CONST DbQUOTE = chr$(34) '-- charactor CONST NONE_KEY = 0:CONST GENERAL_KEY = 1: CONST PASTE_KEY = 2 CONST VK_A = 65:CONST VK_Z = 90 CONST VK_SEMICOLON = 186:CONST VK_SLASH = 191 CONST VK_LBRACKET = 219:CONST VK_SINGLEQUOTE = 222 CONST VK_NUM0 = 48:CONST VK_NUM9 = 57 '-- Private_VK CONST VK_TAB = &H9:CONST VK_RETURN = &HD:CONST VK_SPACE = &H20 CONST VK_BACK = &H8:CONST VK_DELETE = &H2E CONST VK_NUMPAD0 = &H60:CONST VK_NUMPAD9 = &H69 CONST VK_MULTIPLY = &H6A:CONST VK_DIVIDE = &H6F '-- Win32Api_VK '// ABOUT PROGRAM '// declare sub about_close create about as qform caption = "about this program" height = 200 create aboutbox as qrichedit align = 1 alignment = 2 readonly = 1 height = 110 text = "UNDO/REDO BOX VERSION 1.0a"+NEWLINE$+_ "Program by Suchart Chokphichitchai"+NEWLINE$+NEWLINE$+_ "Copy Right 2003-2004" end create create aboutbtn as qbutton top = aboutbox.height+5 left = 110 caption = "close" onclick = about_close end create end create sub about_close about.close end sub sub aboutShow about.center about.showmodal end sub '// OBJECT DECLARATION // DIM Form AS QForm Form.Center DIM mn AS QMainMenu DIM iEdit AS QMenuItem DIM iRedo AS QMenuItem DIM iUndo AS QMenuItem DIM iDelWord AS QMenuItem DIM iBackWord AS QMenuItem DIM iCut AS QMenuItem DIM iCopy AS QMenuItem DIM iPaste AS QMenuItem DIM iSelAll AS QMenuItem DIM iEditMode AS QMenuItem DIM iHelp AS QMenuItem DIM iAbout AS QMenuItem DIM ed AS QRichEdit DIM LsVal AS QListbox Dim LsUndoIndex AS QListbox Dim ls AS QListbox Dim lsN AS QListbox const dmnCount = 7 ' truely = 8 defstr deliminator(dmnCount) = {" ", ".", ",", ":", ";", chr$(9),CR$,LF$} dim DownKey as integer dim DownShift as integer dim selBegin as integer dim Lspace as integer dim Rspace as integer dim Deleted as string defint TextCount = 0 '// keep Len(Ed.Text) By OnKeydown Event, And Edit-Subroutine defint undoPosition = -1 '// FUNCTION AND EVENT // sub showUndoPosition '-- Global Purpose '-- this Subroutine need not for Undoing --' ' It's just show the proceed of command. ' You may insert quote-mark infront of it to run faster. LsUndoIndex.itemIndex = undoPosition Ls.itemIndex = undoPosition LsN.itemIndex = undoPosition end sub subi intVar(...) '// for showVariable dim i as integer if paramValCount<>paramStrCount then LsVal.Additems "wrong parameter amount" LsVal.Additems str$(paramValCount)+" "+str$(paramStrCount) else for i = 1 to paramValCount LsVal.Additems paramStr$(i)+" = "+str$(paramVal(i)) next i end if LsVal.itemIndex = LsVal.itemCount - 1 end subi subi strVar(...) '// for showVariable dim i as integer if (paramStrCount mod 2 <> 0) then LsVal.Additems "wrong parameter amount" LsVal.Additems str$(paramValCount)+" "+str$(paramStrCount) else for i = 1 to paramStrCount step 2 LsVal.Additems paramStr$(i)+" = "+DbQUOTE+paramStr$(i+1)+DbQUOTE next i end if LsVal.itemIndex = LsVal.itemCount-1 end subi sub Inc_undoPosition undoPosition = undoPosition + 1 end sub sub Dec_undoPosition undoPosition = undoPosition - 1 end sub function LMarkDistance( sel as integer ) as integer defint LenText = Len(Ed.Text) defint sel_first = sel dim i as integer while ( sel > 0 ) '// sound is hard-work, but at for-loop have condition '// will stop while loop when found deliminator(i) for i = 0 to dmnCount if (Ed.Text[ sel ] = deliminator(i)) then exit while end if next i sel = sel - 1 wend if (sel = sel_first) then '// if found deliminator at first time. '// purpose find length of same-deliminator char. while (sel > 0 ) sel = sel - 1 ' obtain it decrease. if (Ed.Text[ sel ] <> deliminator(i)) then '// when found not-deliminator(i). exit while end if wend end if '// sometime refering to not-exists variable coz mistake. LMarkDistance = sel_first - sel end function function RMarkDistance( sel as integer ) as integer defint LenText = Len(Ed.Text) defint sel_first = sel dim i as integer while ( sel < LenText ) '// sound is hard-work, but at for-loop have condition '// will stop while loop when found deliminator(i) sel = sel + 1 for i = 0 to dmnCount if (Ed.Text[ sel ] = deliminator(i)) then sel = sel - 1 exit while end if next i wend if (sel = sel_first) then '// if found deliminator at first time. '// purpose find length of same-deliminator char. while (sel < LenText) sel = sel + 1 ' obtain it increase. if (Ed.Text[ sel ] <> deliminator(i)) then '// when found not-deliminator(i). sel = sel - 1 exit while end if wend end if RMarkDistance = sel - sel_first end function sub DelBackHilight DownKey = VK_BACK selBegin = Ed.SelStart + Ed.selLength 'increase coz SelStart is at left of SelText Deleted = Ed.SelText TextCount = Len(Ed.Text) end sub sub DelWord DownKey = VK_DELETE selBegin = Ed.SelStart Rspace = IIF(MID$(Ed.Text,Ed.SelStart+1,2) = CR$+LF$, 2, RMarkDistance(Ed.SelStart)) Deleted = MID$(Ed.Text, Ed.SelStart+1,Rspace) '// keep RightText may deleted. TextCount = Len(Ed.Text) end sub sub DelBack DownKey = VK_BACK selBegin = Ed.SelStart Lspace = IIF(MID$(Ed.Text,Ed.SelStart-1,2) = CR$+LF$, 2, LMarkDistance(Ed.SelStart)) Deleted = MID$(Ed.Text, Ed.SelStart - Lspace + 1 , Lspace ) TextCount = Len(Ed.Text) end sub sub edkbdown(Key AS WORD, Shift AS INTEGER) if (Shift <> 16) then '// purpose = not add undoList when click menu SELECT CASE Key CASE VK_A TO VK_Z,VK_SEMICOLON TO VK_SLASH,_ VK_LBRACKET TO VK_SINGLEQUOTE,VK_NUM0 TO VK_NUM9,_ VK_NUMPAD0 TO VK_NUMPAD9,VK_MULTIPLY TO VK_DIVIDE,VK_SPACE,VK_TAB: DownKey = GENERAL_KEY selBegin = Ed.SelStart CASE VK_BACK: if (Ed.selLength <> 0) then ' Del by hilights DelBackHilight else ' (Ed.SelLength = 0) ' Del by not hilights if (Ed.SelStart <> 0) then DelBack end if end if CASE VK_RETURN: DownKey = VK_RETURN selBegin = Ed.SelStart CASE VK_DELETE: if (Ed.SelStart <> Len(Ed.Text)) then '// not add UndoList if SelStart at last position DelWord end if END SELECT end if end sub sub IF_Not_LastPosition_DelOldList ' When Edit Between Undo/Redo, 'Delete RedoList (All UndoList which above UndoPosition) 'used by OnChange Event dim i as integer if (undoPosition <> Ls.itemCount-1) then for i = Ls.itemCount-1 to undoPosition+1 step -1 LsUndoIndex.DelItems i ' clear old undoList Ls.DelItems i ' clear old undoList LsN.DelItems i ' clear old selStartList next i end if end sub sub addUndoItem( item$ as string, position as integer ) LsUndoIndex.Additems str$(undoPosition+1) '// For Display UndoIndex Ls.Additems item$ '// add undoList LsN.Additems str$(position) '// add undoSelStart DownKey = NONE_KEY '// set value for protect adding undoList over 1 per time. end sub sub edbkbChg SELECT CASE DownKey CASE GENERAL_KEY: IF_Not_LastPosition_DelOldList addUndoItem(Ed.Text[Ed.SelStart], selBegin) Inc_UndoPosition: showUndoPosition CASE VK_BACK: IF_Not_LastPosition_DelOldList addUndoItem(right$( Deleted, TextCount-Len(Ed.Text) )+"B", selBegin) 'develop Inc_undoPosition: showUndoPosition CASE VK_RETURN: IF_Not_LastPosition_DelOldList addUndoItem("#R", selBegin) Inc_undoPosition: showUndoPosition CASE VK_DELETE: IF_Not_LastPosition_DelOldList addUndoItem(left$( Deleted, TextCount-Len(Ed.Text) )+"D", selBegin) Inc_undoPosition: showUndoPosition CASE PASTE_KEY: IF_Not_LastPosition_DelOldList defint LenPasted = Len(Ed.Text) - TextCount addUndoItem(Mid$(Ed.Text, Ed.SelStart - LenPasted + 1, LenPasted )+"P", selBegin) Inc_undoPosition: showUndoPosition END SELECT end sub sub SelStartSelLength(sStart as integer, sLen as integer) Ed.SelStart = sStart Ed.SelLength = sLen end sub sub iUndoCk defstr itemType$ = right$(Ls.item(undoPosition),1) defint LenUndo = Len(Ls.item(undoPosition)) defint UndoSelStart = val(LsN.item(undoPosition)) if (LenUndo = 1) then '//GENERAL_KEY SelStartSelLength( UndoSelStart, 1) Ed.SelText = "" Dec_undoPosition: showUndoPosition elseif (LenUndo > 1) then SELECT CASE itemType$ CASE "B": 'VK_BACK SelStartSelLength( UndoSelStart - Len(Ls.item(undoPosition))+1 , 1) Ed.SelText = left$(Ls.item(undoPosition),Len(Ls.item(undoPosition))-1)+Ed.SelText Ed.SelStart = UndoSelStart ' SelCorrectPosition Dec_undoPosition: showUndoPosition CASE "R": 'VK_RETURN SelStartSelLength( UndoSelStart, 2 ) Ed.SelText = "" Dec_undoPosition: showUndoPosition CASE "D": 'VK_DELETE SelStartSelLength( UndoSelStart, 0) Ed.SelText = left$(Ls.item(undoPosition),Len(Ls.item(undoPosition))-1) ' SelCorrectPosition Ed.SelStart = UndoSelStart Dec_undoPosition: showUndoPosition CASE "P": 'PASTE_KEY SelStartSelLength( UndoSelStart, Len(Ls.item(undoPosition))-1) Ed.SelText = "" Dec_undoPosition: showUndoPosition END SELECT end if DownKey = NONE_KEY '// protect onchange event end sub sub iRedoCk defint redoPosition = undoPosition+1 defint LenRedo = Len(Ls.item(redoPosition)) defstr ItemType$ = right$(Ls.item(redoPosition),1) defint RedoSelStart = val( LsN.item(redoPosition) ) if (LenRedo = 1) then '// GENERAL_KEY ' Develop defint ascRedo = asc(Ls.item(redoPosition)) select case ascRedo '// correct re-input my native language. case 209 to 218,231 to 237 SelStartSelLength( RedoSelStart, -RedoSelStart ) Ed.SelText = Ed.SelText+Ls.item(redoPosition) case else: SelStartSelLength( RedoSelStart, 1 ) Ed.SelText = Ls.item(redoPosition)+Ed.SelText end select ' SelCorrectPosition_Simple Inc_undoPosition: showUndoPosition elseif (LenRedo > 1) then SELECT CASE ItemType$ CASE "B": 'VK_BACK Ed.SelStart = RedoSelStart Ed.SelLength = -Len(Ls.item(redoPosition))+1 Ed.SelText = "" Inc_undoPosition: showUndoPosition CASE "R": 'VK_RETURN SelStartSelLength( RedoSelStart, 0 ) ' developing Ed.SelText = NEWLINE$ Inc_undoPosition: showUndoPosition CASE "D": 'VK_DELETE SelStartSelLength( RedoSelStart, Len(Ls.item(redoPosition))-1) Ed.SelText = "" Inc_undoPosition: showUndoPosition CASE "P": 'PASTE_KEY SelStartSelLength( RedoSelStart, 0 ) Ed.SelText = left$(Ls.item(redoPosition),Len(Ls.item(redoPosition))-1) ' SelCorrectPosition ' Ed.SelStart = RedoSelStart Inc_undoPosition: showUndoPosition END SELECT end if DownKey = NONE_KEY '// protect onchange event end sub sub iDelWordCk if (Ed.SelStart <> Len(Ed.Text)) then '// not add UndoList if SelStart at last position DelWord Ed.SelLength = Rspace Ed.SelText = "" end if end sub sub iBackWordCk if (Ed.selLength <> 0) then ' Del by hilights DelBackHilight Ed.SelText = "" ' delete else ' (Ed.SelLength = 0) ' Del by not hilights if (Ed.SelStart <> 0) then DelBack Ed.SelLength = -Lspace Ed.SelText = "" ' delete end if end if end sub sub iEditCk iUndo.Enabled = Not (undoPosition = -1) iRedo.Enabled = (undoPosition < LsN.itemCount - 1) 'iDelWord.Enabled = (Ed.SelStart < Len(Ed.Text)) 'iBackWord.Enabled = (Ed.SelStart > 0) iCut.Enabled = (Ed.SelLength > 0) iCopy.Enabled = iCut.Enabled 'v@lue31999 is max value of Len(Clipboard.Text) on my pc, Windows98se iPaste.Enabled = Not ((Len(Clipboard.Text) = 0) or (Len(Clipboard.Text) = 31999)) iSelAll.Enabled = (Len(Ed.Text) > 0) end sub sub iCutCk DelBackHilight Ed.CutToClipboard end sub sub iCopyCk Ed.CopyToClipboard end sub sub iPasteCk DownKey = PASTE_KEY selBegin = Ed.SelStart TextCount = Len(Ed.Text) Ed.PasteFromClipboard end sub sub iSelAllCk Ed.SelectAll end sub ' // PROPERTIES // Mn.parent = form Mn.Additems iEdit, iHelp iHelp.caption = "&help" iHelp.Additems iAbout iAbout.caption = "&about" iAbout.onclick = aboutShow iEdit.caption = "&Edit" iEdit.Additems iUndo, iRedo, iDelWord, iBackWord, iCut, iCopy, iPaste, iSelAll, iEditMode iEdit.onclick = iEditCk iUndo.caption = "&Undo" iUndo.shortcut = "Ctrl+Z" iUndo.onclick = iUndoCk iRedo.caption = "&Redo" iRedo.shortcut = "Ctrl+Y" iRedo.onclick = iRedoCk iDelWord.caption = "Del &Word" iDelWord.shortcut = "Ctrl+Del" iDelWord.onclick = iDelWordCk iBackWord.caption = "Del Word &Back" iBackWord.shortcut = "Ctrl+BkSp" iBackWord.onclick = iBackWordCk iCut.caption = "Cu&t" iCut.shortcut = "Ctrl+X" iCut.onclick = iCutCk iCopy.caption = "&Copy" iCopy.shortcut = "Ctrl+C" iCopy.onclick = iCopyCk iPaste.caption = "&Paste" iPaste.shortcut = "Ctrl+V" iPaste.onclick = iPasteCk iSelAll.caption = "Select &All" iSelAll.shortcut = "Ctrl+A" iSelAll.onclick = iSelAllCk iEditMode.caption = "Edit Mode" iEditMode.shortcut = "Ins" iEditMode.Enabled = 0 'iEditMode.onclick = iEditModeCk Ed.parent = form Ed.width = 225 Ed.height = 180 Ed.wanttabs = 1 Ed.onKeydown = edkbdown Ed.onChange = edbkbChg 'Ed.Text = "abc" with LsVal .parent = form .top = 185 .width = 375 .height = 75 .text = "Debug Box" end with LsUndoIndex.parent = form LsUndoIndex.Left = 230 LsUndoIndex.width = 30 LsUndoIndex.height = 180 LsUndoIndex.Columns = 1 LsUndoIndex.Clear Ls.parent = form Ls.Left = 265 Ls.width = 60 Ls.height = 180 Ls.Columns = 1 Ls.Clear LsN.parent = form LsN.Left = 325 LsN.width = 50 LsN.height = 180 LsN.Columns = 1 Ls.Clear Form.width = 390 Form.height = 310 Form.Caption = "UNDO/REDO BOX VERSION 1.0a" Form.ShowModal