Announcement

Collapse
1 of 2 < >

New Sub-Forum

In an effort to help make sure there are appropriate categories for topics of discussion that are happening, there is now a sub-forum for databases and database programming under Special Interest groups. Please direct questions, etc., about this topic to that sub-forum moving forward. Thank you.
2 of 2 < >

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

PBSnippets - use your favorite pieces of code in IDE

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

  • PBSnippets - use your favorite pieces of code in IDE

    A useful PB IDE enhacement - see comments.

    Code:
    '------------------------------------------------------------------------------
    '              PBSnippets - an easy way to manage your favorite pieces of code
    '
    ' It's a usual practice that when starting a new program, you look through your existing
    ' applications, copy pieces of code and paste them to a new one. I do it for years...:-)
    ' This simple program can help you to manage this task and save a lot of time. Put your
    ' favorite (often used) code pieces as named blocks to plain text file and then you need
    ' only 3 mouse clicks to paste them into your program text:
    ' First start PBSnippets - it runs minimized on the taskbar. Click it (1) - it's
    ' maximized, find and click (2) the name of your block - program hides again on the
    ' taskbar, focus returns to your editor and you have to click (3) "paste" to insert
    ' the whole block of code to the current place of caret.
    ' BTW, PB Staff: it's a very simple idea, so besides Program Templates, you can embed
    ' into PB IDE a possibility to write User-defined Code Templates (Tools --> User Code).
    ' IMHO it can make IDE more user-friendly and powerful. Meanwhile try this small app...
    '
    '    * Required data file see in the next post, its structure - below in the text.
    '    * Notice that you can launch this app with different files in COMMAND$, by default
    '      PBSnippets.txt is used.
    ' PUBLIC DOMAIN - FEEL FREE TO USE, MODIFY AND APPEND DATA FILE
    '                                                      Alex Art, 12.12.2007
    #COMPILE EXE "PBSnippets.exe"
    '------------------------------------------------------------------------------
    #INCLUDE "WIN32API.INC"
    
    %IDD_DIALOG1  =  101
    %IDC_LISTBOX1 = 1001
    %IDC_LABEL1   = 1002
    %IDC_BUTTON1  = 1003
    '------------------------------------------------------------------------------
    GLOBAL Arr$()
    GLOBAL Count&
    GLOBAL hFont AS DWORD
    GLOBAL hFont1 AS DWORD
    GLOBAL MaxLen&
    '------------------------------------------------------------------------------
    '   ** Declarations **
    '------------------------------------------------------------------------------
    DECLARE CALLBACK FUNCTION ShowDIALOG1Proc()
    DECLARE FUNCTION FillListBox(BYVAL hDlg AS DWORD, BYVAL lID AS LONG) AS LONG
    DECLARE FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
    DECLARE FUNCTION ReadDataFile(DatFil AS STRING) AS LONG
    '------------------------------------------------------------------------------
    '            MACROS:
    '---------------------------------------------------------------------------------
    ' A piece of PBForms.inc
    MACRO FUNCTION PBFormsMakeFont(sFntName, fFntSize, lWeight, lUnderlined, lItalic, lStrike, lCharSet)
        MACROTEMP       lf
        MACROTEMP       hDC
        MACROTEMP       lCyPixels
        DIM lf          AS LOGFONT
        DIM hDC         AS DWORD
        DIM lCyPixels   AS LONG
            hDC         = GetDC(%HWND_DESKTOP)
            lCyPixels   = GetDeviceCaps(hDC, %LOGPIXELSY)
            ReleaseDC %HWND_DESKTOP, hDC
        lf.lfHeight         = -(fFntSize * lCyPixels) \ 72
        lf.lfFaceName       = sFntName
        lf.lfPitchAndFamily = %FF_DONTCARE
            IF lWeight = %FW_DONTCARE THEN
                lf.lfWeight = %FW_NORMAL
            ELSE
                lf.lfWeight = lWeight
            END IF
            lf.lfUnderline  = lUnderlined
            lf.lfItalic     = lItalic
            lf.lfStrikeOut  = lStrike
            lf.lfCharSet    = lCharSet
    END MACRO = CreateFontIndirect(lf)
    
    '-------  SUBCLASSING MACROS - Colin's Schmidt code -----------------------
    '              can be used for any number of controls
    MACRO SubClass_Set(phDlg, phCtl, pProc)
        SetWindowLong GetDlgItem(phDlg, phCtl), %GWL_USERDATA, _
        SetWindowLong(GetDlgItem(phDlg, phCtl), %GWL_WNDPROC, CODEPTR(pProc))
    END MACRO
    MACRO SubClass_Kill(phCtl)
        SetWindowLong(GetDlgItem(CBHNDL, phCtl), %GWL_WNDPROC, GetWindowLong(CBHNDL, %GWL_USERDATA))
    END MACRO
    MACRO SubClass_OrgProc
        FUNCTION = CallWindowProc(GetWindowLong(hWnd, %GWL_USERDATA), hWnd, wMsg, wParam, lParam)
    END MACRO
    'End subclassing
    
    '------------------------------------------------------------------------------
    FUNCTION PBMAIN()
        Fil$=TRIM$(COMMAND$)
        IF Fil$="" THEN                                 ' No command string => Use default data file
                LOCAL buffer AS ASCIIZ * %MAX_PATH
                GetModuleFileName %NULL, Buffer, SIZEOF(Buffer) ' Who am I?
                Fil$=TRIM$(Buffer)                              '
                REPLACE ".exe" WITH ".txt" IN Fil$              ' My default file
        END IF
        IF ReadDataFile(Fil$)=0 THEN EXIT FUNCTION
        ShowDIALOG1 %HWND_DESKTOP
    END FUNCTION
    '------------------------------------------------------------------------------
    '                          Read & parse data file
    ' Structure: plain text file with block Names in square brackets. You click the
    ' Name and get corresponding block of code (body) to clipboard
    ' [Name-1]
    ' ........
    ' body = any your text
    ' ........
    ' [Name-2]
    ' ........
    '  etc....
    ' If "body" is empty - the first Name is Section Header - to make navigation
    ' more easy :
    ' [Sect.Header]
    ' [Header-1]
    ' ........
    ' See "PBSnippets.txt" in the next post as an example
    '------------------------------------------------------------------------------
    FUNCTION ReadDataFile (DatFil$) AS LONG
        IF DIR$(DatFil$)="" THEN FUNCTION=0: EXIT FUNCTION
        nf&=FREEFILE
        OPEN DatFil$ FOR BINARY AS #nf&
            GET$ #nf&,LOF(1),St$
        CLOSE #nf&
           Rec&=PARSECOUNT(St$,"[")
           REDIM Arr$(1, Rec&)
               Num&=PARSECOUNT(St$,$CRLF)-1
               Count&=0
               MaxLen&=0
               FOR i&=1 TO Num&
                   a$=PARSE$(St$,$CRLF,i&)
                   IF INSTR(1,a$,"[")<>0 THEN
                       INCR Count&
                       a$=REMOVE$(a$, ANY "[]")
                       Arr$(0,Count&)=a$ : La&=LEN(a$)
                       IF La&>MaxLen& THEN MaxLen&=La&
                                         ELSE
                                     Arr$(1,Count&)=Arr$(1,Count&)+a$+$CRLF
                   END IF
               NEXT i&
               ''''''' Center section headers
               FOR i&=1 TO Count&
                   IF Arr$(1,i&)="" THEN
                       Zg$=SPACE$(MaxLen&+4) : CSET Zg$=Arr$(0,i&)
                       Arr$(0,i&)=Zg$
                   END IF
               NEXT i&
    FUNCTION=1
    END FUNCTION
    
    '------------------------------------------------------------------------------
    SUB SetClipboard (Txt$)
    LOCAL lpMem AS ASCIIZ PTR
    LOCAL hMem  AS DWORD
         Txt$=Txt$+CHR$(0)
         hMem = GlobalAlloc(%GHND, LEN(Txt$) + 1)
         lpMem = GlobalLock(hMem)
         @lpMem = Txt$
           GlobalUnlock hMem
           OpenClipboard 0
           EmptyClipboard
           SetClipboardData %CF_TEXT , hMem
           CloseClipboard
    END SUB
    
    '------------------------------------------------------------------------------
    '      LISTBOX subclassing, based on Borje Hagsten's code
    '------------------------------------------------------------------------------
    FUNCTION ListBoxProc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                           BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
      SELECT CASE wMsg
         CASE %WM_DRAWITEM
            LOCAL hBrush AS LONG, hBrushOld AS LONG, rct AS RECT
            LOCAL lpdis  AS DRAWITEMSTRUCT PTR, zTxt AS ASCIIZ * 64
            lpdis = lParam
            IF @lpdis.itemID = -1 THEN EXIT FUNCTION
            It&[email protected]+1
    
            SELECT CASE @lpdis.itemAction
               CASE %ODA_DRAWENTIRE
                  'CLEAR BACKGROUND
                  hBrush = CreateSolidBrush(GetSysColor(%COLOR_WINDOW)) 'Create a background brush
                  hBrushOld = SelectObject(@lpdis.hDC, hBrush)      'Select brush into device context
                  CALL FillRect(@lpdis.hDC, @lpdis.rcItem, hBrush)  'Paint background color rectangle
                  CALL SelectObject(@lpdis.hDC, hBrushOld)          'Select old brush back
                  CALL DeleteObject(hBrush)                         'Delete brush
                  'DRAW TEXT
                       IF Arr$(1, It&)="" THEN
                           Fg&=RGB(0,0,220) : Bg&=RGB(255,255,200): Fnt&=hFont1
                           ELSE
                               Fg&=0 : Bg&=%WHITE : Fnt&=hFont
                       END IF
                  CALL SetBkColor(@lpdis.hDC, Bg&)          'Set text Background
                  CALL SetTextColor(@lpdis.hDC, Fg&)        'Set text color
                  CALL SendMessage(hWnd, %LB_GETTEXT, @lpdis.itemID, VARPTR(zTxt))     'Get text
                  CALL SelectObject(@lpdis.hDC, Fnt&)       'Select font
                  CALL TextOut(@lpdis.hDC, 2, @lpdis.rcItem.ntop + 2, zTxt, LEN(zTxt)) 'Draw text
    
               CASE %ODA_FOCUS
                 CALL DrawFocusRect(@lpdis.hDC, @lpdis.rcItem) 'draw focus rectangle
            END SELECT
      END SELECT
      SubClass_OrgProc
    END FUNCTION
    
    '------------------------------------------------------------------------------
    '   ** CallBacks **
    '------------------------------------------------------------------------------
    CALLBACK FUNCTION ShowDIALOG1Proc()
    
        SELECT CASE AS LONG CBMSG
            CASE %WM_INITDIALOG
                ' Initialization handler
                DIALOG SHOW STATE CBHNDL, %SW_MINIMIZE
    
            CASE %WM_DESTROY
                DeleteObject hFont
                DeleteObject hFont1
                SubClass_Kill(%IDC_LISTBOX1)
            CASE %WM_NCACTIVATE
                STATIC hWndSaveFocus AS DWORD
                IF ISFALSE CBWPARAM THEN
                    ' Save control focus
                    hWndSaveFocus = GetFocus()
                ELSEIF hWndSaveFocus THEN
                    ' Restore control focus
                    SetFocus(hWndSaveFocus)
                    hWndSaveFocus = 0
                END IF
    
            CASE %WM_COMMAND
                ' Process control notifications
                SELECT CASE AS LONG CBCTL
                    CASE %IDC_LISTBOX1
                       IF CBCTLMSG = %LBN_SELCHANGE OR CBCTLMSG = 1 THEN
                          CONTROL SEND CBHNDL, %IDC_LISTBOX1, %LB_GETCURSEL,0,0 TO Sel&
                          INCR Sel&
                          IF Arr$(1,Sel&)="" THEN EXIT SELECT
                          CALL SetClipboard (Arr$(1,Sel&))
                          DIALOG SHOW STATE CBHNDL, %SW_MINIMIZE
                        END IF
                    CASE %IDC_BUTTON1
                        IF CBCTLMSG = %BN_CLICKED OR CBCTLMSG = 1 THEN
                            DIALOG END CBHNDL
                        END IF
    
            END SELECT
         CASE %WM_DRAWITEM , %WM_MEASUREITEM ' To make listbox nice looking
            IF CBWPARAM = %IDC_LISTBOX1 THEN
               ListBoxProc GetDlgItem(CBHNDL, %IDC_LISTBOX1), CBMSG, CBWPARAM, CBLPARAM
               FUNCTION = 0: EXIT FUNCTION
            END IF
    
        END SELECT
    END FUNCTION
    
    '------------------------------------------------------------------------------
    FUNCTION FillListBox(BYVAL hDlg AS DWORD, BYVAL lID AS LONG) AS LONG
        FOR i& = 1 TO Count&
            LISTBOX ADD hDlg, lID, Arr$(0,i&)
        NEXT i&
    END FUNCTION
    '------------------------------------------------------------------------------
    
    FUNCTION ShowDIALOG1(BYVAL hParent AS DWORD) AS LONG
        LOCAL lRslt AS LONG
        LOCAL hDlg  AS DWORD
        LOCAL hList AS LONG
    
        DIALOG NEW hParent, "PB Snippets", 209,90 , MaxLen&*6+10, 195, %WS_POPUP OR _ ' %WS_CAPTION OR
           %WS_SYSMENU OR %WS_MINIMIZEBOX OR %WS_VISIBLE OR _
            %DS_CENTER OR %DS_3DLOOK, %WS_EX_LEFT OR %WS_EX_RIGHTSCROLLBAR, TO hDlg
            DIALOG SET COLOR hDlg, -1,RGB(120,120,220)
        CONTROL ADD LISTBOX, hDlg, %IDC_LISTBOX1, , 3, 2, MaxLen&*6+4, 182, _
        %WS_CHILD OR %LBS_OWNERDRAWFIXED OR %LBS_HASSTRINGS OR _
        %WS_TABSTOP OR %LBS_DISABLENOSCROLL OR %WS_VSCROLL, %WS_EX_CLIENTEDGE
        CONTROL ADD LABEL, hDlg, %IDC_LABEL1, "PB Snippets: Click-n-Paste",  10, 184, 145, 10
        CONTROL SET COLOR hDlg, %IDC_LABEL1, %WHITE,-2
        CONTROL ADD BUTTON, hDlg, %IDC_BUTTON1, "X", MaxLen&*6-5, 184, 12, 10
    
        hFont  = PBFormsMakeFont("Courier New", 10, %FW_NORMAL, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
        hFont1 = PBFormsMakeFont("Courier New", 10, %FW_BOLD, %FALSE, %FALSE, %FALSE, %DEFAULT_CHARSET)
        CONTROL SEND hDlg, %IDC_LISTBOX1, %WM_SETFONT, hFont, 0
        CONTROL SEND hDlg, %IDC_LABEL1, %WM_SETFONT, hFont1, 0
    
        FillListBox  hDlg, %IDC_LISTBOX1
    
        '''' Subclass listbox
          SubClass_Set(hDlg, %IDC_LISTBOX1, ListBoxProc)
    
        DIALOG SHOW MODAL hDlg, CALL ShowDIALOG1Proc TO lRslt
        FUNCTION = lRslt
    END FUNCTION
    '------------------------------------------------------------------------------
    Data file - feel free to modify, thanks to Colin Schmidt, Semen Matusovsky and others... If you add some useful snippets, maybe post them here. No error checking - please observe file format while editing.
    Save as "PBSnippets.txt".


    Code:
    [GENERAL]
    [FOR:NEXT - 1]
        FOR i&=1 to Num&      ''' Names to edit: i&, Num&
    
        NEXT i&
    [FOR:NEXT - 2]
        FOR i&=1 to Num1&     ''' Names to edit: i&, Num1&
            FOR j&=1 to Num2& ''' Names to edit: j&, Num2&
    
            NEXT j&
        NEXT i&
    [FOR:NEXT - 3]
        FOR i&=1 to Num1&          ''' Names to edit: i&, Num1&
            FOR j&=1 to Num2&      ''' Names to edit: j&, Num2&
                FOR k&=1 to Num3&  ''' Names to edit: k&, Num3&
    
                NEXT k&
            NEXT j&
        NEXT i&
    [IF:THEN:ELSE]
          IF  THEN
    
                  ELSE
    
          END IF
    [SELECT:CASE]
          SELECT CASE
                 CASE
    
                 CASE
    
                 CASE ELSE
    
          END SELECT
    [FILE R/W]
    [File-to-String]
    ''''' Reading file into string buffer '''
        FilNam$=""  ''' Delete or write filename
        nf&=FREEFILE
        OPEN FilNam$ FOR BINARY AS #nf&
            GET$ #nf&,LOF(1),Buff$     ''' Name to edit: Buff$
        CLOSE #nf&
    [File-to-String_Array]
    ''''' Reading file into string Array '''
        FilNam$=""  ''' Delete or write filename
        nf&=FREEFILE
        OPEN FilNam$ FOR BINARY AS #nf&
            GET$ #nf&,LOF(1),Buff$
        CLOSE #nf&
        Num&=PARSECOUNT(Buff$,$CRLF)-1  ''' Name to edit: Num&
          REDIM Arr$(1 TO Num&)
          PARSE Buff$,Arr$(),$CRLF      ''' Name to edit: Arr$()
          Buff$=""                      ''' Delete if you still need Buff$
    [String-to-File]
    ''''' Print string buffer Buff$ to file'''
        FilNam$=""  ''' Delete or write filename
        IF DIR$(FilNam$)<>"" then KILL FilNam$
        nf&=FREEFILE
        OPEN FilNam$ FOR BINARY AS #nf&
            PUT$ #nf&,Buff$             ''' Name to edit: Buff$
        CLOSE #nf&
    [String_Array-to-File]
    ''''' Print string array Arr$()  to file'''
        FilNam$=""  ''' Delete or write filename
        Buff$=JOIN$(Arr$(),$CRLF)       ''' Name to edit: Arr$()
        IF DIR$(FilNam$)<>"" then KILL FilNam$
        nf&=FREEFILE
        OPEN FilNam$ FOR BINARY AS #nf&
            PUT$ #nf&,Buff$
        CLOSE #nf&
          Buff$=""                      ''' Delete if you still need Buff$
    
    [CLIPBOARD]
    [Text-to-Clipboard]
    ''''' Write text string Buff$ to clipboard '''
    LOCAL lpMem AS ASCIIZ PTR
    LOCAL hMem  AS DWORD
         Buff$=Buff$+CHR$(0)            ''' Name to edit: Buff$
         hMem = GlobalAlloc(%GHND, LEN(Buff$) + 1)
         lpMem = GlobalLock(hMem)
         @lpMem = Buff$
         GlobalUnlock hMem
         OpenClipboard 0
         EmptyClipboard
         SetClipboardData %CF_TEXT , hMem
         CloseClipboard
    [Clipboard-to-Text]
    ''''' Read clipboard into text string Buff$ '''
    LOCAL lpMem AS ASCIIZ PTR
      OpenClipboard(0)
      lpMem=GetClipboardData(%CF_TEXT)
      [email protected]                    ''' Name to edit: Buff$
      CloseClipboard()
    [Bitmap-to-Clipboard]
    ''''' Put bitmap (handle: hBMP) to clipboard '''
    GLOBAL(LOCAL) hBmp As Dword ''' BMP handle
      OpenClipboard (0)
      EmptyClipboard ()
      SetClipboardData(%CF_BITMAP, hBmp)
      CloseClipboard()
    
    [TOOLTIPS]
    [1.To INCLUDE section]
        #INCLUDE "COMMCTRL.INC" ''' Delete if already included
    [2.To GLOBALS section]
    GLOBAL hToolTips AS DWORD
    [3.To PBMAIN]
       CALL InitCommonControls  ''' Delete if already called
    [4.After each CONTROL ADD]
         ''' Dialog handle, Control ID, Your text for TT
    CALL SetToolTip (hToolTips, GetDlgItem(hDlg, %IDC_****), "* text *")
    [5.Main code - paste somewhere]
    ' Create ToolTips control if needed.
    FUNCTION ToolTip_Create (lToolTips AS LONG, BYVAL hWnd AS LONG) AS LONG
      IF lToolTips = 0 THEN
         IF hWnd = 0 THEN hWnd = GetActiveWindow()
         IF hWnd = 0 THEN EXIT FUNCTION
         lToolTips = CreateWindowEx(0, "tooltips_class32", "", %TTS_ALWAYSTIP , _
                 0, 0, 0, 0, hWnd, BYVAL 0&, GetModuleHandle(""), BYVAL %NULL)
      END IF
      FUNCTION = lToolTips
    END FUNCTION
    '''' Set ToolTip
    FUNCTION SetToolTip (lToolTips AS LONG, BYVAL hWnd AS LONG, BYVAL txt AS STRING) AS LONG
      LOCAL ti AS TOOLINFO
      LOCAL St AS ASCIIZ*20
      IF ToolTip_Create(lToolTips, GetParent(hWnd)) = 0 THEN EXIT FUNCTION 'ensure creation
      ti.cbSize   = LEN(ti)
      ti.uFlags   = %TTF_SUBCLASS OR %TTF_IDISHWND
      ti.hWnd     = GetParent(hWnd)
      ti.uId      = hWnd
      'Remove existing tooltip
      IF SendMessage (lToolTips, %TTM_GETTOOLINFO, 0, BYVAL VARPTR(ti)) THEN
         SendMessage lToolTips, %TTM_DELTOOL, 0, BYVAL VARPTR(ti)
      END IF
      ti.cbSize   = LEN(ti)
      ti.uFlags   = %TTF_SUBCLASS OR %TTF_IDISHWND
      ti.hWnd     = GetParent(hWnd)
      ti.uId      = hWnd
      ti.lpszText = STRPTR(txt)
      FUNCTION = SendMessage(lToolTips, %TTM_ADDTOOL, 0, BYVAL VARPTR(ti)) 'add tooltip
    END FUNCTION
    
    [SUBCLASSING]
    [1.Add before any your code]
    '-------  SUBCLASSING MACROS: can be used for any number of controls -----------------
    MACRO SubClass_Set(phDlg, phCtl, pProc)
        SetWindowLong GetDlgItem(phDlg, phCtl), %GWL_USERDATA, _
        SetWindowLong(GetDlgItem(phDlg, phCtl), %GWL_WNDPROC, CODEPTR(pProc))
    END MACRO
    MACRO SubClass_Kill(phCtl)
        SetWindowLong(GetDlgItem(CBHNDL, phCtl), %GWL_WNDPROC, GetWindowLong(CBHNDL, %GWL_USERDATA))
    END MACRO
    MACRO SubClass_OrgProc
        FUNCTION = CallWindowProc(GetWindowLong(hWnd, %GWL_USERDATA), hWnd, wMsg, wParam, lParam)
    END MACRO
    'End subclassing
    [2.To %WM_DESTROY of main callback]
                ''' Remove subclass
                SubClass_Kill(%IDC_****) ''' Control ID here
    [3.After your CONTROL ADD]
          ''' (Dialog handle, Control ID, Name of you callback proc)
          SubClass_Set(hDlg, %IDC_****, ****CBProc)
    [4.Skeleton of your callback proc]
    '''' Callback procedure - change name, edit message IDs, write your code
    FUNCTION ****CBProc(BYVAL hWnd AS LONG, BYVAL wMsg AS LONG, _
                           BYVAL wParam AS LONG, BYVAL lParam AS LONG) AS LONG
      SELECT CASE wMsg
         CASE %WM_      ''' Message
                 ''' Your code
         CASE %WM_
    
      END SELECT
      SubClass_OrgProc
    END FUNCTION
    Last edited by Alexander Artyukhov; 12 Dec 2007, 07:17 AM.
    SY: Alex [email protected]
Working...
X