Date: 02-16-2022
Return to Index
created by gbSnippets
'Compilable Example: (Jose Includes)
#Compiler PBWin 9, PBWin 10
#Compile EXE
#Dim All
%Unicode=1
#Debug Error On 'catch array/pointer errors - OFF in production
#Debug Display On 'display untrapped errors - OFF in production
#Include "Win32api.inc"
%IDC_Graphic = 500
Global hDlg, hDC, memDC, hBMP, hGraphic As Dword
Global pt, ptDrawOrig, truept As Point
Global DrawInWork, SnapToGrid, ShowGrid, iMsgCount, GridSize As Long
Global x1,y1,x2,y2 As Long
Function PBMain() As Long
Local w,h As Long
Desktop Get Size To w,h
Dialog New Pixels, 0, "",0,0,w,h, %WS_Popup To hDlg
Control Add Graphic, hDlg, %IDC_Graphic, "", 0,0,w,h
Control Handle hDlg, %IDC_Graphic To hGraphic
Graphic Attach hDlg, %IDC_Graphic
Dialog Show Modal hDlg Call DlgProc
End Function
CallBack Function DlgProc() As Long
Local i,x,y,w,h,iReturn As Long
Select Case Cb.Msg
Case %WM_InitDialog
CreateInvisibleBitmap
CaptureScreen
Case %WM_Paint
RefreshDrawing '1=PB 0=API
Case %WM_SetCursor
Dialog Get Client hDlg To w,h
GetCursorPos pt : ScreenToClient hDlg, pt
Select Case Hi(Word, Cb.LParam) 'monitors the 3 basic mouse actions, lbuttondown, mousemose, lbuttonup
Case %WM_LButtonDown
If (pt.x>-1) And (pt.x<(w+1)) And (pt.y>0) And (pt.y<h) Then 'inside GUI bounds
DrawInWork = 1
ptDrawOrig = pt
End If
Case %WM_MouseMove
If DrawInWork Then
RefreshDrawing
End If
Case %WM_LButtonUp
If DrawInWork Then
DrawInWork = 0
RefreshDrawing
End If
End Select
End Select
End Function
Sub RefreshDrawing 'using PB Bitmap
Local i,x,y,w,h As Long
Dialog Get Client hDlg To w,h
Graphic Clear 'clear/fill with color
If DrawInWork Then Graphic Box (ptDrawOrig.x, ptDrawOrig.y) - (pt.x, pt.y),, %Red 'draw rectangle that follows the mouse
hDC = GetDC(hDlg)
BitBlt hDC, 0, 0, w, h, memDC, 0, 0, %SRCCopy
ReleaseDC(hDlg,hDC)
End Sub
Sub CreateInvisibleBitmap
Local x,y,w,h As Long
Desktop Get Size To w,h
Graphic Bitmap New w,h To hBMP
Graphic Attach hBMP, 0
Graphic Get DC To memDC
End Sub
Sub CaptureScreen
keybd_event(%VK_SnapShot, 0, 0, 0) 'screen image
Dialog DoEvents
Clipboard Get Bitmap To hBMP 'put screen image into Graphic Control
Graphic Copy hBMP, 0
End Sub
MACRO AddLine(value)
IF cntProcs>=maxProcs THEN
maxProcs = maxProcs + 1000
REDIM PRESERVE procs(maxProcs)
END IF
procs(cntProcs)=value
INCR cntProcs
END MACRO
Sub GetProcNames(value As String)
DIM maxProcs AS INTEGER
maxProcs=1000
DIM procs(maxProcs) As String
DIM cntProcs AS INTEGER
cntProcs = 0
DIM translate(255) AS STATIC BYTE
ARRAY ASSIGN translate() = _
0, 0, 0, 0, 0, 0, 0, 0, 0, 32, 0, 0, 0, 13, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 32, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57, 0, 0, 0, 61, 0, 0 _
, 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 95 _
, 0, 65, 66, 67, 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, 78, 79 _
, 80, 81, 82, 83, 84, 85, 86, 87, 88, 89, 90, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 _
, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
REGISTER i AS INTEGER, p AS INTEGER
DIM t AS INTEGER
i=MAX(LEN(value)-13, 0): ' Forget last 13 characters
DIM v AS BYTE PTR, d AS BYTE PTR
v = STRPTR(value)
DIM dest As String
dest = STRING$(i,32)
d = STRPTR(dest)
DIM lastSpace AS INTEGER
DIM c AS BYTE
p = 0
DO WHILE i
DO
' Skip leading spaces
WHILE i AND translate(@v)<=32
DECR i
INCR v
WEND
' Only consider possible lines
IF INSTR("CFIMOPST",CHR$(translate(@v)))>0 THEN EXIT DO
' So find next carriage return
WHILE i AND translate(@v)<>13
DECR i
INCR v
WEND
LOOP WHILE i
IF i=0 THEN EXIT DO
' translate possible line
lastSpace=0
DO
c=translate(@v)
IF c=0 THEN
' Skip over rubbish
WHILE i AND translate(@v)<>13
DECR i
INCR v
WEND
c = 13
END IF
IF lastSpace AND c=32 THEN
c=0
ELSE
lastSpace = (c = 32)
END IF
IF c THEN
@d = c
INCR d
END IF
DECR i
INCR v
LOOP WHILE i AND c<>13
LOOP
value=RTRIM$(dest)
p = PARSECOUNT(value, $CR)
DIM iLines(p-1) As String
PARSE value, iLines(), $CR
FOR i=0 TO p-1
IF LEFT$(iLines(i), 9) = "CALLBACK " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 6) = "CLASS " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 9) = "Function " AND INSTR(iLines(i), "=")=0 THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 10) = "INTERFACE " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 6) = "MACRO " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 7) = "METHOD " AND INSTR(iLines(i), "=")=0 THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 9) = "OVERRIDE " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 9) = "PROPERTY " AND INSTR(iLines(i), "=")=0 THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 4) = "SUB " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
IF LEFT$(iLines(i), 7) = "THREAD " THEN
AddLine(iLines(i))
ITERATE FOR
END IF
NEXT
REDIM PRESERVE procs(cntProcs)
End Sub
'gbs_01003
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm