by jacoby » 2006年9月16日(土) 02:50
描画速度の高速化のために
InvalidateRectで領域を指定した再描画を
させようと以下のようにプログラムを書いてみたのですが、、、
(ここにソースが表示されます) [ここをクリックすると内容が表示されます] [ここをクリックすると非表示にします]
コード: 全て選択
'-----------------------------------------------------------------------------
' イベント プロシージャ
'-----------------------------------------------------------------------------
' このファイルには、ウィンドウ [MainWnd] に関するイベントをコーディングします。
' ウィンドウ ハンドル: hMainWnd
' TODO: この位置にグローバルな変数、構造体、定数、関数を定義します。
#prompt
Declare Function AdjustWindowRectEx Lib "user32" Alias "AdjustWindowRectEx" (ByRef lpRect As RECT, ByVal dsStyle As Long, ByVal bMenu As Long, ByVal dwEsStyle As Long) As Long
Dim windowRc As RECT 'ウインドウの大きさ
Dim clientRc As RECT 'クライアントエリアの大きさ
Dim hMemDC As HDC 'メモリ・ビットマップのDCハンドル
Dim hMemBmp As HBITMAP 'メモリ・ビットマップハンドル
Dim hThread1 As HANDLE 'スレッド1のハンドル
Dim thread1_ID As DWord 'スレッド1のID
Dim bkColor As DWord '背景色
Dim penColor As DWord 'ペン描画色
Dim brushColor As DWord 'ブラシ描画色
Dim rc As RECT 'GDI命令汎用
'-----------------------------------------------------------------------------
' ウィンドウメッセージを処理するためのコールバック関数
Function MainWndProc(hWnd As HWND, dwMsg As DWord, wParam As WPARAM, lParam As LPARAM) As DWord
' TODO: この位置にウィンドウメッセージを処理するためのコードを記述します。
Select Case dwMsg
Case WM_DESTROY
MainWnd_Destroy()
Case WM_CREATE
hMainWnd=hWnd
MainWnd_Create(ByVal (lParam As VoidPtr))
'---------- 今回「PAINTSTRUCT」参照の為、ここを変更 -------------
Case WM_PAINT
Dim ps As PAINTSTRUCT
Dim hDC As HDC
hDC=BeginPaint(hWnd,ps)
MainWnd_MyPaint(hDC,ps)
EndPaint(hWnd,ps)
'-----------------------------------------------------------------------
Case WM_CLOSE
Dim cancel=0 As Integer
If cancel=0 Then DestroyWindow(hWnd)
Case Else
MainWndProc=DefWindowProc(hWnd,dwMsg,wParam,lParam)
Exit Function
End Select
MainWndProc=0
' イベントプロシージャの呼び出しを行います。(今回はスキップ)
'MainWndProc=EventCall_MainWnd(hWnd,dwMsg,wParam,lParam)
End Function
'-----------------------------------------------------------------------------
' ここから下は、イベントプロシージャを記述するための領域になります。
Sub MainWnd_Destroy()
DeleteDC(hMemDC)
DeleteObject(hMemBmp)
UzumakiTest424_DestroyObjects()
PostQuitMessage(0)
End Sub
'
'●ペイント・イベント(今回は使用しない)
'
Sub MainWnd_Paint(hDC As HDC)
BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub
'
'●マイ・ペイント・イベント(領域を指定した再描画。今回これを使用する)
'
Sub MainWnd_MyPaint(ByVal hDC As HDC, ByRef ps As PAINTSTRUCT)
Dim xa As Long
Dim ya As Long
Dim xv As Long
Dim yv As Long
xa=ps.rcPaint.left
ya=ps.rcPaint.top
xv=ps.rcPaint.right-xa+1
yv=ps.rcPaint.bottom-ya+1
BitBlt(hDC,xa,ya,xv,yv,hMemDC,xa,ya,SRCCOPY)
End Sub
'
' ●クリエイト・イベント
'
Sub MainWnd_Create(ByRef CreateStruct As CREATESTRUCT)
'メインウインドウのリサイズ
ResizeMainWindow()
' メモリ・ビットマップの作成
CreateMemBitMaps()
'メイン・メモリBmpのクリア
ClearMemBmp()
' 背景色の設定
SetBackColor()
'スレッドの定義
hThread1=CreateThread(ByVal 0,0,AddressOf(MainOperation),0,0,VarPtr(thread1_ID))
End Sub
'
'●スレッド1
'
Sub MainOperation(dwDummy As DWord)
Dim pi As Double '円周率
Dim xo As Long, yo As Long '渦巻き中心座標
Dim x As Long, y As Long '描画地点(中心からの相対座標)
Dim div As Long '円周の分割数
Dim r As Double '渦巻き円の半径初期値
Dim o As Double 'Sin,Cos用の角度セット用
Dim i As Long 'ループカウンタ
penColor=RGB(255,255,0)
pi=3.1415926535898
xo=clientRc.right\2 'スクリーン中心座標を
yo=clientRc.bottom\2 ' 渦巻き中心座標としてセット
div=256
r=240
'最初の描画地点にカレントポジションを移動
x=r+xo
y=yo
Pset(x,y),6
rc.left=x
rc.top=y
SetForegroundWindow(hMainWnd)
For i=1 To div*32 ' 32周渦巻きを描画
'描画位置の計算
o=2*pi*(i mod div)/div
x=r*Cos(o)+xo
y=r*Sin(o)+yo
'プロンプトウインドウに描画
Line -(x,y),6
'MainWndに描画
rc.right=x
rc.bottom=y
DrawLine(hMemDC)
InvalidateRect(hMainWnd, rc, FALSE)
Sleep(1)
rc.left=rc.right
rc.top=rc.bottom
'半径を序々に小さくする
r=r-0.02
Next i
End Sub
'---------------------------------------------------------
'---------------------------------------------------------
'↓これより以降はスレッド1の流れと直接関係ないサブ群
'
'●リサイズ・メインウインドウ
'
Sub ResizeMainWindow()
GetClientRect(_PromptSys_hWnd,clientRc)
windowRc.left=clientRc.left
windowRc.top=clientRc.top
windowRc.right=clientRc.right
windowRc.bottom=clientRc.bottom
AdjustWindowRectEx(windowRc, GetWindowLong(hMainWnd, GWL_STYLE), FALSE, GetWindowLong(hMainWnd, GWL_EXSTYLE))
MoveWindow(hMainWnd, windowRc.left+100, windowRc.top+100, windowRc.right-windowRc.left, windowRc.bottom-windowRc.top, TRUE)
End Sub
'
' ●メモリ・ビットマップの作成
'
Sub CreateMemBitMaps()
Dim hDC As HDC
hDC=GetDC(hMainWnd)
' メインのメモリ・ビットマップ作成
hMemDC=CreateCompatibleDC(hDC)
hMemBmp=CreateCompatibleBitmap(hDC, clientRc.right, clientRc.bottom)
SelectObject(hMemDC,hMemBmp)
ReleaseDC(hMainWnd,hDC)
End Sub
'
' ●メイン・メモリBmpのクリア
'
Sub ClearMemBmp()
Dim hBrush As HBRUSH
Dim hOldBrush As HBRUSH
brushColor=bkColor
rc.left=clientRc.left
rc.top=clientRc.top
rc.right=clientRc.right
rc.bottom=clientRc.bottom
DrawBoxFill(hMemDC)
End Sub
'
' ●背景色の設定
'
Sub SetBackColor()
Dim hBrush As HBRUSH
Dim hOldBrush As HBRUSH
' 背景色の設定
bkColor=RGB(0,0,0)
SetBkMode(hMemDC,OPAQUE)
SetBkColor(hMemDC,bkColor)
End Sub
'
' ●ライン描画(DrawLine GDI)
'
Sub DrawLine(ByVal hMemDC As HDC)
Dim hDC As HDC
Dim hPen As HPEN
Dim hOldPen As HPEN
hPen= CreatePen(PS_SOLID,0,penColor)
SelectObject(hDC,hPen)
hOldPen=SelectObject(hMemDC,hPen)
MoveToEx(hMemDC,rc.left,rc.top,ByVal NULL)
LineTo(hMemDC,rc.right,rc.bottom)
SetPixel(hMemDC,rc.right,rc.bottom,penColor)
SelectObject(hMemDC,hOldPen)
DeleteObject(hPen)
End Sub
'
' ●ライン描画高速版(DrawLine GDI)
'
Sub DrawLineHighSpeed(ByVal hWnd As HWND, ByVal hMemDC As HDC)
Dim hDC As HDC
Dim hPen As HPEN
Dim hOldPen As HPEN
hDC=GetDC(hWnd)
hPen= CreatePen(PS_SOLID,0,penColor)
SelectObject(hDC,hPen)
hOldPen=SelectObject(hMemDC,hPen)
MoveToEx(hMemDC,rc.left,rc.top,ByVal NULL)
LineTo(hMemDC,rc.right,rc.bottom)
SetPixel(hMemDC,rc.right,rc.bottom,penColor)
MoveToEx(hDC,rc.left,rc.top,ByVal NULL)
LineTo(hDC,rc.right,rc.bottom)
SetPixel(hDC,rc.right,rc.bottom,penColor)
ReleaseDC(hWnd,hDC)
SelectObject(hMemDC,hOldPen)
DeleteObject(hPen)
End Sub
'
' ●四角塗りつぶし(FillRectangle)
'
Sub DrawBoxFill(ByVal hDC As HDC)
Dim hBrush As HBRUSH
Dim hOldBrush As HBRUSH
hBrush=CreateSolidBrush(brushColor)
hOldBrush=SelectObject(hDC,hBrush)
FillRect(hDC,rc,hBrush)
SelectObject(hDC,hOldBrush)
DeleteObject(hBrush)
End Sub
(AB 4.24でプロジェクト名「UzumakiTest424」で製作。)
プログラムは以前のスレ「描画速度の違いについて」で作った
「ラインで画面に序々に渦巻き模様を描いて行く」というものです。
まず自分で「PAINTSTRUCT構造体」を参照するため
本来CallBack.wbpの中で書かれている
EventCall_MainWnd()の中身をごっそり
MainWnd_Proc()の方へコピーして持って来て、
(その際MainWnd_Proc()の中ではEventCall_MainWnd()へ
行かないように流れを切りました。)
ウインドウメッセージ処理のSelectCase分岐で
WM_PAINTのところ、
コード: 全て選択
'---------- 今回「PAINTSTRUCT」参照の為、ここを変更 ---------
Case WM_PAINT
Dim ps As PAINTSTRUCT
Dim hDC As HDC
hDC=BeginPaint(hWnd,ps)
MainWnd_MyPaint(hDC,ps)
EndPaint(hWnd,ps)
'-----------------------------------------------------
このように変えて、
更にMainWnd_MyPaint()という自前のペイントイベント処理サブを
新たに作り、そこでPAINTSTRUCT構造体を参照するようにしました。
コード: 全て選択
'
'●マイ・ペイント・イベント(領域を指定した再描画。今回これを使用する)
'
Sub MainWnd_MyPaint(ByVal hDC As HDC, ByRef ps As PAINTSTRUCT)
Dim xa As Long
Dim ya As Long
Dim xv As Long
Dim yv As Long
xa=ps.rcPaint.left
ya=ps.rcPaint.top
xv=ps.rcPaint.right-xa+1
yv=ps.rcPaint.bottom-ya+1
BitBlt(hDC,xa,ya,xv,yv,hMemDC,xa,ya,SRCCOPY)
End Sub
とりあえずこのようにしてinvalidateRectの領域指定で
コード: 全て選択
'MainWndに描画
rc.right=x
rc.bottom=y
DrawLine(hMemDC)
InvalidateRect(hMainWnd, rc, FALSE)
Sleep(1)
として再描画させようと思ったのですが、
実行結果は、上のソースを実際実行していただければ一目瞭然なのですが
「再描画される所、されない所が出てきてしまい」、このままでは使い物になりません。
PAINTSTRUCT構造体の再描画領域の取得そのものは
出来ているように思えるのですが、実際に描画されるのは
渦巻き円の右上部分だけで、後はまるで線が「かすれる」ように消えていく
感じです。
InvalidateRect命令の再描画領域の指定を
行うにはどうすれば良いのでしょうか？
(その他でもプログラム中で直す所がありましたら教えて下さい)
(環境 WinMe / AB 4.24)
描画速度の高速化のために
InvalidateRectで領域を指定した再描画を
させようと以下のようにプログラムを書いてみたのですが、、、
[hide=(ここにソースが表示されます)]
[code]
'-----------------------------------------------------------------------------
' イベント プロシージャ
'-----------------------------------------------------------------------------
' このファイルには、ウィンドウ [MainWnd] に関するイベントをコーディングします。
' ウィンドウ ハンドル: hMainWnd
' TODO: この位置にグローバルな変数、構造体、定数、関数を定義します。
#prompt
Declare Function AdjustWindowRectEx Lib "user32" Alias "AdjustWindowRectEx" (ByRef lpRect As RECT, ByVal dsStyle As Long, ByVal bMenu As Long, ByVal dwEsStyle As Long) As Long
Dim windowRc As RECT 'ウインドウの大きさ
Dim clientRc As RECT 'クライアントエリアの大きさ
Dim hMemDC As HDC 'メモリ・ビットマップのDCハンドル
Dim hMemBmp As HBITMAP 'メモリ・ビットマップハンドル
Dim hThread1 As HANDLE 'スレッド1のハンドル
Dim thread1_ID As DWord 'スレッド1のID
Dim bkColor As DWord '背景色
Dim penColor As DWord 'ペン描画色
Dim brushColor As DWord 'ブラシ描画色
Dim rc As RECT 'GDI命令汎用
'-----------------------------------------------------------------------------
' ウィンドウメッセージを処理するためのコールバック関数
Function MainWndProc(hWnd As HWND, dwMsg As DWord, wParam As WPARAM, lParam As LPARAM) As DWord
' TODO: この位置にウィンドウメッセージを処理するためのコードを記述します。
Select Case dwMsg
Case WM_DESTROY
MainWnd_Destroy()
Case WM_CREATE
hMainWnd=hWnd
MainWnd_Create(ByVal (lParam As VoidPtr))
'---------- 今回「PAINTSTRUCT」参照の為、ここを変更 -------------
Case WM_PAINT
Dim ps As PAINTSTRUCT
Dim hDC As HDC
hDC=BeginPaint(hWnd,ps)
MainWnd_MyPaint(hDC,ps)
EndPaint(hWnd,ps)
'-----------------------------------------------------------------------
Case WM_CLOSE
Dim cancel=0 As Integer
If cancel=0 Then DestroyWindow(hWnd)
Case Else
MainWndProc=DefWindowProc(hWnd,dwMsg,wParam,lParam)
Exit Function
End Select
MainWndProc=0
' イベントプロシージャの呼び出しを行います。(今回はスキップ)
'MainWndProc=EventCall_MainWnd(hWnd,dwMsg,wParam,lParam)
End Function
'-----------------------------------------------------------------------------
' ここから下は、イベントプロシージャを記述するための領域になります。
Sub MainWnd_Destroy()
DeleteDC(hMemDC)
DeleteObject(hMemBmp)
UzumakiTest424_DestroyObjects()
PostQuitMessage(0)
End Sub
'
'●ペイント・イベント(今回は使用しない)
'
Sub MainWnd_Paint(hDC As HDC)
BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub
'
'●マイ・ペイント・イベント(領域を指定した再描画。今回これを使用する)
'
Sub MainWnd_MyPaint(ByVal hDC As HDC, ByRef ps As PAINTSTRUCT)
Dim xa As Long
Dim ya As Long
Dim xv As Long
Dim yv As Long
xa=ps.rcPaint.left
ya=ps.rcPaint.top
xv=ps.rcPaint.right-xa+1
yv=ps.rcPaint.bottom-ya+1
BitBlt(hDC,xa,ya,xv,yv,hMemDC,xa,ya,SRCCOPY)
End Sub
'
' ●クリエイト・イベント
'
Sub MainWnd_Create(ByRef CreateStruct As CREATESTRUCT)
'メインウインドウのリサイズ
ResizeMainWindow()
' メモリ・ビットマップの作成
CreateMemBitMaps()
'メイン・メモリBmpのクリア
ClearMemBmp()
' 背景色の設定
SetBackColor()
'スレッドの定義
hThread1=CreateThread(ByVal 0,0,AddressOf(MainOperation),0,0,VarPtr(thread1_ID))
End Sub
'
'●スレッド1
'
Sub MainOperation(dwDummy As DWord)
Dim pi As Double '円周率
Dim xo As Long, yo As Long '渦巻き中心座標
Dim x As Long, y As Long '描画地点(中心からの相対座標)
Dim div As Long '円周の分割数
Dim r As Double '渦巻き円の半径初期値
Dim o As Double 'Sin,Cos用の角度セット用
Dim i As Long 'ループカウンタ
penColor=RGB(255,255,0)
pi=3.1415926535898
xo=clientRc.right\2 'スクリーン中心座標を
yo=clientRc.bottom\2 ' 渦巻き中心座標としてセット
div=256
r=240
'最初の描画地点にカレントポジションを移動
x=r+xo
y=yo
Pset(x,y),6
rc.left=x
rc.top=y
SetForegroundWindow(hMainWnd)
For i=1 To div*32 ' 32周渦巻きを描画
'描画位置の計算
o=2*pi*(i mod div)/div
x=r*Cos(o)+xo
y=r*Sin(o)+yo
'プロンプトウインドウに描画
Line -(x,y),6
'MainWndに描画
rc.right=x
rc.bottom=y
DrawLine(hMemDC)
InvalidateRect(hMainWnd, rc, FALSE)
Sleep(1)
rc.left=rc.right
rc.top=rc.bottom
'半径を序々に小さくする
r=r-0.02
Next i
End Sub
'---------------------------------------------------------
'---------------------------------------------------------
'↓これより以降はスレッド1の流れと直接関係ないサブ群
'
'●リサイズ・メインウインドウ
'
Sub ResizeMainWindow()
GetClientRect(_PromptSys_hWnd,clientRc)
windowRc.left=clientRc.left
windowRc.top=clientRc.top
windowRc.right=clientRc.right
windowRc.bottom=clientRc.bottom
AdjustWindowRectEx(windowRc, GetWindowLong(hMainWnd, GWL_STYLE), FALSE, GetWindowLong(hMainWnd, GWL_EXSTYLE))
MoveWindow(hMainWnd, windowRc.left+100, windowRc.top+100, windowRc.right-windowRc.left, windowRc.bottom-windowRc.top, TRUE)
End Sub
'
' ●メモリ・ビットマップの作成
'
Sub CreateMemBitMaps()
Dim hDC As HDC
hDC=GetDC(hMainWnd)
' メインのメモリ・ビットマップ作成
hMemDC=CreateCompatibleDC(hDC)
hMemBmp=CreateCompatibleBitmap(hDC, clientRc.right, clientRc.bottom)
SelectObject(hMemDC,hMemBmp)
ReleaseDC(hMainWnd,hDC)
End Sub
'
' ●メイン・メモリBmpのクリア
'
Sub ClearMemBmp()
Dim hBrush As HBRUSH
Dim hOldBrush As HBRUSH
brushColor=bkColor
rc.left=clientRc.left
rc.top=clientRc.top
rc.right=clientRc.right
rc.bottom=clientRc.bottom
DrawBoxFill(hMemDC)
End Sub
'
' ●背景色の設定
'
Sub SetBackColor()
Dim hBrush As HBRUSH
Dim hOldBrush As HBRUSH
' 背景色の設定
bkColor=RGB(0,0,0)
SetBkMode(hMemDC,OPAQUE)
SetBkColor(hMemDC,bkColor)
End Sub
'
' ●ライン描画(DrawLine GDI)
'
Sub DrawLine(ByVal hMemDC As HDC)
Dim hDC As HDC
Dim hPen As HPEN
Dim hOldPen As HPEN
hPen= CreatePen(PS_SOLID,0,penColor)
SelectObject(hDC,hPen)
hOldPen=SelectObject(hMemDC,hPen)
MoveToEx(hMemDC,rc.left,rc.top,ByVal NULL)
LineTo(hMemDC,rc.right,rc.bottom)
SetPixel(hMemDC,rc.right,rc.bottom,penColor)
SelectObject(hMemDC,hOldPen)
DeleteObject(hPen)
End Sub
'
' ●ライン描画高速版(DrawLine GDI)
'
Sub DrawLineHighSpeed(ByVal hWnd As HWND, ByVal hMemDC As HDC)
Dim hDC As HDC
Dim hPen As HPEN
Dim hOldPen As HPEN
hDC=GetDC(hWnd)
hPen= CreatePen(PS_SOLID,0,penColor)
SelectObject(hDC,hPen)
hOldPen=SelectObject(hMemDC,hPen)
MoveToEx(hMemDC,rc.left,rc.top,ByVal NULL)
LineTo(hMemDC,rc.right,rc.bottom)
SetPixel(hMemDC,rc.right,rc.bottom,penColor)
MoveToEx(hDC,rc.left,rc.top,ByVal NULL)
LineTo(hDC,rc.right,rc.bottom)
SetPixel(hDC,rc.right,rc.bottom,penColor)
ReleaseDC(hWnd,hDC)
SelectObject(hMemDC,hOldPen)
DeleteObject(hPen)
End Sub
'
' ●四角塗りつぶし(FillRectangle)
'
Sub DrawBoxFill(ByVal hDC As HDC)
Dim hBrush As HBRUSH
Dim hOldBrush As HBRUSH
hBrush=CreateSolidBrush(brushColor)
hOldBrush=SelectObject(hDC,hBrush)
FillRect(hDC,rc,hBrush)
SelectObject(hDC,hOldBrush)
DeleteObject(hBrush)
End Sub
[/code]
[/hide]
(AB 4.24でプロジェクト名「UzumakiTest424」で製作。)
プログラムは以前のスレ「描画速度の違いについて」で作った
「ラインで画面に序々に渦巻き模様を描いて行く」というものです。
まず自分で「PAINTSTRUCT構造体」を参照するため
本来CallBack.wbpの中で書かれている
EventCall_MainWnd()の中身をごっそり
MainWnd_Proc()の方へコピーして持って来て、
(その際MainWnd_Proc()の中ではEventCall_MainWnd()へ
行かないように流れを切りました。)
ウインドウメッセージ処理のSelectCase分岐で
WM_PAINTのところ、
[code]
'---------- 今回「PAINTSTRUCT」参照の為、ここを変更 ---------
Case WM_PAINT
Dim ps As PAINTSTRUCT
Dim hDC As HDC
hDC=BeginPaint(hWnd,ps)
MainWnd_MyPaint(hDC,ps)
EndPaint(hWnd,ps)
'-----------------------------------------------------
[/code]
このように変えて、
更にMainWnd_MyPaint()という自前のペイントイベント処理サブを
新たに作り、そこでPAINTSTRUCT構造体を参照するようにしました。
[code]
'
'●マイ・ペイント・イベント(領域を指定した再描画。今回これを使用する)
'
Sub MainWnd_MyPaint(ByVal hDC As HDC, ByRef ps As PAINTSTRUCT)
Dim xa As Long
Dim ya As Long
Dim xv As Long
Dim yv As Long
xa=ps.rcPaint.left
ya=ps.rcPaint.top
xv=ps.rcPaint.right-xa+1
yv=ps.rcPaint.bottom-ya+1
BitBlt(hDC,xa,ya,xv,yv,hMemDC,xa,ya,SRCCOPY)
End Sub
[/code]
とりあえずこのようにしてinvalidateRectの領域指定で
[code]
'MainWndに描画
rc.right=x
rc.bottom=y
DrawLine(hMemDC)
InvalidateRect(hMainWnd, rc, FALSE)
Sleep(1)
[/code]
として再描画させようと思ったのですが、
実行結果は、上のソースを実際実行していただければ一目瞭然なのですが
「再描画される所、されない所が出てきてしまい」、このままでは使い物になりません。
PAINTSTRUCT構造体の再描画領域の取得そのものは
出来ているように思えるのですが、実際に描画されるのは
渦巻き円の右上部分だけで、後はまるで線が「かすれる」ように消えていく
感じです。
InvalidateRect命令の再描画領域の指定を
行うにはどうすれば良いのでしょうか？
(その他でもプログラム中で直す所がありましたら教えて下さい)
(環境 WinMe / AB 4.24)