Tweet
A useful PB IDE enhacement - see comments.
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:
'------------------------------------------------------------------------------
' 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
'------------------------------------------------------------------------------
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