Tested with PB x86 - Windows 7,8 & 10
- Aero or classic window
- Shadow with any width
- No shadow
- Zero-Order intact
- Clipboard and Saved image are identical
Feel free to adapt it
Code: Select all
#DWMWA_EXTENDED_FRAME_BOUNDS = 9
#LB_ITEMFROMPOINT = $1A9
#CAPTUREBLT = $40000000
UseJPEG2000ImageEncoder()
UseJPEGImageEncoder()
UsePNGImageEncoder()
Global Dim h(100),n,t
Procedure tbWindows(hwnd,lParam)
title.s = Space(#MAX_PATH)
If GetWindowLongPtr_(hwnd,#GWL_EXSTYLE) ! #WS_EX_TOOLWINDOW And GetWindowLongPtr_(hwnd,#GWL_STYLE) & #WS_VISIBLE
GetWindowText_(hwnd,title,#MAX_PATH)
If title <> ""
h(n) = hwnd
n +1
AddGadgetItem(0,-1,title)
EndIf
EndIf
ProcedureReturn #True
EndProcedure
Procedure WindowProc(hWnd,uMsg,wParam,lParam)
Result = #PB_ProcessPureBasicEvents
Select uMsg
Case #WM_NCACTIVATE
Result = 1
EndSelect
ProcedureReturn Result
EndProcedure
LoadFont(0,"Consolas",8)
SetGadgetFont(#PB_Default,FontID(0))
initshadow = 8
initdelay = 100
OpenWindow(0, 0, 0, 400,155, "Snapshot", #PB_Window_SystemMenu| #PB_Window_ScreenCentered)
StickyWindow(0,1)
ListViewGadget(0,10,10,380,100)
ButtonGadget(1,10,120,60,24,"Re/Start")
ButtonGadget(2,75,120,60,24,"Save As")
TextGadget(3,140,120,40,24,"Delay:",#SS_CENTER|#SS_CENTERIMAGE)
SpinGadget(4,180,120,55,22,0,5000,#PB_Spin_Numeric)
SetGadgetState(4,initdelay)
TextGadget(5,240,120,45,24,"Shadow:",#SS_CENTER|#SS_CENTERIMAGE)
CheckBoxGadget(6,285,120,16,24,"" )
SetGadgetState(6,1)
TextGadget(7,305,120,35,24,"Width:",#SS_CENTER|#SS_CENTERIMAGE)
StringGadget(8,345,122,18,18,"8",#PB_String_Numeric|#ES_CENTER)
OpenWindow(1,0,0,0,0,"",#PB_Window_BorderLess)
SetWindowColor(1,$FEFEFE)
SetWindowLongPtr_(WindowID(1), #GWL_EXSTYLE, #WS_EX_LAYERED)
SetLayeredWindowAttributes_(WindowID(1), 0, 250, #LWA_ALPHA)
SetActiveWindow(0)
SetWindowCallback(@WindowProc())
Repeat
Select WaitWindowEvent()
Case #PB_Event_CloseWindow
SendMessage_(#HWND_BROADCAST, #WM_SYSCOMMAND, #SC_HOTKEY,GetWindow_(WindowID(0),#GW_HWNDPREV))
Quit = 1
Case #WM_MOUSEMOVE
GetCursorPos_(p.POINT)
ScreenToClient_ (GadgetID(0), @p)
index = SendMessage_(GadgetID(0),#LB_ITEMFROMPOINT,0,p\y<<16+p\x)
SetGadgetState(0,index)
Case #PB_Event_Gadget
Select EventGadget()
Case 0
Select EventType()
Case #PB_EventType_LeftClick
hwnd = h(GetGadgetState(0))
If IsIconic_(hwnd) = 1
ShowWindow_(hwnd,#SW_SHOWNORMAL)
iconflag = 1
EndIf
ahwnd = GetWindow_(hwnd,#GW_HWNDNEXT)
If OSVersion() >= #PB_OS_Windows_Vista
lib = OpenLibrary(#PB_Any, "UxTheme.dll")
If lib
*IsThemeActive = GetFunction(lib, "IsThemeActive")
If *IsThemeActive
Themed = CallFunctionFast(*IsThemeActive)
EndIf
CloseLibrary(lib)
EndIf
If Themed = 1
Lib = OpenLibrary(#PB_Any, "dwmapi.dll")
If Lib
*DwmIsCompositionEnabled = GetFunction(Lib, "DwmIsCompositionEnabled")
If *DwmIsCompositionEnabled
CallFunctionFast(*DwmIsCompositionEnabled, @flag)
EndIf
If flag = 1
*DwmGetWindowAttribute = GetFunction(Lib, "DwmGetWindowAttribute")
If *DwmGetWindowAttribute
CallFunctionFast(*DwmGetWindowAttribute, hWnd, #DWMWA_EXTENDED_FRAME_BOUNDS, wr.RECT, SizeOf(wr))
EndIf
shadow = initshadow
Else
shadow = 0
GetWindowRect_(hWnd, wr.RECT)
EndIf
EndIf
CloseLibrary(Lib)
Else
shadow = 0
GetWindowRect_(hWnd, wr.RECT)
EndIf
Else
shadow = 0
GetWindowRect_(hWnd, wr.RECT)
EndIf
If Themed = 1
hBitmap = CreateImage(0,wr\right-wr\left+2*shadow,wr\bottom-wr\top+2*shadow,32,#PB_Image_Transparent )
Else
hBitmap = CreateImage(0,wr\right-wr\left+2*shadow,wr\bottom-wr\top+2*shadow)
EndIf
MoveWindow_(WindowID(1),wr\left-shadow,wr\top-shadow,wr\right-wr\left+2*shadow,wr\bottom-wr\top+2*shadow,1)
SetWindowPos_(WindowID(1),#HWND_TOPMOST,0,0,0,0,#SWP_NOMOVE|#SWP_NOSIZE)
SetWindowPos_(hwnd,#HWND_TOPMOST,0,0,0,0,#SWP_NOMOVE|#SWP_NOSIZE)
SendMessage_(#HWND_BROADCAST, #WM_SYSCOMMAND, #SC_HOTKEY, hWnd)
Delay(GetGadgetState(4))
hdc = StartDrawing(ImageOutput(0))
SelectObject_(hdc, hBitmap)
BitBlt_(hdc,0,0,wr\right-wr\left+2*shadow,wr\bottom-wr\top+2*shadow, GetDC_(0),wr\left-shadow,wr\top-shadow,#SRCCOPY |#CAPTUREBLT)
StopDrawing()
ClearClipboard()
SetClipboardImage(0)
MoveWindow_(WindowID(1),0,0,1,1,1)
SetWindowPos_(hwnd,ahwnd,0,0,0,0,#SWP_NOSIZE|#SWP_NOMOVE|#SWP_NOACTIVATE )
If iconflag = 1
ShowWindow_(hwnd,#SW_MINIMIZE )
iconflag = 0
EndIf
EndSelect
Case 1
ClearGadgetItems(0)
n = 0
FreeArray(h())
Dim h(100)
EnumChildWindows_(FindWindow_("MSTaskSwWClass",0),@tbWindows(),0)
Case 2
GetClipboardImage(0,32)
sFile$ = SaveFileRequester("Please choose file to save",""," All supported formats|*.bmp;*.jpg; *.jpeg; *.jp2; *.png | PNG image (*.png)| *.png| BMP image (*.bmp)| *.bmp| JPEG image (*.jpg;*.jpeg)",0)
If sFile$
Select LCase(GetExtensionPart(sFile$))
Case "bmp"
SaveImage(0,sFile$,#PB_ImagePlugin_BMP)
Case "png"
SaveImage(0,sFile$,#PB_ImagePlugin_PNG)
Case "jpg"
SaveImage(0,sFile$,#PB_ImagePlugin_JPEG)
Case "jpeg","jp2"
SaveImage(0,sFile$,#PB_ImagePlugin_JPEG2000)
EndSelect
EndIf
Case 6
If GetGadgetState(6) = 1
initshadow = Val(GetGadgetText(8))
Else
initshadow = 0
EndIf
Case 8
initshadow = Val(GetGadgetText(8))
EndSelect
EndSelect
Until Quit = 1
Edit2 :Fixed right click bug
Edit3 :Fixed some bugs and now works with Windows XP as well
Edit4 :Windows 7 Basic theme supported
( i forgot i had that Computer was set to : Windows 7 Basic ... i have 3 available Themes= Aero , Classic , and Basic )
