Double buffering in Winapi
-
- Posts: 11
- Joined: Feb 09, 2022 0:03
Double buffering in Winapi
Hello, I've been trying to do double buffering with winapi in freebasic but I can't.
Can someone help me?
Can someone help me?
Re: Double buffering in Winapi
Simple example using text and rectangle.
Code: Select all
#include "windows.bi"
const xres=800
const yres=600
const backgroundColour=bgr(55,255,255)
Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style))
End Sub
Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
SetTextColor(h,text)
SetBkColor(h,background)
End Sub
Sub text(h As hdc,x As Long,y As Long,s As String)
Var l=Len(s)
textouta(h,x,y,s,L)
End Sub
Sub ClearScreen(h As hdc)
Var colour=BackgroundColour
SetDCBrushColor(h,colour)
SetDCPenColor(h,colour)
rectangle(h,0,0,xres,yres)
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Dim As hdc Memhdc,WorkingScreen,hdc
Dim As HBITMAP Membitmap
Dim As msg emsg
Dim As Long fps
Dim As hwnd p=CreateWindowEx( WS_EX_TOPMOST Or WS_EX_TOOLWINDOW ,"#32770","Press ESCAPE key to finish . . .",(WS_OVERLAPPEDWINDOW Or WS_SYSMENU) - (WS_MINIMIZEBOX Or WS_MAXIMIZEBOX Or WS_THICKFRAME) Or WS_VISIBLE,200,200,xres,yres,0,0,0,null)
WorkingScreen=GetDC(p)
Memhdc = CreateCompatibleDC(WorkingScreen)
Membitmap = CreateCompatibleBitmap(WorkingScreen, xres, yres)
SelectObject(Memhdc, Membitmap)
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))
setfontsize(Memhdc,20,"courier new")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)
While true
While(PeekMessage(@eMsg,0, 0, 0, PM_REMOVE)) > 0
TranslateMessage (@eMsg)
DispatchMessage (@eMsg)
If GetAsyncKeyState(&h1B) Then ' escape key
DeleteObject(Membitmap)
DeleteDC (Memhdc)
End
End If
Wend
'graphics loop
clearscreen(Memhdc)
text(Memhdc,10,10,"Hello")
text(Memhdc,10,30,"Draw all graphics (and SelectObject e.t.c.) into Memhdc")
text(Memhdc,10,50,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
text(Memhdc,10,70,"Note I use PeekMessage only to get graphics in a loop" )
text(Memhdc,10,90,"My main window is a non resizable toolwindow (optional)")
text(Memhdc,10,110,"framerate = "&fps)
BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
Sleep regulate(60,fps)
Wend
-
- Posts: 11
- Joined: Feb 09, 2022 0:03
Re: Double buffering in Winapi
Thank you
Re: Double buffering in Winapi
Here two more examples:
GDI:
GDIPlus:
You can search for GDI or GDI+ to find more examples, if it weren't for the limit of at least 4 letters...
GDI:
Code: Select all
'coded by UEZ
#Include "fbgfx.bi"
#Include "windows.bi"
Using FB
Const As UInteger iW = 1000, iH = 800, iWh = iW \ 2, iHh = iH \ 2
Const As Single fPi = ACos(-1), fRad = fPi / 180
ScreenControl FB.SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 24, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Dim As String sTitle = "GDI Double Buffering"
WindowTitle sTitle
Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))
Dim As Ulong Ptr aBitmap
Dim As BITMAPINFO tBITMAP
With tBITMAP.bmiheader
.biSize = Sizeof(BITMAPINFOHEADER)
.biWidth = iW
.biHeight = -iH
.biPlanes = 1
.biBitCount = 32
.biCompression = BI_RGB
End With
Dim As Any Ptr hDC = GetDC(hHWND), _
hDC_backbuffer = CreateCompatibleDC(hDC), _
hHBitmap = CreateDIBSection(hDC_backbuffer, @tBITMAP, DIB_RGB_COLORS, @aBitmap, NULL, NULL), _
hCanvas, hPen
Var hObjOld = SelectObject(hDC_backbuffer, hHBitmap)
'SetGraphicsMode(hDC, 2)
'SetStretchBltMode(hDC_backbuffer, 4) 'high quality mode
hPen = SelectObject(hDC_backbuffer, GetStockObject(DC_Pen))
Dim As Single r = 200, t = 0
Dim evt As EVENT
Do
BitBlt(hDC_backbuffer, 0, 0, iW, iH, hDC_backbuffer, 0, 0, WHITENESS)
MoveToEx(hDC_backbuffer, iWh + r * Cos(t), iHh + r * Sin(t), NULL)
LineTo(hDC_backbuffer, iWh + r * Cos(t + fRad * 90), iHh + r * Sin(t + fRad * 90))
t += 0.01666666
BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
Sleep(10)
Loop Until ((InKey = Chr(27)) Or (evt.Type = EVENT_WINDOW_CLOSE))
SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
SelectObject(hDC_backbuffer, hPen)
DeleteObject(hPen)
Code: Select all
'coded by UEZ
#Include "fbgfx.bi"
#Ifdef __Fb_64bit__
#Inclib "gdiplus"
#Include Once "win/gdiplus-c.bi"
#Else
#Include Once "win/gdiplus.bi"
Using gdiplus
#Endif
Using FB
Const As UShort iW = 1000, iH = 800, iWh = iW \ 2, iHh = iH \ 2
Const As Single fPi = ACos(-1), fRad = fPi / 180
Dim Shared gdipToken As ULONG_PTR
Dim GDIp As GdiplusStartupInput
GDIp.GdiplusVersion = 1
GdiplusStartup(@gdipToken, @GDIp, NULL)
ScreenControl SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 32, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Dim As String sTitle = "GDI+ Double Buffering"
WindowTitle sTitle
Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))
Dim As Any Ptr hDC = GetDC(hHWND), _
hHBitmap = CreateCompatibleBitmap(hDC, iW, iH), _
hDC_backbuffer = CreateCompatibleDC(hDC), _
hCanvas, hPen
Var hObjOld = SelectObject(hDC_backbuffer, hHBitmap)
GdipCreateFromHDC(hDC_backbuffer, @hCanvas)
GdipSetSmoothingMode(hCanvas, 5)
GdipSetPixelOffsetMode(hCanvas, 2)
GdipCreatePen1(&hFF000000, 1, 2, @hPen)
GdipSetPenLineJoin(hPen, 2)
Dim As Single r = 200, t = 0
Dim evt As EVENT
Do
BitBlt(hDC_backbuffer, 0, 0, iW, iH, hDC_backbuffer, 0, 0, WHITENESS)
GdipDrawLine(hCanvas, hPen, iWh + r * Cos(t), iHh + r * Sin(t), iWh + r * Cos(t + fRad * 90), iHh + r * Sin(t + fRad * 90))
t += 0.01666666
BitBlt(hDC, 0, 0, iW, iH, hDC_backbuffer, 0, 0, SRCCOPY)
Sleep(10, 1)
Loop Until ((InKey = Chr(27)) Or (evt.Type = EVENT_WINDOW_CLOSE))
SelectObject(hDC_backbuffer, hObjOld)
DeleteDC(hDC_backbuffer)
ReleaseDC(hHWND, hDC)
DeleteObject(hHBitmap)
GdipDeleteGraphics(hCanvas)
GdipDeletePen(hPen)
GdiplusShutdown(gdipToken)
Re: Double buffering in Winapi
Afaik newer commctrls allow to set a double buffer attribute. I quickly looked and it is called WS_EX_COMPOSITED, maybe searching on that helps.
Re: Double buffering in Winapi
That is not real double buffering without using callback WM_PAINT
when you drag window and pull it over screen edge then window become dark
in first dodicat example become white.
when you drag window and pull it over screen edge then window become dark
in first dodicat example become white.
Re: Double buffering in Winapi
It depends on what you mean with db! Without db the gfx animation will flicker. WM_PAINT is only for repainting, not db, imho.
Afaik, WS_EX_COMPOSITED is not working for GDI / GDI+.
Re: Double buffering in Winapi
Give us an example aurelVZAB.
The main purpose of double buffering is to avoid flicker (in any window), even the console:
The main purpose of double buffering is to avoid flicker (in any window), even the console:
Code: Select all
#include "windows.bi"
Const xres=800
Const yres=600
Const backgroundColour=bgr(55,255,255)
Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style))
End Sub
Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
SetTextColor(h,text)
SetBkColor(h,background)
End Sub
Sub text(h As hdc,x As Long,y As Long,s As String)
Var l=Len(s)
textouta(h,x,y,s,L)
End Sub
Sub ClearScreen(h As hdc)
Var colour=BackgroundColour
SetDCBrushColor(h,colour)
SetDCPenColor(h,colour)
rectangle(h,0,0,xres,yres)
End Sub
sub hidecursor()
dim as handle consoleHandle
dim as CONSOLE_CURSOR_INFO info
consolehandle = GetStdHandle(STD_OUTPUT_HANDLE)
info.dwSize = 100
info.bVisible = FALSE
SetConsoleCursorInfo(consoleHandle, @info)
End sub
Sub drawline(x As Long,y As Long,angle As Single,lngth As Double,Byref x2 As Long=0,Byref y2 As Long=0)
angle=angle*Atn(1)/45
x2=x+lngth*Cos(angle)
y2=y-lngth*Sin(angle)
End Sub
Sub pendulum(h As hdc)
SetDCBrushColor(h,bgr(0,150,255))
SetDCPenColor(h,bgr(200,0,50))
Dim As Long x,y
Const pi=4*Atn(1),r=40
Static As Single ang
ang+=.02
drawline(400,20,15*Sin(ang)-90,500,x,y)
MoveToEx(h, 400, 20, NULL)
LineTo(h, x,y)
ellipse(h,(x-r),(y-r),(x+r),(y+r))
Circle(x,y),50
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Dim As hdc Memhdc,WorkingScreen,hdc
Dim As HBITMAP Membitmap
Dim As msg emsg
Dim As Long fps
Dim As hwnd p=getconsolewindow()
setwindowpos(p, HWND_TOPMOST, 100, 100, 810, 630,SWP_SHOWWINDOW)
WorkingScreen=GetDC(p)
Memhdc = CreateCompatibleDC(WorkingScreen)
Membitmap = CreateCompatibleBitmap(WorkingScreen, xres, yres)
SelectObject(Memhdc, Membitmap)
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))
setfontsize(Memhdc,25,"comic sans ms")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)
'some console instructions
var sysMenu = GetSystemMenu(p, False)
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND) 'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND)'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND) 'non resizable console
hidecursor()
ShowScrollBar(p, SB_BOTH, FALSE)
While true
'graphics loop
clearscreen(Memhdc)
text(Memhdc,10,10,"Hello")
text(Memhdc,10,35,"Draw all graphics (and SelectObject e.t.c.) into Memhdc")
text(Memhdc,10,60,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
text(Memhdc,10,110,"framerate = "&fps)
text(Memhdc,10,500,"Press <escape> to finish")
pendulum(Memhdc)
BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
Sleep regulate(60,fps)
If GetAsyncKeyState(&h1B) Then ' escape key
DeleteObject(Membitmap)
DeleteDC (Memhdc)
End
End If
Wend
Re: Double buffering in Winapi
Is everybody welcome to this party?
There's also Begin/EndBufferedPaint which you can just put around your existing code without having to rearchitect it. Also lets you do alpha blending, how fancy.
There's also Begin/EndBufferedPaint which you can just put around your existing code without having to rearchitect it. Also lets you do alpha blending, how fancy.
Re: Double buffering in Winapi
Here is my attempt to implement it:adeyblue wrote: ↑Feb 11, 2022 5:24 Is everybody welcome to this party?
There's also Begin/EndBufferedPaint which you can just put around your existing code without having to rearchitect it. Also lets you do alpha blending, how fancy.
Code: Select all
'coded by UEZ
#Include "fbgfx.bi"
#Include "windows.bi"
'#Include "win/uxtheme.bi"
Using FB
Type HPAINTBUFFER As HPAINTBUFFER__ Ptr
Type _BP_PAINTPARAMS
cbSize As DWORD
dwFlags As DWORD
prcExclude As Const RECT Ptr
pBlendFunction As Const BLENDFUNCTION Ptr
End Type
Type _BP_BUFFERFORMAT As Long
Type BP_BUFFERFORMAT As _BP_BUFFERFORMAT
Type BP_PAINTPARAMS As _BP_PAINTPARAMS
Enum
BPBF_COMPATIBLEBITMAP
BPBF_DIB
BPBF_TOPDOWNDIB
BPBF_TOPDOWNMONODIB
End Enum
Dim As Any Ptr hLibUx = Dylibload("UxTheme.dll")
Dim BufferedPaintInit As Function () As HRESULT
Dim BufferedPaintUnInit As Function () As HRESULT
Dim BeginBufferedPaint As Function (Byval hdcTarget As HDC, Byval prcTarget As Const RECT Ptr, Byval dwFormat As BP_BUFFERFORMAT, Byval pPaintParams As BP_PAINTPARAMS Ptr, Byval phdc As HDC Ptr) As HPAINTBUFFER
Dim EndBufferedPaint As Function (Byval hBufferedPaint as HPAINTBUFFER, Byval fUpdateTarget as WINBOOL) as HRESULT
BufferedPaintInit = Dylibsymbol(hLibUx, "BufferedPaintInit")
BufferedPaintUnInit = Dylibsymbol(hLibUx, "BufferedPaintUnInit")
BeginBufferedPaint = Dylibsymbol(hLibUx, "BeginBufferedPaint")
EndBufferedPaint = Dylibsymbol(hLibUx, "EndBufferedPaint")
Const As UInteger iW = 1000, iH = 800, iWh = iW \ 2, iHh = iH \ 2
Const As Single fPi = ACos(-1), fRad = fPi / 180
ScreenControl FB.SET_DRIVER_NAME, "GDI"
ScreenRes iW, iH, 24, 1, GFX_HIGH_PRIORITY Or GFX_NO_SWITCH
Dim As String sTitle = "GDI Double Buffering"
WindowTitle sTitle
Dim as HWND hHWND
ScreenControl(FB.GET_WINDOW_HANDLE, Cast(Integer, hHWND))
Dim As Any Ptr hDC = GetDC(hHWND), hCanvas, hPen, hNewDC
hPen = SelectObject(hDC, GetStockObject(DC_Pen))
Dim As RECT tRECT = Type(0, 0, iW, iH)
Dim As BLENDFUNCTION tBLENDFUNCTION
tBLENDFUNCTION.BlendOp = AC_SRC_OVER
tBLENDFUNCTION.BlendFlags = 0
tBLENDFUNCTION.SourceConstantAlpha = 100
tBLENDFUNCTION.AlphaFormat = AC_SRC_ALPHA
Dim As BP_PAINTPARAMS pPaintParams
pPaintParams.cbSize = Sizeof(_BP_PAINTPARAMS)
pPaintParams.dwFlags = 0
pPaintParams.prcExclude = Null
pPaintParams.pBlendFunction = @tBLENDFUNCTION
BufferedPaintInit()
Dim As HPAINTBUFFER hBP = BeginBufferedPaint(hDC, @tRECT, BPBF_COMPATIBLEBITMAP, @pPaintParams, @hNewDC)
Dim As Double r = 200, t = 0
Do
BitBlt(hNewDC, 0, 0, iW, iH, hDC, 0, 0, WHITENESS)
MoveToEx(hNewDC, iWh + r * Cos(t), iHh + r * Sin(t), NULL)
LineTo(hNewDC, iWh + r * Cos(t + fRad * 90), iHh + r * Sin(t + fRad * 90))
BitBlt(hDC, 0, 0, iW, iH, hNewDC, 0, 0, MERGECOPY)
t += 0.01666666
Sleep(10)
Loop Until InKey = Chr(27)
EndBufferedPaint(hBP, 1)
BufferedPaintUnInit()
ReleaseDC(hHWND, hDC)
SelectObject(hDC, hPen)
DeleteObject(hPen)
Dylibfree(hLibUx)
Re: Double buffering in Winapi
I also had a go at "Is everybody welcome to this party?" by adeyblue.
I had to leave a border around, I had difficulty filling the background (all of it) with rectangle.
But I'll have a closer look later, I am sure it is something simple.
Alas, I had to make the pendulum shorter in this method so it fitted the screen (a symptom of the above rectangle)
There is a slight difference between 32 and 64 bits.
Way back in the mists of time dkl did say that some work was needed to be done with the winapi.bi files to accommodate 64 and 32 bit, so "win/uxtheme.bi" is one of them I reckon.
Probably all this #if _WIN32_WINNT >= bla bla needs looked at.
Anyway:
I had to leave a border around, I had difficulty filling the background (all of it) with rectangle.
But I'll have a closer look later, I am sure it is something simple.
Alas, I had to make the pendulum shorter in this method so it fitted the screen (a symptom of the above rectangle)
There is a slight difference between 32 and 64 bits.
Way back in the mists of time dkl did say that some work was needed to be done with the winapi.bi files to accommodate 64 and 32 bit, so "win/uxtheme.bi" is one of them I reckon.
Probably all this #if _WIN32_WINNT >= bla bla needs looked at.
Anyway:
Code: Select all
#define winincludeall
#include "windows.bi"
'#Include "win/uxtheme.bi"
Enum
BPBF_COMPATIBLEBITMAP
BPBF_DIB
BPBF_TOPDOWNDIB
BPBF_TOPDOWNMONODIB
End Enum
Type HPAINTBUFFER As HPAINTBUFFER__ Ptr
Type BP_PAINTPARAMS
cbSize As DWORD
dwFlags As DWORD
prcExclude As Const RECT Ptr
pBlendFunction As Const BLENDFUNCTION Ptr
End Type
Declare Function SetWindowTheme Lib "UxTheme.dll" Alias "SetWindowTheme"(As Any Ptr,As zstring Ptr,As zstring Ptr) As Long
Declare Function BufferedPaintInit Lib "UxTheme.dll" Alias "BufferedPaintInit" As HRESULT
Declare Function BufferedPaintUnInit Lib "UxTheme.dll" Alias "BufferedPaintUnInit" As HRESULT
Declare Function BeginBufferedPaint Lib "UxTheme.dll" Alias "BeginBufferedPaint" (Byval hdcTarget As HDC, Byval prcTarget As Const RECT Ptr, Byval dwFormat As Long, Byval pPaintParams As BP_PAINTPARAMS Ptr, Byval phdc As HDC Ptr) As HPAINTBUFFER
Declare Function EndBufferedPaint Lib "UxTheme.dll" Alias "EndBufferedPaint" (Byval hBufferedPaint As HPAINTBUFFER, Byval fUpdateTarget As WINBOOL) As HRESULT
Const xres=800
Const yres=600
Const backgroundColour=bgr(55,255,255)
Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style))
End Sub
Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
SetTextColor(h,text)
SetBkColor(h,background)
End Sub
Sub text(h As hdc,x As Long,y As Long,s As String)
Var l=Len(s)
textouta(h,x,y,s,L)
End Sub
Sub ClearScreen(h As hdc)
Var colour=BackgroundColour
SetDCBrushColor(h,colour)
SetDCPenColor(h,colour)
rectangle(h,15,15,xres,yres)
End Sub
Sub hidecursor()
Dim As handle consoleHandle
Dim As CONSOLE_CURSOR_INFO info
consolehandle = GetStdHandle(STD_OUTPUT_HANDLE)
info.dwSize = 100
info.bVisible = FALSE
SetConsoleCursorInfo(consoleHandle, @info)
End Sub
Sub drawline(x As Long,y As Long,angle As Single,lngth As Double,Byref x2 As Long=0,Byref y2 As Long=0)
angle=angle*Atn(1)/45
x2=x+lngth*Cos(angle)
y2=y-lngth*Sin(angle)
End Sub
Sub pendulum(h As hdc)
SetDCBrushColor(h,bgr(0,150,255))
SetDCPenColor(h,bgr(200,0,50))
Dim As Long x,y
Const pi=4*Atn(1),r=40
Static As Single ang
ang+=.02
drawline(400,20,15*Sin(ang)-90,450,x,y)
MoveToEx(h, 400, 20, NULL)
LineTo(h, x,y)
ellipse(h,(x-r),(y-r),(x+r),(y+r))
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Dim As hdc Memhdc,WorkingScreen
Dim As msg emsg
Dim As Long fps
Dim As hwnd p=getconsolewindow()
setwindowpos(p, HWND_TOPMOST, 100, 100, xres, yres,SWP_SHOWWINDOW)
WorkingScreen=GetDC(p)
SetWindowTheme(p,"","")
'==================================================
Dim As RECT tRECT = Type(0, 0,xres, yres)
Dim As BLENDFUNCTION tBLENDFUNCTION
BufferedPaintInit()
Dim As BP_PAINTPARAMS pPaintParams
pPaintParams.cbSize = Sizeof(BP_PAINTPARAMS)
pPaintParams.dwFlags = 0
pPaintParams.prcExclude = Null
pPaintParams.pBlendFunction = @tBLENDFUNCTION
Dim As HPAINTBUFFER hBP = BeginBufferedPaint(WorkingScreen, @tRECT, BPBF_COMPATIBLEBITMAP, @pPaintParams, @Memhdc)
If hBP=null Then Print "unable to do this":Sleep:End
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))
setfontsize(Memhdc,25,"comic sans ms")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)
'some console instructions
Var sysMenu = GetSystemMenu(p, False)
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND) 'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND)'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND) 'non resizable console
hidecursor()
ShowScrollBar(p, SB_BOTH, FALSE)
While true
'graphics loop
clearscreen(Memhdc)
text(Memhdc,20,10+10,"Hello")
text(Memhdc,20,35+10,"Draw all graphics (and SelectObject e.t.c.) into Memhdc via BeginBufferedPaint")
text(Memhdc,20,60+10,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
text(Memhdc,20,110+10,"framerate = "&fps)
text(Memhdc,20,500,"Press <escape> to finish")
pendulum(Memhdc)
BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
Sleep regulate(60,fps)
If GetAsyncKeyState(&h1B) Then ' escape key
EndBufferedPaint(hBP, 1)
BufferedPaintUnInit()
DeleteDC (Memhdc)
DeleteDC (WorkingScreen)
End
End If
Wend
Re: Double buffering in Winapi
Just a minor detail; isn't it simpler to use do..loop rather than while true..wend?
Re: Double buffering in Winapi
@dodicat: you can use
instead of
if you want to clear the buffered dc flat (black). I know that you have used a separate function to add bg colors.
This seems to work without the black border at the right or scrollbar:
I don't see a real advantage using Buffered* functions compared to the classic way. Only useful when mixing bitmaps with alpha blending.
Code: Select all
Declare Function BufferedPaintClear Lib "UxTheme.dll" Alias "BufferedPaintClear" (Byval hBufferedPaint As HPAINTBUFFER, Byval prcTarget As Const RECT Ptr) As HRESULT
BufferedPaintClear(hBP, Null)
Code: Select all
clearscreen(Memhdc)
This seems to work without the black border at the right or scrollbar:
Code: Select all
'#define winincludeall
#include "windows.bi"
'#Include "win/uxtheme.bi"
Enum
BPBF_COMPATIBLEBITMAP
BPBF_DIB
BPBF_TOPDOWNDIB
BPBF_TOPDOWNMONODIB
End Enum
Type HPAINTBUFFER As HPAINTBUFFER__ Ptr
Type BP_PAINTPARAMS
cbSize As DWORD
dwFlags As DWORD
prcExclude As Const RECT Ptr
pBlendFunction As Const BLENDFUNCTION Ptr
End Type
Declare Function SetWindowTheme Lib "UxTheme.dll" Alias "SetWindowTheme"(As Any Ptr,As zstring Ptr,As zstring Ptr) As Long
Declare Function BufferedPaintInit Lib "UxTheme.dll" Alias "BufferedPaintInit" As HRESULT
Declare Function BufferedPaintUnInit Lib "UxTheme.dll" Alias "BufferedPaintUnInit" As HRESULT
Declare Function BeginBufferedPaint Lib "UxTheme.dll" Alias "BeginBufferedPaint" (Byval hdcTarget As HDC, Byval prcTarget As Const RECT Ptr, Byval dwFormat As Long, Byval pPaintParams As BP_PAINTPARAMS Ptr, Byval phdc As HDC Ptr) As HPAINTBUFFER
Declare Function EndBufferedPaint Lib "UxTheme.dll" Alias "EndBufferedPaint" (Byval hBufferedPaint As HPAINTBUFFER, Byval fUpdateTarget As WINBOOL) As HRESULT
Declare Function BufferedPaintClear Lib "UxTheme.dll" Alias "BufferedPaintClear" (Byval hBufferedPaint As HPAINTBUFFER, Byval prcTarget As Const RECT Ptr) As HRESULT
Const xres=800
Const yres=600
Const backgroundColour=bgr(55,255,255)
Sub setfontsize(h As hdc,size As Long,style As zstring Ptr)
SelectObject(h,CreateFont(size,0,0,0,400,0,0,0,DEFAULT_CHARSET,OUT_OUTLINE_PRECIS,CLIP_DEFAULT_PRECIS,ANTIALIASED_QUALITY,VARIABLE_PITCH,style))
End Sub
Sub setfontcolours(h As hdc,text As Ulong,background As Ulong)
SetTextColor(h,text)
SetBkColor(h,background)
End Sub
Sub text(h As hdc,x As Long,y As Long,s As String)
Var l=Len(s)
textouta(h,x,y,s,L)
End Sub
Sub ClearScreen(h As hdc)
Var colour=BackgroundColour
SetDCBrushColor(h,colour)
SetDCPenColor(h,colour)
rectangle(h,0,0,xres,yres)
End Sub
Sub hidecursor()
Dim As handle consoleHandle
Dim As CONSOLE_CURSOR_INFO info
consolehandle = GetStdHandle(STD_OUTPUT_HANDLE)
info.dwSize = 100
info.bVisible = FALSE
SetConsoleCursorInfo(consoleHandle, @info)
End Sub
Sub drawline(x As Long,y As Long,angle As Single,lngth As Double,Byref x2 As Long=0,Byref y2 As Long=0)
angle=angle*Atn(1)/45
x2=x+lngth*Cos(angle)
y2=y-lngth*Sin(angle)
End Sub
Sub pendulum(h As hdc)
SetDCBrushColor(h,bgr(0,150,255))
SetDCPenColor(h,bgr(200,0,50))
Dim As Long x,y
Const pi=4*Atn(1),r=40
Static As Single ang
ang+=.02
drawline(400,20,15*Sin(ang)-90,450,x,y)
MoveToEx(h, 400, 20, NULL)
LineTo(h, x,y)
ellipse(h,(x-r),(y-r),(x+r),(y+r))
End Sub
Function Regulate(Byval MyFps As Long,Byref fps As Long) As Long 'optional
Static As Double timervalue,_lastsleeptime,t3,frames
frames+=1
If (Timer-t3)>=1 Then t3=Timer:fps=frames:frames=0
Var sleeptime=_lastsleeptime+((1/myfps)-Timer+timervalue)*1000
If sleeptime<1 Then sleeptime=1
_lastsleeptime=sleeptime
timervalue=Timer
Return sleeptime
End Function
Dim As hdc Memhdc,WorkingScreen
Dim As msg emsg
Dim As Long fps
Dim As hwnd p=getconsolewindow()
setwindowpos(p, HWND_TOPMOST, 100, 100, xres, yres,SWP_SHOWWINDOW)
WorkingScreen=GetDC(p)
SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), Type <COORD>(95, 35))
SetWindowTheme(p,"","")
'==================================================
Dim As RECT tRECT = Type(0, 0,xres, yres)
Dim As BLENDFUNCTION tBLENDFUNCTION
BufferedPaintInit()
Dim As BP_PAINTPARAMS pPaintParams
pPaintParams.cbSize = Sizeof(BP_PAINTPARAMS)
pPaintParams.dwFlags = 0
pPaintParams.prcExclude = Null
pPaintParams.pBlendFunction = @tBLENDFUNCTION
Dim As HPAINTBUFFER hBP = BeginBufferedPaint(WorkingScreen, @tRECT, BPBF_COMPATIBLEBITMAP, @pPaintParams, @Memhdc)
If hBP=null Then Print "unable to do this":Sleep:End
SelectObject(Memhdc,GetStockObject(DC_BRUSH))
SelectObject(Memhdc,GetStockObject(DC_PEN))
setfontsize(Memhdc,25,"comic sans ms")
setfontcolours(Memhdc,bgr(0,0,200),BackgroundColour)
'some console instructions
Var sysMenu = GetSystemMenu(p, False)
DeleteMenu(sysMenu, SC_CLOSE, MF_BYCOMMAND) 'cannot close console
DeleteMenu(sysMenu, SC_MINIMIZE, MF_BYCOMMAND) 'To prevent user from minimizing console window
DeleteMenu(sysMenu, SC_MAXIMIZE, MF_BYCOMMAND)'To prevent user from maximizing console window
DeleteMenu(sysMenu, SC_SIZE, MF_BYCOMMAND) 'non resizable console
hidecursor()
While true
'graphics loop
clearscreen(Memhdc)
'BufferedPaintClear(hBP, NULL)
text(Memhdc,20,10+10,"Hello")
text(Memhdc,20,35+10,"Draw all graphics (and SelectObject e.t.c.) into Memhdc via BeginBufferedPaint")
text(Memhdc,20,60+10,"BitBlt from Memhdc back to WorkingScreen in each graphics loop")
text(Memhdc,20,110+10,"framerate = "&fps)
text(Memhdc,20,500,"Press <escape> to finish")
pendulum(Memhdc)
BitBlt(WorkingScreen, 0, 0, xres, yres,Memhdc, 0, 0,SRCCOPY)
Sleep regulate(60,fps)
If GetAsyncKeyState(&h1B) Then ' escape key
EndBufferedPaint(hBP, 1)
BufferedPaintUnInit()
DeleteDC (Memhdc)
DeleteDC (WorkingScreen)
End
End If
Wend
Why is do/loop simpler than While/Wend? For me it's the same effort.
Re: Double buffering in Winapi
Thanks UEZ.
In fact I only have to move ShowScrollBar(p, SB_BOTH, FALSE) up a bit to just under SetWindowTheme(p,"","")
SetWindowTheme(p,"","")
ShowScrollBar(p, SB_BOTH, FALSE)
And reset my rectangle to the whole screen again.
All I have to do is give the console a title and you wouldn't recognise it as a console any more.
Actually I use this type of console for graphics in pascal.
So we have three methods for double buffering now, or more to the point, three methods to get rid of flickering.
Who is going to fix "win/uxtheme.bi", not me today anyway, I can't be bothered just now.
In fact I only have to move ShowScrollBar(p, SB_BOTH, FALSE) up a bit to just under SetWindowTheme(p,"","")
SetWindowTheme(p,"","")
ShowScrollBar(p, SB_BOTH, FALSE)
And reset my rectangle to the whole screen again.
All I have to do is give the console a title and you wouldn't recognise it as a console any more.
Actually I use this type of console for graphics in pascal.
So we have three methods for double buffering now, or more to the point, three methods to get rid of flickering.
Who is going to fix "win/uxtheme.bi", not me today anyway, I can't be bothered just now.