Date: 02-16-2022
Return to Index
created by gbSnippets
'Credit: Borje Hagsten
'Compilable Example: (Jose Includes)
'==========================================================
' Save as for example "PB ClipBoardSpy.bas" and compile
'----------------------------------------------------------
' Simple clipboard wiever, using standard list- and textbox
' Shows how to monitor and enumerate clipboard formats + grab
' and format data to look like hexedit in a standard textbox.
' Inspired by a tip from Gary Beene about a ClipSpy program.
' This one lists more available formats in some cases, and
' is much faster on showing large amounts of data.
' ClipSpy programs can actually be useful when looking for
' special format codes or reasons for paste failure, etc.
' Public Domain by Borje Hagsten. Free to use and abuse. :)
'==========================================================
' Declares
'------------------------------------------------
#Compiler PBWin 9, PBWin 10
#Compile EXE
'------------------------------------------------
%ID_CHECKBOX1 = 110
%ID_LABEL1 = 120
%ID_LISTBOX1 = 130
%ID_TEXTBOX1 = 140
'------------------------------------------------
%USEMACROS = 1
#Include "WIN32API.INC"
Declare Function ClipBoardGetFormatName(ByVal uformat As Long) As String
Declare Function StrToHexDump(ByVal sBuf As String) As String
Declare Sub ClipBoardGetFormats (ByVal hDlg As Dword)
'==========================================================
' Program entrance
'==========================================================
Function PBMain () As Long
Local hDlg As Dword
' use a fixed width font for best look in text and list
Dialog Font "Courier New", 9
Dialog New 0, "PB ClipBoardSpy v0.01",,, 365, 159, _
%WS_Caption Or %WS_MinimizeBox Or %WS_SysMenu, 0 To hDlg
Control Add ListBox, hDlg, %ID_LISTBOX1, , 4, 22, 148, 133, _
%LBS_Notify Or %WS_VScroll Or %WS_TabStop Or _
%LBS_UseTabStops Or %LBS_NoIntegralHeight, _
%WS_Ex_ClientEdge
Control Add TextBox, hDlg, %ID_TEXTBOX1, "", 156, 22, 204, 133, _
%WS_Child Or %WS_Visible Or %ES_MultiLine Or _
%WS_VScroll Or %WS_HScroll, %WS_Ex_ClientEdge
'Tip: %WS_HSCROLL style makes inserting large text blocks much faster
Control Add CheckBox, hDlg, %ID_CHECKBOX1, "Always on top", 158, 4, 70, 14
Control Add Button, hDlg, %IdCancel, "&Quit", 310, 4, 50, 14
Control Add Label, hDlg, %ID_LABEL1, "", 4, 3, 152, 18
'--------------------------------------------------------
' set ListBox tab stops
' negative values makes tabs stops right-aligned
' positive values makes them left aligned
ReDim tbs(2) As Long
tbs(0) = 0 : tbs(1) = 32 : tbs(2) = -140
Control Send hDlg, %ID_LISTBOX1, %LB_SETTABSTOPS, UBound(tbs)+1, VarPtr(tbs(0))
'--------------------------------------------------------
Dialog Show Modal hDlg Call DlgProc
End Function
'==========================================================
' Main dialog callback procedure
'==========================================================
CallBack Function DlgProc() As Long
Local ln As Long, hMem, uFormat As Dword, sBuf As String
Local TmpAsciiz As AsciiZ * %Max_Path
Static hNextViewer As Dword
Select Case CbMsg
Case %WM_InitDialog ' first call
' add ourselves to the chain of clipboard viewers
hNextViewer = SetClipboardViewer(CbHndl)
' fill ListBox with clipboard formats
ClipBoardGetFormats CbHndl
'------------------------------------------------------------------
' clipboard monitoring messages
'------------------------------------------------------------------
Case %WM_CHANGECBCHAIN ' clipboard viewer chain has changed
If CbWParam = hNextViewer Then
hNextViewer = CbLParam
Else
If hNextViewer <> 0 Then
SendMessage hNextViewer, CbMsg, CbWParam, CbLParam
End If
End If
Case %WM_DRAWCLIPBOARD ' clipboard content has changed
If hNextViewer Then ' forward msg to next clipboard viewer
SendMessage hNextViewer, CbMsg, CbWParam, CbLParam
Function = 1
End If
ClipBoardGetFormats CbHndl
Case %WM_Destroy
If hNextViewer Then
' must remove ourselves from the clipboard viewer chain
ChangeClipboardChain CbHndl, hNextViewer
End If
'------------------------------------------------------------------
Case %WM_Command
Select Case CbCtl
Case %ID_CHECKBOX1
If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
Control Get Check CbHndl, %ID_CHECKBOX1 To ln
If ln Then ' force the program to stay always on top
SetWindowPos CbHndl, %HWND_TOPMOST, _
0,0,0,0, %SWP_NOMOVE Or %SWP_NOSIZE
Else ' else no more topmost program state
SetWindowPos CbHndl, %HWND_NOTOPMOST, _
0,0,0,0, %SWP_NOMOVE Or %SWP_NOSIZE
End If
End If
Case %ID_LISTBOX1
If CbCtlMsg = %LBN_SelChange Then
Control Set Text CbHndl, %ID_TEXTBOX1, ""
Control Send CbHndl, %ID_LISTBOX1, %LB_GETCURSEL, 0, 0 To ln
Control Send CbHndl, %ID_LISTBOX1, %LB_GETITEMDATA, ln, 0 To uformat
If uformat Then
If OpenClipboard(CbHndl) Then
hMem = GetClipboardData(uformat) ' get clipboard object handle
If hMem Then
ln = GlobalSize(hMem) ' size of clipboard data
sBuf = Peek$(hMem, ln) ' grab clipboard contents
sBuf = StrToHexDump(sBuf) ' convert to Hexedit looks
Control Set Text CbHndl, %ID_TEXTBOX1, sBuf
End If
CloseClipboard
End If
End If
End If
Case %IdCancel
If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then 'end prog
Dialog End CbHndl
End If
End Select
End Select
End Function
'==========================================================
' Standard clipboard format names look-up function
'==========================================================
Function ClipBoardGetFormatName(ByVal uformat As Long) As String
Select Case As Long uformat
Case 1 : Function = "%CF_TEXT"
Case 2 : Function = "%CF_BITMAP"
Case 3 : Function = "%CF_METAFILEPICT"
Case 4 : Function = "%CF_SYLK"
Case 5 : Function = "%CF_DIF"
Case 6 : Function = "%CF_TIFF"
Case 7 : Function = "%CF_OEMTEXT"
Case 8 : Function = "%CF_DIB"
Case 9 : Function = "%CF_PALETTE"
Case 10 : Function = "%CF_PENDATA"
Case 11 : Function = "%CF_RIFF"
Case 12 : Function = "%CF_WAVE"
Case 13 : Function = "%CF_UNICODETEXT"
Case 14 : Function = "%CF_ENHMETAFILE"
Case 15 : Function = "%CF_HDROP"
Case 16 : Function = "%CF_LOCALE"
Case 17 : Function = "%CF_DIBV5"
Case 18 : Function = "%CF_MAX" ' varies by Windows version
Case &H0080 : Function = "%CF_OWNERDISPLAY"
Case &H0081 : Function = "%CF_DSPTEXT"
Case &H0082 : Function = "%CF_DSPBITMAP"
Case &H0083 : Function = "%CF_DSPMETAFILEPICT"
Case &H008E : Function = "%CF_DSPENHMETAFILE"
End Select
End Function
'==========================================================
' enumerate and add available clipboard formats to ListBox
'==========================================================
Sub ClipBoardGetFormats (ByVal hDlg As Dword)
Local ln As Long, hMem, uFormat As Dword, sTxt As String
Local TmpAsciiz As AsciiZ * %Max_Path
Control Set Text hDlg, %ID_TEXTBOX1, ""
ListBox Reset hDlg, %ID_LISTBOX1
If OpenClipboard(hDlg) Then
ln = CountClipboardFormats()
sTxt = "There are" + Str$(ln)+ " clipboard formats." + $CrLf + _
"Click in list to see their contents."
Control Set Text hDlg, %ID_LABEL1, sTxt
uFormat = EnumClipboardFormats(0)
ListBox Add hDlg, %ID_LISTBOX1, "Code" + $Tab + "Name" + $Tab + "Size"
While uFormat
sTxt = ClipBoardGetFormatName(uformat) ' local function (above)
hMem = GetClipboardData (uformat) ' handle of clipboard object
If hMem Then ln = GlobalSize(hMem) ' size of clipboard data
If Len(sTxt) = 0 Then
TmpAsciiz = ""
GetClipboardFormatName uformat, TmpAsciiz, SizeOf(TmpAsciiz)
sTxt = TmpAsciiz
End If
ListBox Add hDlg, %ID_LISTBOX1, _
"[" + Format$(uformat, "00") + "]" + $Tab + _
sTxt + $Tab + Str$(ln)
Control Send hDlg, %ID_LISTBOX1, %LB_GETCOUNT, 0, 0 To ln
Control Send hDlg, %ID_LISTBOX1, %LB_SETITEMDATA, ln-1, uformat
uFormat = EnumClipboardFormats(uFormat)
Wend
CloseClipboard
End If
End Sub
'==========================================================
' Build a typical HexEditor looking string, like:
' 00000000 50 6F 77 65 72 42 41 53 PowerBAS
' 00000008 49 43 20 50 65 65 72 20 IC Peer
'==========================================================
Function StrToHexDump(ByVal sBuf As String) As String
Local i, ln, lPos, lPos2, lPos3, lPos4 As Long
Local sAdr, sHex, sTxt As String
ln = Ceil(Len(sBuf) / 8) ' line count
' pre-allocate memory for best speed
sAdr = Space$(ln*8) ' for adress string block
sHex = Space$(ln*24) ' for Hex characters block
sTxt = Space$(ln*47) ' each row is 47 bytes long
lPos = 1
For i = 1 To ln ' build adress block
Mid$(sAdr, lPos) = Hex$(lPos-1, 8)
lPos = lPos + 8
Next
lPos = 1
For i = 1 To Len(sBuf) ' build Hex char block
Mid$(sHex, lPos) = Hex$(Asc(sBuf, i), 2)
lPos = lPos + 3
Next
' replace "non-visible" stuff with a dot in right pane.
Replace Any Chr$(0 To 31) With Repeat$(32, ".") In sBuf
lPos = 1 : lPos2 = 1 : lPos3 = 1 : lPos4 = 1
For i = 1 To ln ' put it all together
Mid$(sTxt, lPos) = Mid$(sAdr, lPos2, 8)
lPos = lPos + 11 : lPos2 = lPos2 + 8
Mid$(sTxt, lPos) = Mid$(sHex, lPos3, 24)
lPos = lPos + 26 : lPos3 = lPos3 + 24
Mid$(sTxt, lPos) = Mid$(sBuf, lPos4, 8)
lPos = lPos + 8 : lPos4 = lPos4 + 8
Mid$(sTxt, lPos) = $CrLf
lPos = lPos + 2
Next
Function = sTxt
End Function
'gbs_01140
'Date: 03-10-2012
http://www.garybeene.com/sw/gbsnippets.htm