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

Sub + Function lister

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

  • Sub + Function lister

    Code:
    '----------------------------------------------
    '   DECS.BAS for 32-bit PB/DLL
    '   This is a bare-bones no-frills program for creating lists of subs and functions
    '   in a project. It does what I want it to do, but feel free to improve it for your
    '   own needs (plenty of scope here!).
    '   I have a main BAS file plus 8 INC files, and it is a nightmare finding subs and functions
    '   in the files. This appends the filename to each sub/function name.
    '   Create a list, load it in PB editor to find those routines you had forgotten about.
    '   Resource file could be replaced by DDT.
    '   Up to 25 INC files allowed - change references to 25 as required
    '   Donated to the PB fraternity by Iain Johnstone
    '----------------------------------------------
    ' ** Eliminate unnecessary macros
    %NOANIMATE    = 1
    %NODRAGLIST   = 1
    %NOHEADER     = 1
    %NOIMAGELIST  = 1
    %NOLISTVIEW   = 1
    %NOTABCONTROL = 1
    %NOTRACKBAR   = 1
    %NOTREEVIEW   = 1
    %NOUPDOWN     = 1
    '----------------------------------------------
    $DIM ALL
    $COMPILE EXE
    $OPTION VERSION4
    
    $INCLUDE "WIN32API.INC"
    $INCLUDE "COMDLG32.INC"
    $RESOURCE "DECS.PBR"
    '----------------------------------------------
    DECLARE SUB General ()
    DECLARE SUB GetBasFile ()
    DECLARE SUB GetIncs ()
    DECLARE SUB SearchBAS ()
    DECLARE SUB SearchIncs ()
    DECLARE SUB SaveTxt (NameOFile AS STRING)
    DECLARE SUB DexSearchBAS()
    DECLARE SUB DexSearchIncs()
    DECLARE SUB CenterWindow(BYVAL hWnd AS LONG)
    '----------------------------------------------
    'declarations
        GLOBAL Cancelflag    AS INTEGER
        GLOBAL hInst         AS LONG
        GLOBAL hWndMain      AS LONG
        GLOBAL hDlg          AS LONG
        GLOBAL counter       AS LONG
        GLOBAL crlf          AS STRING
        GLOBAL NameOfBASFile AS STRING
        GLOBAL NameOfINCFile AS STRING
        GLOBAL BASfile       AS ASCIIZ*100000
    '----------------------------------------------
    FUNCTION WINMAIN (BYVAL hInstance     AS LONG, _
                      BYVAL hPrevInstance AS LONG, _
                      lpCmdLine           AS ASCIIZ PTR, _
                      BYVAL iCmdShow      AS LONG) AS LONG
    
      LOCAL Msg         AS tagMsg
      LOCAL wndclass    AS WndClassEx
      LOCAL szClassName AS ASCIIZ * 80
      LOCAL hWnd        AS LONG
      LOCAL hMenu       AS LONG
    
      General
    
      hInst                  = hInstance
      crlf=CHR$(10,13)
      szClassName            = "lister"
    
      wndclass.cbSize        = SIZEOF(WndClass)
      wndclass.style         = %CS_HREDRAW OR %CS_VREDRAW
      wndclass.lpfnWndProc   = CODEPTR( WndProc )
      wndclass.cbClsExtra    = 0
      wndclass.cbWndExtra    = 0
      wndclass.hInstance     = hInstance
      wndclass.hIcon         = LoadIcon( hInstance, "PROGRAM" )
      wndclass.hCursor       = LoadCursor( %NULL, BYVAL %IDC_ARROW )
      wndclass.hbrBackground = GetStockObject( %WHITE_BRUSH )
      wndclass.lpszMenuName  = %NULL
      wndclass.lpszClassName = VARPTR( szClassName )
      wndclass.hIconSm       = LoadIcon( hInstance, BYVAL %IDI_APPLICATION )
    
      RegisterClassEx wndclass
      hMenu = LoadMenu(hInstance, "MAINMENU")
    
      ' Create a window using the registered class
      hWndMain = CreateWindow(szClassName, _               ' window class name
                              "SUB & FUNCTION lister", _ ' window caption
                              %WS_OVERLAPPEDWINDOW, _      ' window style
                              %CW_USEDEFAULT, _            ' initial x position
                              %CW_USEDEFAULT, _            ' initial y position
                              %CW_USEDEFAULT, _            ' initial x size
                              %CW_USEDEFAULT, _            ' initial y size
                              %HWND_DESKTOP, _             ' parent window handle
                              hMenu, _                     ' window menu handle
                              hInstance, _                 ' program instance handle
                              BYVAL %NULL)                 ' creation parameters
    
    
      ShowWindow hWndMain, iCmdShow
      UpdateWindow hWndMain
    
      WHILE GetMessage(Msg, %NULL, 0, 0)
        TranslateMessage Msg
        DispatchMessage Msg
      WEND
    
      FUNCTION = msg.wParam
    
    END FUNCTION  ' WinMain
    '==============================================
    SUB General
        DIM datastring (1 TO 2000) AS GLOBAL STRING
        DIM IncFile(1 TO 25) AS GLOBAL STRING
    
    END SUB
    '==============================================
    FUNCTION WndProc (BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                      BYVAL wParam AS LONG, BYVAL lParam AS LONG) EXPORT AS LONG
    
      LOCAL dwproc AS LONG
      LOCAL tempint AS INTEGER
      LOCAL n AS INTEGER
      LOCAL q AS INTEGER
      local tempstring as string
      SELECT CASE wMsg
    
        CASE %WM_CREATE
          CenterWindow hWnd
          for n=1 to 1000:datastring(n)="":next
    
        CASE %WM_COMMAND
          SELECT CASE LOWRD(wParam)
            CASE 100 'CREATE LIST
                for n=1 to 1000:datastring(n)="":next
                 'select bas file
                 GetBasFile
                 IF cancelflag=1 THEN cancelflag=0:EXIT SELECT
                 'include all incs in same directory
                 tempint=MSGBOX ("Include *.INC files in the same directory?",%MB_YESNO OR %MB_TASKMODAL ,"DECS.EXE")
                    FOR n=1 TO 25
                     IncFile(n)=""
                    NEXT
                 IF tempint=%IDYES THEN GetIncs
                IF cancelflag=1 THEN cancelflag=0:EXIT SELECT
                 'search bas file for subs and functions - put search results into string and append current file name
                 counter=1
                 SearchBAS
                 'load inc files in turn and repeat search - put search results into string and append current file name
                 IF tempint=%IDYES THEN SearchIncs
                 'sort strings to alphabetical
                  ARRAY SORT datastring(), COLLATE UCASE, ASCEND
                  'save as txt file
                 SaveTxt "DECS.TXT"
                 MSGBOX STR$(counter)+" Subs and functions saved as DECS.TXT in source directory."
                'source=source directory of BAS file being searched
    
    
            CASE 999 'exit prog
                    tempint = MSGBOX ("Are you sure you want to quit?",%MB_YESNO OR %MB_TASKMODAL, "Message")
                    IF tempint = %IDYES THEN
                         EndDialog hWndMain,0
                         PostQuitMessage 0
                    END IF
                    FUNCTION = 0
                    EXIT FUNCTION
    
          END SELECT
    
        CASE %WM_PAINT
    
        CASE %WM_SYSCOMMAND
            SELECT CASE LOWRD(wParam)
               CASE %sc_close
                 tempint = MSGBOX ("Are you sure you want to quit?",%MB_YESNO OR %MB_TASKMODAL, "Message")
                 IF tempint = %IDYES THEN
                     EndDialog hWndMain,0
                     PostQuitMessage 0
                 END IF
                 FUNCTION = 0
                 EXIT FUNCTION
            END SELECT
    
    
        CASE %WM_DESTROY
          PostQuitMessage 0
          FUNCTION = 0
          EXIT FUNCTION
    
      END SELECT
    
      FUNCTION = DefWindowProc(hWnd, wMsg, wParam, lParam)
    
    END FUNCTION
    
    '----------------------------------------------
    SUB CenterWindow(BYVAL hWnd AS LONG)
        DIM WndRect AS RECT
        DIM x       AS LONG
        DIM y       AS LONG
      GetWindowRect hWnd, WndRect
    
      x = (GetSystemMetrics(%SM_CXSCREEN)-(WndRect.nRight-WndRect.nLeft))\2
      y = (GetSystemMetrics(%SM_CYSCREEN)-(WndRect.nBottom-WndRect.nTop+GetSystemMetrics(%SM_CYCAPTION)))\2
    
      SetWindowPos hWnd, %NULL, x, y, 0, 0, %SWP_NOSIZE OR %SWP_NOZORDER
    
    END SUB
    '==============================================
    SUB GetBasFile
        LOCAL Filter$
        LOCAL Dext$
        LOCAL flags as dword
        LOCAL zfile$
        LOCAL N AS INTEGER
        LOCAL templong AS LONG
        LOCAL filepath AS STRING
    
            NameOfBASFile=""
            Filter$="BAS file   *.BAS|*.BAS|Include file   *.INC|*.INC"
            DExt$="BAS"
    
            flags=0
    
            templong=OpenFileDialog (hDlg, "Select BAS file",NameOfBASFile,FilePath,Filter$,DExt$,flags)
            IF templong<>1 THEN Cancelflag=1:EXIT SUB
            n=INSTR(-1,NameOfBASFile,"\")
            NameOfBASFile=RIGHT$(NameOfBASFile,LEN(NameOfBASFile)-n)
    END SUB
    '==============================================
    SUB GetIncs
        LOCAL Filter$
        LOCAL Dext$
        LOCAL flags as dword
        LOCAL zfile$
        LOCAL N AS INTEGER
        LOCAL q AS INTEGER
    
        LOCAL templong AS LONG
        LOCAL filepath AS STRING
    
        REDIM IncFile(1 TO 25) AS GLOBAL STRING
    
            NameOfINCFile=""
            Filter$="Include file   *.INC|*.INC|BAS file   *.BAS|*.BAS"
            DExt$="INC"
    
            flags=%OFN_ALLOWMULTISELECT
    
            templong=OpenFileDialog (hDlg, "Select INC files",NameOfINCFile,FilePath,Filter$,DExt$,flags)
            IF templong<>1 THEN Cancelflag=1:EXIT SUB
    
            q=TALLY(UCASE$(NameOfINCFile),"INC")
            IF q=1 THEN
               n=INSTR(-1,NameOfINCFile,"\")'do this for one file
            ELSE
               n=INSTR(NameOfINCFile," ")'do this for more than one file
            END IF
    
            NameOfINCFile=RIGHT$(NameOfINCFile,LEN(NameOfINCFile)-n)'strip off path
            NameOfINCFile=LTRIM$(NameOfINCFile)'remove leading spaces
    
            FOR q=1 TO 25 'break up long string
               n=INSTR(NameOfINCFile," ")
               IF n=0 THEN
                  IncFile(q)=TRIM$(NameOfINCFile)':exit for
               ELSE
                  IncFile(q)=TRIM$(LEFT$(NameOfINCFile,n))
               END IF
               NameOfINCFile=LTRIM$(REMOVE$(NameOfINCFile,IncFile(q)))
               IF LEN(NameOfINCFile)<4 THEN EXIT FOR
            NEXT
    END SUB
    '==============================================
    SUB SearchBAS
    
       LOCAL filesize AS LONG
       LOCAL temp AS STRING
       LOCAL n AS LONG
       LOCAL q AS LONG
       LOCAL p AS LONG
       LOCAL r AS LONG
    
       BASfile="":r=1
          OPEN NameOfBASFile FOR BINARY AS #5
            filesize=LOF(5)
          CLOSE #5
          OPEN NameOfBASFile FOR BINARY AS #1
            SEEK #1,1
            GET$ #1,filesize,BASfile
         CLOSE #1
    
          DO
          n=INSTR(r,BASfile,"SUB ")
          q=INSTR(n+2,BASfile,CHR$(13))
          p=INSTR(n+2,BASfile,"(")
          IF n=0 THEN EXIT LOOP
          IF p>q THEN 'no open brackets after sub name
            datastring(counter)=MID$(BASfile,n,q-n)+" - "+NameOfBASFile
          ELSE
            datastring(counter)=MID$(BASfile,n,p-n)+" - "+NameOfBASFile
          END IF
            INCR counter:r=q
          LOOP UNTIL r>filesize-50
    
          r=1
          DO
          n=INSTR(r,BASfile,"FUNCTION ")
          q=INSTR(n,BASfile,CHR$(13))
          p=INSTR(n,BASfile,"(")
          IF n=0 THEN EXIT LOOP
          IF p>q THEN 'no open brackets after function name
            datastring(counter)=MID$(BASfile,n,q-n)+" - "+NameOfBASFile
          ELSE
            datastring(counter)=MID$(BASfile,n,p-n)+" - "+NameOfBASFile
          END IF
            IF INSTR(datastring(counter),"=")<>0 THEN
               datastring(counter)=""
               decr counter 'get rid of function=1 etc
            end if
           INCR counter:r=q
          LOOP UNTIL r>filesize-50
    END SUB
    '==============================================
    SUB SearchIncs
    
       LOCAL filesize AS LONG
       LOCAL temp AS STRING
       LOCAL n AS LONG
       LOCAL q AS LONG
       LOCAL p AS LONG
       LOCAL r AS LONG
       LOCAL x AS INTEGER
       FOR x=1 TO 25
         if IncFile(x)="" then exit for
         NameOfBASFile=IncFile(x)
         r=1:BASfile=""
          OPEN NameOfBASFile FOR BINARY AS #5
            filesize=LOF(5)
          CLOSE #5
    
          OPEN NameOfBASFile FOR BINARY AS #1
            SEEK #1,1
            GET$ #1,filesize,BASfile
          CLOSE #1
    
          DO
          n=INSTR(r,BASfile,"SUB ")
          q=INSTR(n,BASfile,CHR$(13))
          p=INSTR(n,BASfile,"(")
          IF n=0 THEN EXIT LOOP
          IF p>q THEN 'no open brackets after sub name
            datastring(counter)=MID$(BASfile,n,q-n)+" - "+NameOfBASFile
          ELSE
            datastring(counter)=MID$(BASfile,n,p-n)+" - "+NameOfBASFile
          END IF
          INCR counter:r=q
          LOOP UNTIL r>filesize-50
    
          r=1
          DO
          n=INSTR(r,BASfile,"FUNCTION ")
          q=INSTR(n,BASfile,CHR$(13))
          p=INSTR(n,BASfile,"(")
          IF n=0 THEN EXIT LOOP
          IF p>q THEN 'no open brackets after function name
            datastring(counter)=MID$(BASfile,n,q-n)+" - "+NameOfBASFile
          ELSE
            datastring(counter)=MID$(BASfile,n,p-n)+" - "+NameOfBASFile
          END IF
            IF INSTR(datastring(counter),"=")<>0 THEN
               datastring(counter)=""
               decr counter 'get rid of function=1 etc
            end if
          INCR counter:r=q
          LOOP UNTIL r>filesize-50
       NEXT
    END SUB
    '==============================================
    SUB SaveTxt (NameOFile AS STRING)
       LOCAL n AS INTEGER
            OPEN NameOFile FOR OUTPUT AS #5
              FOR n=1 TO 2000
                IF datastring(n)<>"" THEN print #5,datastring(n)
              NEXT
            CLOSE #5
    END SUB
     
     
     
    '==============================================
    '=========== Resource file ====================
    '====== extract and save as DECS.RC ===========
    '==============================================
    'check that #include is in lower case
    '==============================================
    '#include "resource.h"
    '
    'MAINMENU MENU
    '{
    ' POPUP "Files"
    ' {
    '  MENUITEM "Create dec list", 100
    '  MENUITEM SEPARATOR
    '  MENUITEM "Exit program", 999
    ' }
    '}
    '
    'VS_VERSION_INFO VERSIONINFO
    'FILEVERSION 1, 0, 0, 0
    'PRODUCTVERSION 1, 0, 0, 0
    'FILEOS VOS_WINDOWS32
    'FILETYPE VFT_APP
    '{
    ' BLOCK "StringFileInfo"
    ' {
    '  BLOCK "040904E4"
    '  {
    '   VALUE "CompanyName", "Hydrologic (IT) Ltd\0"
    '   VALUE "FileDescription", "Application\0"
    '   VALUE "FileVersion", "Version 1.0\0"
    '   VALUE "InternalName", "dex\0"
    '   VALUE "OriginalFilename", "DECS.EXE\0"
    '   VALUE "LegalCopyright", "PB users\0"
    '   VALUE "LegalTrademarks", "\0"
    '   VALUE "ProductName", "DECS\0"
    '   VALUE "ProductVersion", "Version 1.0\0"
    '   VALUE "Comments", "Released to public domain\0"
    '  }
    ' }
    '}


    ------------------
    “None but those who have experienced them can conceive of the enticements of science” - Mary Shelley
Working...
X