Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

currency adding machine

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • currency adding machine

    simple adding machine

    the program has 20 lines of view using a listbox as a template.

    this is a on going project, something i have wanted a long since i first used computers.
    any special features will be found under the help button.


    here is the discussion are started prior to this listing
    http://powerbasic.com/support/pbforu...d.php?p=270377

    I used the sample code from the source code section that was placed by Erik Christensen as a template.
    http://www.powerbasic.com/support/pb...ad.php?t=23158
    some notes from Erik at that location
    thanks to borje hagsten and lance edmonds for their inspirational influence on the present code.
    the code skeleton was generated by ezgui freeware dialog designer
    by christopher r. boss see web site at ezgui.com.
    unused code has been removed to improve clarity.


    Any minor or otherwise updates should make it first to
    http://pdptemp.dyndns.org/zipcode


    Code:
    
    'compiled with pbwin 8.04
    'paulcalc.bas
    
    #COMPILE EXE
    #REGISTER NONE
    '#DIM ALL
    %NOANIMATE    = 1
    %NOCOMBO      = 1
    %NODRAGLIST   = 1
    %NOHEADER     = 1
    %NOIMAGELIST  = 1
    %NOLISTVIEW   = 1
    %NOSTATUSBAR  = 1
    %NOTABCONTROL = 1
    %NOTOOLBAR    = 1
    %NOTOOLTIPS   = 1
    %NOTREEVIEW   = 1
    %NOUPDOWN     = 1
    #INCLUDE "win32api.inc"
    #INCLUDE "commctrl.inc"
    '
    %ListBox            = 100
    %TextOfListItems    = 105
    %RowHeaderList      = 110
    %ExitButton         = 115
    %HelpButton         = 116
    %OnTopButton        =114
    %DimmerButton       = 117
    %DimmerDimButton     = 118
    %DimmerBrightButton  = 119
    %DimmerBrighterButton  = 113
    
    %itemcount          = 120
    %VertScrollbar      = 135
    %EditDescript       = 145
    '
    %EditLabel          = 400
    %EditText           = 410
    %EditOK             = 415
    %EditCancel         = 420
    %Totalsum           = 425
    %Edittext1          = 421
    %Edittext2          = 422
    
    ' --------------------------------------------------
    DECLARE SUB ShowListDialog(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION ListDialogProc
    DECLARE CALLBACK FUNCTION EditDialogProc
    DECLARE SUB EditCellForm(BYVAL hParent&)
    DECLARE CALLBACK FUNCTION CBF_ListBox()
    DECLARE CALLBACK FUNCTION CBF_HeaderBox()
    DECLARE CALLBACK FUNCTION CBF_Exit()
    DECLARE FUNCTION CBF_Exxit() AS STRING
    DECLARE FUNCTION Clearcells() AS STRING
    DECLARE FUNCTION beginClearcells() AS STRING
    
    DECLARE FUNCTION SetClipboardText (BYVAL sText AS STRING) AS LONG
    
    DECLARE CALLBACK FUNCTION CBF_Help()
    DECLARE CALLBACK FUNCTION CBF_OnTop()
    DECLARE CALLBACK FUNCTION CBF_Dimmer()
    DECLARE CALLBACK FUNCTION CBF_Dimmerdim()
    DECLARE CALLBACK FUNCTION CBF_Dimmerbright()
    DECLARE CALLBACK FUNCTION CBF_Dimmerbrighter()
    DECLARE CALLBACK FUNCTION CBF_EditText()
    DECLARE CALLBACK FUNCTION CBF_EditOK()
    DECLARE CALLBACK FUNCTION CBF_EditCancel()
    DECLARE SUB UpdateWindowAndScrollbar (BYVAL yPos AS LONG)
    ' --------------------------------------------------
    'DECLARE MakeFont(FONT AS STRING, PointSize AS LONG) AS LONG
    
    
    
    
    GLOBAL Brush&
    GLOBAL hListForm&           ' Dialog handle
    GLOBAL hEditForm&           ' Dialog handle
    
    GLOBAL Rows AS LONG         ' Total number of rows in array
    
    GLOBAL PageRows AS LONG     ' Number of rows on a page
    
    GLOBAL DataArray() AS STRING' One dimensional text array to be displayed
    GLOBAL siY AS SCROLLINFO
    GLOBAL PrevKey AS LONG      ' Previously pressed key
    GLOBAL gOldSubClassList&
    GLOBAL gOldSubClassEdit&
    GLOBAL PresCursPos AS LONG  ' Present cursor position in grid list box
    GLOBAL CursCorr AS LONG     ' Correction used to place cursor correctly
    GLOBAL SelY AS LONG         ' Row selected
    GLOBAL XCR!,YCR!            ' conversion factors from pixels to dialog units
    GLOBAL XMaxScr AS LONG
    GLOBAL YMaxScr AS LONG
    
    
    GLOBAL Gtotalsum AS CURRENCYX 'DOUBLE
    GLOBAL Gtotalcount AS LONG
    GLOBAL gAutoinsertnew AS LONG
    GLOBAL hFONT AS LONG
    GLOBAL hGTFONT AS LONG
    GLOBAL gDimmer AS LONG
    GLOBAL gOntop  AS LONG
    GLOBAL gpaulsyprevpos AS LONG
    GLOBAL gOldcellvalue AS STRING
    
    
    
    
    FUNCTION MakeFont(BYVAL FFont AS STRING, BYVAL PointSize AS LONG) AS LONG
      LOCAL hDC      AS LONG
      LOCAL CyPixels AS LONG
      hDC = GetDC(%HWND_DESKTOP)
      CyPixels  = GetDeviceCaps(hDC, %LOGPIXELSY)
      ReleaseDC %HWND_DESKTOP, hDC
      PointSize = (PointSize * CyPixels) \ 72
      FUNCTION = CreateFont(0 - PointSize, 0, 0, 0, %FW_NORMAL, 0, 0, 0, _
                %ANSI_CHARSET, %OUT_TT_PRECIS, %CLIP_DEFAULT_PRECIS, _
                %DEFAULT_QUALITY, %FF_DONTCARE, BYCOPY FFont)
    END FUNCTION
    
    
    ' --------------------------------------------------
    '
    FUNCTION PBMAIN
        LOCAL hDC AS LONG
        LOCAL Count&
        LOCAL CC1 AS INIT_COMMON_CONTROLSEX
        gautoinsertnew=-1&
    
        CC1.dwSize=SIZEOF(CC1)
        CC1.dwICC=%ICC_WIN95_CLASSES
        InitCommonControlsEX CC1
        Brush&=CreateSolidBrush(RGB(196,196,196))  ' light grey
        ShowListDialog 0
    
        CALL beginclearcells()
        IF gAutoinsertnew =-1& THEN
            CALL prepareforedit
        END IF
    
        DO
         DIALOG DOEVENTS TO Count&
          IF  SLOWDOWNCOUNT& MOD 10000 =0  THEN SLEEP 1:SLOWDOWNCOUNT&=0
          INCR SLOWDOWNCOUNT&
        LOOP UNTIL Count&=0
        DeleteObject Brush&
    END FUNCTION
    ' --------------------------------------------------
    '
    
    
    
    FUNCTION XDU(XPct AS SINGLE) AS LONG  ' X transformation function just for this program
        XDU=XPct*430*0.01/XCR!
    END FUNCTION
    '
    FUNCTION YDU(YPct AS SINGLE) AS LONG  ' Y transformation function just for this program
        YDU=YPct*543*0.01/1.90
    END FUNCTION
    '
    SUB ShowListDialog(BYVAL hParent&)
        LOCAL Style&, ExStyle&,hCtl&,i&,j&
        LOCAL X&,Y&,X1&,Y1&,hDlg&,res&
        LOCAL hSYSMENU AS LONG
    
        XMaxScr=GetSystemMetrics(%SM_CXFULLSCREEN)
        IF XMaxScr >800 THEN XMaxScr=800
        YMaxScr=GetSystemMetrics(%SM_CYFULLSCREEN)
        IF YMaxScr >543 THEN YMaxScr=543
        X&=300: Y&=200
        DIALOG NEW 0,"",,,X&,Y&, %WS_VISIBLE, TO hDlg&
        DIALOG UNITS hDlg&, X&, Y& TO PIXELS X1&, Y1&
        DIALOG END hDlg&
        XCR!=X1&*10000/X&: XCR!=XCR!/10000
        YCR!=Y1&*10000/Y&: YCR!=YCR!/10000
        '
        ' Specification of size of array.
        ' You may test other size.
        Rows=99999
        '
        ' The listbox routines are made for array no less than (20)
        Rows=MAX(20,Rows)
        REDIM DataArray(1:Rows)
        ' Fill array with data
        FOR j&=1 TO Rows
            DataArray(j&)=""
        NEXT
        Style& = %WS_POPUP OR %DS_MODALFRAME OR %WS_CAPTION OR %WS_THICKFRAME OR %WS_MINIMIZEBOX OR %WS_SYSMENU OR %DS_CENTER OR %WS_EX_TOPMOST
        ExStyle& = 0
        DIALOG NEW hParent&, "Adding machine", 0, 0,XDU(58),YDU(73.5), Style&, ExStyle& TO hListForm&
        CONTROL ADD LISTBOX, hListForm&,%ListBox, , XDU(.25),YDU(4.65),XDU(42.5),YDU(69.4), _
           %WS_CHILD OR %WS_VISIBLE OR %LBS_NOTIFY OR %WS_BORDER OR %WS_TABSTOP CALL CBF_ListBox
    
        CONTROL ADD SCROLLBAR, hListForm&,%VertScrollbar,"" , XDU(56.1),YDU(4.65),XDU(2.5),YDU(65.2), _
            %WS_CHILD OR %WS_VISIBLE OR %SBS_VERT
    
        CONTROL ADD LISTBOX, hListForm&,  %RowHeaderList, ,XDU(43.00),YDU(4.65),XDU(12.5),YDU(69.4), _
            %WS_CHILD OR %WS_VISIBLE OR %LBS_NOTIFY OR %WS_BORDER OR %WS_TABSTOP CALL CBF_HeaderBox
    
        CONTROL ADD BUTTON, hListForm&,  %ExitButton,  "&X",XDU(.25),YDU(70),XDU(5),YDU(3.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Exit
        CONTROL ADD BUTTON, hListForm&,  %HelpButton,  "&Help",XDU(5.25),YDU(70),XDU(7),YDU(3.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Help
    
        CONTROL ADD BUTTON, hListForm&,  %DimmerbrightButton,  "Bright",XDU(12.25),YDU(70),XDU(9),YDU(3.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Dimmerbright
        CONTROL ADD BUTTON, hListForm&,  %DimmerbrighterButton,  "+",XDU(21.25),YDU(70),XDU(3),YDU(3.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Dimmerbrighter
    
    
    
        CONTROL ADD BUTTON, hListForm&,  %DimmerDimButton,"Clear",XDU(24.25),YDU(70),XDU(8),YDU(3.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Dimmerdim
        CONTROL ADD BUTTON, hListForm&,  %DimmerButton,  "-",XDU(32.25),YDU(70),XDU(3),YDU(3.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_Dimmer
    
        CONTROL ADD BUTTON, hListForm&,  %OntopButton,  "top",XDU(36),YDU(70),XDU(6.5),YDU(3.43), _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_ontop
    
        CONTROL ADD LABEL, hListForm&,  %itemcount,"", XDU(45),YDU(0.0),XDU(10),YDU(2.35), _
            %WS_CHILD OR %WS_VISIBLE OR %SS_RIGHT
    
        CONTROL ADD TEXTBOX, hListForm&,  %Totalsum,"", XDU(.25),YDU(.00),XDU(42.5),YDU(4.2), %SS_RIGHT OR %ES_READONLY OR %WS_BORDER, %WS_EX_WINDOWEDGE
    
        hFONT = GetStockObject(%SYSTEM_FIXED_FONT)
        'hGTFONT = MakeFont("Courier New Bold",12)
    
        'remove the close box in the gui
        EnableMenuItem GetSystemMenu(hlistform&, 0), %SC_CLOSE, %MF_BYCOMMAND OR %MF_GRAYED
    
        DIALOG SHOW MODELESS hListForm& , CALL ListDialogProc
        CONTROL SEND hListForm&,%ListBox,%WM_SETFONT,hFONT,%TRUE
        CONTROL SEND hListForm&,%RowHeaderList,%WM_SETFONT,hFONT,%TRUE
        CONTROL SEND hListForm&,%Totalsum,%WM_SETFONT,hFONT,%TRUE
          [email protected]@
          gtotalcount=0&
          FOR j&=1 TO Rows
            IF LEN(TRIM$(dataarray(j&))) THEN INCR gtotalcount:gtotalsum=gtotalsum+VAL(REMOVE$(DataArray(j&),","))
        NEXT
    
        CONTROL SET TEXT hListForm&, %Totalsum, FORMAT$(gtotalsum,"#,.00")
        CONTROL SET TEXT hListForm&, %itemcount, FORMAT$(gtotalcount,"#,0")
        GDimmer=100
    
    END SUB
    ' --------------------------------------------------
    '
    CALLBACK FUNCTION ListDialogProc
        LOCAL hCtl&,j&,Result&
        SELECT CASE CBMSG
             CASE %WM_INITDIALOG
                CONTROL HANDLE CBHNDL, %ListBox TO hCtl&
                gOldSubClassList = SetWindowLong(hCtl&, %GWL_WNDPROC, CODEPTR(SubClassListKeys))
                '
                ' Number of rows in a displayed page
                PageRows=20
                '
                ' The scrollbar control bits are based on a fine example
                ' by Lance Edmonds in the source code forum.
                '
                ' Define vertical scrollbar
                siY.cbSize = SIZEOF(siY)
                siY.fMask  = %SIF_ALL   ' = %SIF_RANGE OR %SIF_PAGE OR %SIF_POS
                siY.nMin   = 1
                siY.nMax   = Rows
                siY.nPage  = PageRows
                siY.nPos   = 1
                CONTROL SEND CBHNDL, %VertScrollbar, %SBM_SETSCROLLINFO, %FALSE, VARPTR(siY)
                '
                ' Fill window with data
                CALL UpdateWindowAndScrollbar (siY.nPos)
           CASE %WM_VSCROLL
                SELECT CASE LOWRD(CBWPARAM)
                    CASE %SB_LINEDOWN      : INCR siY.nPos
                    CASE %SB_PAGEDOWN      : siY.nPos = siY.nPos + siY.nPage - 1
                    CASE %SB_LINEUP        : DECR siY.nPos
                    CASE %SB_PAGEUP        : siY.nPos = siY.nPos - siY.nPage + 1
                    CASE %SB_THUMBTRACK,%SB_THUMBPOSITION
                        ' This code allows for tracking above the 16-bit limit (65536) of HIWRD
                        ' Proposed by Borje Hagsten
                        siY.cbSize = SIZEOF(siY)
                        siY.fMask  = %SIF_TRACKPOS
                        CONTROL SEND CBHNDL, %VertScrollbar, %SBM_GETSCROLLINFO,0, VARPTR(siY)
                        siY.nPos   = siY.nTrackPos
                    CASE ELSE              : EXIT FUNCTION
                END SELECT
                ' Ensure that position is within range
                siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
                ' Reset previous key flag
                PrevKey = 0
               ' MSGBOX STR$(siy.npos)
                 CALL UpdateWindowAndScrollbar (siY.nPos)
            CASE %WM_DESTROY
                ' Important! Remove the subclassing
                SetWindowLong hCtl&, %GWL_WNDPROC, gOldSubClassList
            ' -----------------------------------------------
            CASE %WM_CTLCOLORMSGBOX , %WM_CTLCOLORBTN, %WM_CTLCOLOREDIT,_
                 %WM_CTLCOLORSTATIC, %WM_CTLCOLORSCROLLBAR, %WM_CTLCOLORLISTBOX
                ' Control colors
                SELECT CASE GetDlgCtrlID(CBLPARAM)
                    CASE %RowHeaderList
                        SetTextColor CBWPARAM, RGB(0,0,0)
                        SetBkColor   CBWPARAM, RGB(196,196,196)
                        FUNCTION=Brush&
                    CASE ELSE
                        FUNCTION=0
                END SELECT
            CASE ELSE
    
        END SELECT
        ' Enable redrawing of listbox
        CONTROL SEND hListForm&,%ListBox,%WM_SETREDRAW,%TRUE,0 TO Result&
    
    END FUNCTION
    ' --------------------------------------------------
    CALLBACK FUNCTION SubClassListKeys
        ' Subclass callback function for processing key messages.
        ' Inspired by Lance Edmonds who provided a fine example in the Source Code Forum
        ' Completed after valuable feedback by Semen Matusovski and Borje Hagsten.
        LOCAL Result&
        '
        SELECT CASE CBMSG
            ' The %WM_GETDLGCODE message is sent to the dialog box procedure
            ' associated with a control. Normally, Windows handles all arrow-key
            ' and TAB-key input to the control.
            ' By responding to the %WM_GETDLGCODE message, an application can
            ' take control of a particular type of input and process the input itself.
    
    
             CASE %WM_GETDLGCODE
                ' Specifies that the only extra key we want to be available is
                ' the ENTER key (= %VK_RETURN) (chr$(13)).
                ' This particular expression was proposed by Borje Hagsten
                IF CBWPARAM = %VK_RETURN  THEN
                    FUNCTION = %DLGC_WANTALLKEYS : EXIT FUNCTION
                END IF
            CASE %WM_KEYDOWN ' Keys at time of pressing
                ' The statements below for UP, DOWN, LEFT and RIGHT move are adjusted for
                ' the "internal" automatic movement produced by the listbox.
                SELECT CASE CBWPARAM
                    CASE %VK_LEFT,%VK_UP
                        IF PrevKey=%VK_UP THEN
                            IF PresCursPos <= 1 THEN DECR siY.nPos  : CursCorr=1
                        ELSEIF PrevKey<>%VK_DOWN  THEN
                            IF PresCursPos  = 0 THEN DECR siY.nPos  : CursCorr=1
                        END IF
                    CASE %VK_RIGHT,%VK_DOWN
                        IF PrevKey=%VK_DOWN THEN
                            IF PresCursPos >= PageRows - 2 THEN INCR siY.nPos : CursCorr=-1
                        ELSEIF PrevKey<>%VK_UP THEN
                            IF PresCursPos  = PageRows - 1 THEN INCR siY.nPos : CursCorr=-1
                        END IF
                    ' The selection movements for PGUP and PGDN are the "internal" automatic listbox movements.
                    ' You may improve them.
    
    
                    CASE %VK_PGUP  :   siY.nPos = siY.nPos - siY.nPage + 1
                    CASE %VK_PGDN  :   siY.nPos = siY.nPos + siY.nPage - 1
                    '
                    CASE %VK_HOME  :   siY.nPos = 0
                    CASE %VK_END   :   siY.nPos = Rows
                    CASE ELSE
    
    
                END SELECT
    
                PrevKey = CBWPARAM
                ' Ensure that positions are within range
                siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
                CALL UpdateWindowAndScrollbar (siY.nPos)
            CASE %WM_KEYUP ' Keys at time of release (not used)
              SELECT CASE CBWPARAM ' Holds the code of the key.
                    ' Specify what action should be taken for each key code.
                    CASE %VK_F2,%VK_INSERT ' The F2 or Insert key was pressed to edit a line
                        ' Ensure that a cell is selected before editing.
                        ' Otherwise you will have a fatal error !
                        CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 TO Result&
                        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, Result&,-1
                        CALL PrepareForEdit
                        EXIT FUNCTION
    
    
            CASE %WM_CHAR  ' Any character key at time of pressing
              REM   REMARKED OUT BY PAUL PURVIS
              REM  SELECT CASE CBWPARAM ' Holds the code of the key.
              REM      ' Specify what action should be taken for each key code.
              REM      CASE 13 ' ENTER pressed
              REM          ' Ensure that a cell is selected before editing.
              REM          ' Otherwise you will have a fatal error !
              REM          CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 TO Result&
              REM          CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, Result&,-1
              REM          CALL PrepareForEdit
              REM          EXIT FUNCTION
              REM
              REM      END SELECT
    
                    ' Specify what action should be taken for each key code.
    
                   CASE 88 ' x key pressed
                       CALL cbf_exxit()
                       EXIT FUNCTION
    
    
    
                   CASE 69 ' e key pressed
                      CALL clearcells()
                      EXIT FUNCTION
    
                   CASE 67 ' c key pressed
                      'copies only the grandtotal to the clipboard
                      CALL SetClipboardText(TRIM$(REMOVE$(STR$(gtotalsum), ANY ", ")))
                      EXIT FUNCTION
                   CASE 78 ' n key pressed
                      'copies the grandtotal to the clipboad with a cr and lf added
                      CALL SetClipboardText(TRIM$(REMOVE$(STR$(gtotalsum), ANY ", "))+$CRLF)
                      EXIT FUNCTION
    
              CASE ELSE ' No action to be taken here for the other keys.
              END SELECT
    
    
    
    
        IF gAutoinsertnew =1& THEN
                     'msgbox str$(prescurspos)
                     INCR siy.npos
                     'IF PresCursPos+1 >= (PageRows - 1) THEN decr siY.nPos : CursCorr=-1
                     'incr siy.npos
                     siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
                     CALL UpdateWindowAndScrollbar (siY.nPos)
                     CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 TO Result&
                     CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, Result&,-1
                     CALL PrepareForEdit
                     EXIT FUNCTION
    
        END IF
    
    
         END SELECT
        ' Pass the message on to the original window procedure... the DDT engine!
        FUNCTION = CallWindowProc(gOldSubClassList, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
    END FUNCTION
    ' --------------------------------------------------
    SUB UpdateWindowAndScrollbar (BYVAL yPos AS LONG)
        ' Updates the listbox data to be presented after scrolling.
        LOCAL j&,Res&
        STATIC yPrevPos AS LONG  ' previous y-position (remember between calls)
        CONTROL SEND hListForm&,%ListBox,%LB_GETCURSEL,0,0 TO PresCursPos
        IF yPos<>yPrevPos THEN ' Moved
            CONTROL SEND hListForm&,%ListBox,%WM_SETREDRAW,%FALSE,0 TO Res&
            ' Update vertical scroll bar
            siY.fMask = %SIF_POS
            CONTROL SEND hListForm&, %VertScrollbar, %SBM_SETSCROLLINFO, %TRUE, VARPTR(siY)
            CONTROL SEND hListForm&,%RowHeaderList,%LB_RESETCONTENT,0,0
            CONTROL SEND hListForm&,%ListBox,%LB_RESETCONTENT,0,0
            FOR j&=yPos TO yPos + PageRows - 1
                ' Update row header list
                LISTBOX ADD hListForm&,%RowHeaderList,STR$(j&)
                ' Update window data
                LISTBOX ADD hListForm&,%ListBox,DataArray(j&)
            NEXT
        END IF
        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,PresCursPos+CursCorr,0
        IF PrevKey = 0 THEN ' Deselect cursor at list position zero
            CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,0,0
            CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,-1,0
        END IF
        CursCorr = 0 ' Reset correction of selection position
        ' New "previous" position to be remembered for the next update call
        yPrevPos=yPos
     END SUB
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_ListBox
        DIM J AS LONG
        IF CBCTLMSG=%LBN_DBLCLK THEN CALL PrepareForEdit
    
    END FUNCTION
    ' ------------------------------------------------
    SUB PrepareForEdit
        LOCAL buffer AS ASCIIZ * 28 '256
        LOCAL CVal&
        LOCAL tempstring AS STRING        'added by paul purvis
        LOCAL tempstring2 AS STRING       'added by paul purvis
        LOCAL J AS LONG
    
        ' Return Current Selection in CVal&
        CONTROL SEND hListForm&,%ListBox, %LB_GETCURSEL, 0,0 TO CVal&
        ' Get array index corresponding to selected cell
        SelY = siY.nPos + CVal&
        gOLDCELLvalue=TRIM$(dataarray(sely))
    
    
    
    
    REM -----------------------------------------------------------------------------------------------------------------------------------
    
        backtoeditcellform:           'added by paul purvis
        dataarray(sely)=TRIM$(REMOVE$(dataarray(sely),","))
        CALL EditCellForm(hListForm&) ' Edit cell - new text to data array
                                     'beginning of block added by paul purvis
        dataarray(sely)=TRIM$(REMOVE$(dataarray(sely),ANY ", "))
    
        tempstring=dataarray(sely)
        IF TALLY(tempstring,"-")>0 THEN
            IF (LEFT$(tempstring,1)="-") THEN tempstring=RIGHT$(tempstring,(LEN(tempstring)-1))
            IF (RIGHT$(tempstring,1)="-") THEN tempstring=LEFT$(tempstring,(LEN(tempstring)-1))
            IF TALLY(tempstring,"-")>0 THEN GOTO backtoeditcellform
            tempstring="-"+tempstring
        END IF
        dataarray(sely)=tempstring
    
        IF TALLY(tempstring,".")>0 THEN
             IF TALLY(tempstring,".") > 1 THEN GOTO backtoeditcellform
             IF INSTR(tempstring,".") < (LEN(tempstring)-2) THEN GOTO backtoeditcellform
        END IF
        tempstring2=TRIM$(REMOVE$(tempstring, ANY "-0123456789."))
    
        IF LEN(tempstring2)>0 THEN GOTO backtoeditcellform
        IF (VAL(dataarray(sely)) >   [email protected]@) OR  (VAL(dataarray(sely)) < [email protected]@) THEN GOTO backtoeditcellform
        IF LEN(dataarray(sely))=0 THEN
              dataarray(sely)=""
              ELSE
              IF VAL(dataarray(sely))[email protected]@ THEN
                dataarray(sely)="0.00"
                ELSE
                IF TALLY(dataarray(sely),".")=0 THEN dataarray(sely)=TRIM$(STR$(VAL(dataarray(sely))*[email protected]@))
                END IF
        END IF
    
        IF LEN(dataarray(sely))>0 THEN tempstring=FORMAT$(VAL(dataarray(sely)),"#,.00")
        dataarray(sely)=RIGHT$("                           "+tempstring,22)
                                      'ending of block added by paul purvis
    
        buffer = DataArray(SelY) ' new text from data array to buffer
        ' Update ListBox with new text
    
        CONTROL SEND hListForm&,%ListBox,%LB_DELETESTRING,CVal&,0
        CONTROL SEND hListForm&,%ListBox,%LB_INSERTSTRING,CVal&,VARPTR(buffer)
        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, CVal&,-1
    
        [email protected]@
        gtotalcount=0&
        FOR j=1 TO Rows
         IF LEN(TRIM$(dataarray(j&))) THEN INCR gtotalcount:gtotalsum=gtotalsum+VAL(REMOVE$(DataArray(j),","))
        NEXT
        CONTROL SET TEXT hListForm&, %Totalsum, FORMAT$(gtotalsum,"#,.00")
        CONTROL SET TEXT hListForm&, %itemcount, FORMAT$(gtotalcount,"#,0")
        gAutoinsertnew=0&
        IF SELY<rows  THEN
            IF LEN(TRIM$(dataarray(sely))) THEN IF LEN(TRIM$(dataarray(sely+1)))=0 THEN gAutoinsertnew=1&:gpaulsyprevpos=cval&
        END IF
    
    END SUB
    
    FUNCTION CBF_Exxit AS STRING
        LOCAL res&
        res&=MSGBOX ("Are you sure that you want"+$CRLF+"to exit the adding machine?",_
        %MB_YESNO OR %MB_ICONERROR OR %MB_DEFBUTTON2 OR %MB_TASKMODAL ,"Exit adding machine?")
    
         IF res&=%IDYES THEN
            res&=MSGBOX ("Entries will be lost"+$CRLF+"Are double sure you want"+$CRLF+"to exit the adding machine?",_
               %MB_YESNO OR %MB_ICONERROR OR %MB_DEFBUTTON2 OR %MB_TASKMODAL,"Exit adding machine?")
            IF res&=%IDYES THEN  DIALOG END hListForm&
         END IF
    
    END FUNCTION
    
    FUNCTION clearcells AS STRING
        LOCAL res&
        res&=MSGBOX ("Clear all numbers in adding machine?",_
        %MB_YESNO OR %MB_ICONWARNING OR %MB_DEFBUTTON2 OR %MB_TASKMODAL ,"Clear adding machine?")
    
         IF res&=%IDYES THEN
            res&=MSGBOX ("ALL ENTRIES WILL BE LOST!"+$CRLF+"Are double sure you want?",_
               %MB_YESNO OR %MB_ICONWARNING OR %MB_DEFBUTTON2 OR %MB_TASKMODAL,"Clear adding machine?")
            IF res&<>%IDYES THEN EXIT FUNCTION
    
                       [email protected]@
                       FOR gtotalcount=1 TO Rows
                       dataarray(gtotalcount)=""
                       NEXT
                       gtotalcount=0&
    
                       siY.nMin   = 1
                       siY.nMax   = Rows
                       siY.nPage  = PageRows
                       siY.nPos   = rows-pagerows+1
                       prescurspos= 0
    
                      siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
                      CALL UpdateWindowAndScrollbar (siY.nPos)
                      CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 TO Result&
                      CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, Result&,-1
    
                       siY.nMin   = 1
                       siY.nMax   = Rows
                       siY.nPage  = PageRows
                       siY.nPos   = 1
                       prescurspos= 0
                       curscorr=1
    
    
                      siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
    
                      CALL UpdateWindowAndScrollbar (siY.nPos)
                      CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 TO Result&
                      CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, 0,-1
                      CONTROL SET TEXT hListForm&, %Totalsum, FORMAT$(gtotalsum,"#,.00")
                      CONTROL SET TEXT hListForm&, %itemcount, FORMAT$(gtotalcount,"#,0")
         END IF
    
    END FUNCTION
    
    FUNCTION beginclearcells AS STRING
    
                       [email protected]@
                       FOR gtotalcount=1 TO Rows
                       dataarray(gtotalcount)=""
                       NEXT
                       gtotalcount=0&
    
                       siY.nMin   = 1
                       siY.nMax   = Rows
                       siY.nPage  = PageRows
                       siY.nPos   = rows-pagerows+1
                       prescurspos= 0
    
                      siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
                      CALL UpdateWindowAndScrollbar (siY.nPos)
                      CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 TO Result&
                      CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, Result&,-1
    
                       siY.nMin   = 1
                       siY.nMax   = Rows
                       siY.nPage  = PageRows
                       siY.nPos   = 1
                       prescurspos= 0
                       curscorr=1
    
    
                      siY.nPos = MAX&(siY.nMin, MIN&(siY.nPos, siY.nMax - siY.nPage + 1))
    
                      CALL UpdateWindowAndScrollbar (siY.nPos)
                      CONTROL SEND hListForm&,%ListBox,%LB_GETCARETINDEX,0,0 'TO 0
                      CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL, 0,-1
                      CONTROL SET TEXT hListForm&, %Totalsum, FORMAT$(gtotalsum,"#,.00")
                      CONTROL SET TEXT hListForm&, %itemcount, FORMAT$(gtotalcount,"#,0")
    END FUNCTION
    
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_HeaderBox
        ' set focus to %ListBox
        CONTROL SET FOCUS hListForm&, %ListBox
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_Exit
        LOCAL res&
    
        res&=MSGBOX ("Are you sure that you want"+$CRLF+"to exit the adding machine?",_
           %MB_YESNO OR %MB_ICONERROR OR %MB_DEFBUTTON2 OR %MB_TASKMODAL,"Exit adding machine?")
    
        IF res&=%IDYES THEN
            res&=MSGBOX ("Entries will be lost"+$CRLF+"Are double sure you want"+$CRLF+"to exit the adding machine?",_
              %MB_YESNO OR %MB_ICONERROR OR %MB_DEFBUTTON2 OR %MB_TASKMODAL ,"Exit adding machine?")
           IF res&=%IDYES THEN  DIALOG END hListForm&
        END IF
    END FUNCTION
    
    CALLBACK FUNCTION CBF_Help
        MSGBOX "F2, Insert, or Double-Click to add/edit."+$CRLF+_
        "E to erase numbers adding machine"+$CRLF+_
        "C to copy grandtotal to the clipboard"+$CRLF+_
        "N to as above with a carriage return and line feed."+$CRLF+_
        "X or alt-X to quit",_
        %MB_TASKMODAL OR %MB_ICONINFORMATION ,"Adding machine help"
    END FUNCTION
    
    CALLBACK FUNCTION CBF_Dimmerbright
    gDimmer=100&
      SetWindowLong(CBHNDL, %GWL_EXSTYLE,  GetWindowLong(CBHNDL, %GWL_EXSTYLE) OR %WS_EX_LAYERED)
      SetLayeredWindowAttributes(CBHNDL, 0, (255 * gDimmer) / 100, %LWA_ALPHA)
    END FUNCTION
    
    CALLBACK FUNCTION CBF_Dimmerdim
    gDimmer=50&
      SetWindowLong(CBHNDL, %GWL_EXSTYLE,  GetWindowLong(CBHNDL, %GWL_EXSTYLE) OR %WS_EX_LAYERED)
      SetLayeredWindowAttributes(CBHNDL, 0, (255 * gDimmer) / 100, %LWA_ALPHA)
    END FUNCTION
    CALLBACK FUNCTION CBF_DimmerBrighter
      IF Gdimmer<20 THEN gdimmer=gdimmer+2& ELSE gDimmer=gdimmer+5&
      IF gDimmer> 100& THEN gDimmer=100&
      SetWindowLong(CBHNDL, %GWL_EXSTYLE,  GetWindowLong(CBHNDL, %GWL_EXSTYLE) OR %WS_EX_LAYERED)
      SetLayeredWindowAttributes(CBHNDL, 0, (255 * gDimmer) / 100, %LWA_ALPHA)
    END FUNCTION
    
    CALLBACK FUNCTION CBF_Dimmer
      IF gdimmer<21 THEN gdimmer=gdimmer-2& ELSE gDimmer=gdimmer-5&
      IF gDimmer< 6& THEN gDimmer=6&
      SetWindowLong(CBHNDL, %GWL_EXSTYLE,  GetWindowLong(CBHNDL, %GWL_EXSTYLE) OR %WS_EX_LAYERED)
      SetLayeredWindowAttributes(CBHNDL, 0, (255 * gDimmer) / 100, %LWA_ALPHA)
    END FUNCTION
    
    CALLBACK FUNCTION CBF_onTop
    IF GOnTop THEN
        gontop=0&
        CONTROL SET TEXT CBHNDL, %OntopBUTTON, "top"
     ELSE
        gontop=1&
        CONTROL SET TEXT CBHNDL, %OntopBUTTON, "TOP"
    END IF
    END FUNCTION
    
    
    
    
    '
    ' ------------------------------------------------
    ' Code section for editing of cell text
    ' ------------------------------------------------
    '
    SUB EditCellForm(BYVAL hListForm&) ' make and display edit form
        LOCAL Style&, ExStyle&
        Style& = %WS_POPUP OR %DS_MODALFRAME ' OR %WS_CAPTION 'OR %DS_CENTER
        ExStyle& = 0
        DIALOG NEW hListForm&, "Edit item "+STR$(SelY), -1, 12,  164,  28, Style&, ExStyle& TO hEditForm&
        CONTROL ADD TEXTBOX, hEditForm&,  %EditText,  DataArray(SelY), 6, 2, 90, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %WS_TABSTOP,%WS_EX_CLIENTEDGE
        ' The following two statements deselect the text and place caret at the end of the text.
        CONTROL SEND hEditForm&, %EditText,%EM_SETSEL,0,-1  ' select all text
        CONTROL SEND hEditForm&, %EditText,%EM_SETSEL,-1,-1 ' deselect text
        CONTROL ADD BUTTON, hEditForm&,  %EditOK,  "&OK", 110, 1, 20, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_EditOK
        CONTROL ADD BUTTON, hEditForm&,  %EditCancel,  "&Cancel", 132, 1, 30, 12, _
            %WS_CHILD OR %WS_VISIBLE OR %BS_PUSHBUTTON OR %WS_TABSTOP CALL CBF_EditCancel
         CONTROL SEND hEditForm&,%EditText,%WM_SETFONT,hFONT,%TRUE
         CONTROL ADD LABEL, hEditForm&,  %Edittext1,gOLDCELLVALUE, 7,17,87,12, %SS_LEFT
         CONTROL ADD LABEL,  hEditForm&,  %Edittext2,"Item "+TRIM$(STR$(SELY)), 96,17,68,12, %SS_RIGHT
         CONTROL SEND hEditForm&,%EditText1,%WM_SETFONT,hFONT,%TRUE
         CONTROL SEND hEditForm&,%EditText2,%WM_SETFONT,hFONT,%TRUE
    
          DIALOG SHOW MODAL hEditForm&, CALL EditDialogProc
    
    
    END SUB
    ' ------------------------------------------------
    CALLBACK FUNCTION EditDialogProc
        LOCAL hCtl&,j&,Result&
         SELECT CASE CBMSG
            CASE %WM_INITDIALOG
                CONTROL HANDLE CBHNDL, %EditText TO hCtl&
                gOldSubClassEdit& = SetWindowLong(hCtl&, %GWL_WNDPROC, CODEPTR(SubClassEditKeys))
            CASE %WM_DESTROY
                ' Important! Remove the subclassing
                SetWindowLong hCtl&, %GWL_WNDPROC, gOldSubClassEdit&
            CASE ELSE
        END SELECT
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION SubClassEditKeys
        ' Subclass callback function for processing key messages in edit control (textbox).
        ' Completed after valuable feedback by Semen Matusovski and Borje Hagsten.
        LOCAL Result&
        '
        SELECT CASE CBMSG
            '
            ' The %WM_GETDLGCODE message is sent to the dialog box procedure
            ' associated with a control. Normally, Windows handles all arrow-key
            ' and TAB-key input to the control.
            ' By responding to the %WM_GETDLGCODE message, an application can
            ' take control of a particular type of input and process the input itself.
            CASE %WM_GETDLGCODE
                ' Specifies that we want all keys entered in the textbox to be
                ' available here.
                FUNCTION = %DLGC_WANTALLKEYS: EXIT FUNCTION
            CASE %WM_KEYDOWN ' Keys at time of pressing (not used here)
            CASE %WM_KEYUP   ' Keys at time of release (not used here)
            CASE %WM_CHAR    ' Any character key at time of pressing
                SELECT CASE CBWPARAM ' Holds the code of the key.
                    ' Specify what action should be taken for each key code.
                    CASE 13 ' ENTER pressed
                        CONTROL GET TEXT hEditForm&,%EditText TO DataArray(SelY)
                        CONTROL SEND hListForm&,%ListBox,%LB_SETCURSEL,-1,0 ' deselect cell
                        DIALOG END hEditForm&
                        EXIT FUNCTION
                    CASE 27 ' ESCAPE pressed
                        DIALOG END hEditForm&
                        EXIT FUNCTION
                    CASE ELSE ' No action to be taken here for the other keys.
                END SELECT
    
        END SELECT
        ' Pass the message on to the original window procedure... the DDT engine!
        FUNCTION = CallWindowProc(gOldSubClassEdit&, CBHNDL, CBMSG, CBWPARAM, CBLPARAM)
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_EditOK
        ' update data array with edited text
        CONTROL GET TEXT hEditForm&,%EditText TO DataArray(SelY)
        DIALOG END hEditForm&
    END FUNCTION
    ' ------------------------------------------------
    CALLBACK FUNCTION CBF_EditCancel
        DIALOG END hEditForm&
    END FUNCTION
    
    FUNCTION SetClipboardText (BYVAL sText AS STRING) AS LONG
        LOCAL hData AS LONG
        LOCAL hGlob AS LONG
        ' ** Create a global memory object and copy the data into it
        hData = GlobalAlloc(%GMEM_MOVEABLE, LEN(sText)+1)
        hGlob = GlobalLock(hData)
        POKE$ hGlob, sText + CHR$(0)
        GlobalUnlock hData
        ' ** Open the clipboard
        IF ISFALSE(OpenClipboard(%Null)) THEN
            GlobalFree hData
            ? "Can't reach clipboard!!", %mb_taskmodal, "Warning"
            EXIT FUNCTION
        END IF
        ' ** Paste the data into the clipboard
        EmptyClipboard
        FUNCTION = SetClipboardData(%CF_TEXT, hData)
        CloseClipboard
    END FUNCTION
    Last edited by Paul Purvis; 6 Dec 2007, 08:19 PM.
    p purvis
Working...
X