Clipboard Spy

Category: WinSpy

Date: 03-28-2012

Return to Index


 
'Credit:  Borje Hagsten
 
'Compilable Example:
'==========================================================
' 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 LongAs String
Declare Function StrToHexDump(ByVal sBuf As StringAs 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, CbMsgCbWParamCbLParam
            End If
         End If
 
      Case %WM_DRAWCLIPBOARD  ' clipboard content has changed
         If hNextViewer Then ' forward msg to next clipboard viewer
            SendMessage hNextViewer, CbMsgCbWParamCbLParam
            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(CbHndlThen
                        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 LongAs 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 StringAs 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


created by gbSnippets
http://www.garybeene.com/sw/gbsnippets.htm