ab.com コミュニティ

マティさん、BitBltの性能について、詳しく説明していただいて
ありがとうございました。
[quote]
性能改善方法としては、Promptで行っているように画面とビットマップ（再描画用）の両方に描画する方法では、線描画に関しては（斜線の場合に）軌跡が一致しない問題もあり、使用しない方が良い時もあります。
（画面とビットマップでXORを行うと良くわかります。）
[/quote]
速い、速いと単に喜んでいたのですが、そうなんですか、うーん、となると
これはやっぱりちょっと考えた方がいいかも知れませんね。
(ただこれは一体どういう状況で、そうなるもんなのですか？ 同じ2点を
繋ぐなら、必ず同じドットで描かれるようにも単純に思ったりするるのですが。。
ちょっと奥の深そうな問題ですね。)
[quote]
また、ビットマップを使う場合に変更のあった部分のみを転送することで性能を改善する方法もありますので、色々試してみてください。
(変更のあった左上と右下の範囲をInvalidateRectで指定するとか)
[/quote]
BeginPaintでセットされるPAINTSTRUCT構造体をPaintイベント内で
取得出来ればいいのだろうと思うのですが。。。

　これから色々試してみて、改めて報告したいと思います。
レクありがとうごさいます。またよろしくお願いします。

BitBLTの性能についてですが
[quote]
'
'●ペイント・イベント
'
Sub MainWnd_Paint(hDC As HDC)
BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub

※clientRc.right=クライアントエリアの幅
clientRc.bottom=クライアントエリアの高さ
[/quote]
で全画面を描画するように指定していますが、実際に画面に転送されるデータはGDIにり画面に表示可能な範囲に分割後、ディスプレイドライバーで転送を行います。
（表示可能な領域の形状によっては、分割の必要が無い場合もあります。）
したがって表示可能なサイズと、分割される個数によって性能に変化がでる事になります。

[b]性能改善方法[/b]としては、Promptで行っているように画面とビットマップ（再描画用）の両方に描画する方法では、線描画に関しては（斜線の場合に）軌跡が一致しない問題もあり、使用しない方が良い時もあります。
（画面とビットマップでXORを行うと良くわかります。）

また、画面描画の方がビットマップに描画するよりも格段に早い場合は、描画コマンドを全て記憶し、再描画（クリッピングを指定して）を行うときに全描画コマンドを実行します。
（メモリーの少なかった時代は、この方法が主流でした。）

また、ビットマップを使う場合に[b]変更のあった部分のみを転送[/b]することで性能を改善する方法もありますので、色々試してみてください。
(変更のあった左上と右下の範囲をInvalidateRectで指定するとか)

'line
  MoveToEx(_PromptSys_hMemDC,sx,sy,ByVal NULL)
  LineTo(_PromptSys_hMemDC,ex,ey)
  SetPixel(_PromptSys_hMemDC,ex,ey,GetBasicColor(ColorCode))
  MoveToEx(hDC,sx,sy,ByVal NULL)
  LineTo(hDC,ex,ey)
  SetPixel(hDC,ex,ey,GetBasicColor(ColorCode))

'
' ●ライン描画 (MoveToEx & LineTo)
'
Sub DrawLine(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

'
'●ペイント・イベント
'
Sub MainWnd_Paint(hDC As HDC)
 BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub

※clientRc.right=クライアントエリアの幅
  clientRc.bottom=クライアントエリアの高さ

前の返信で僕は
[quote]
ただそれにしてもpromptウインドウでは何故あれだけ高速に
表示されるのかがやはり疑問なんです。
promptウインドウだって、結局のとこ内部で「BitBlt」してビットマップを
表示してるのでは？と思ったりして。
[/quote]
と書きましたが、それはどうやら違っていたみたいです。

　速度の差がどうしても気になって、あれから「prompt.sbp」を開いて
「Macro　LINE」の所を見てみたんですが、
「InvalidateRect」等のPaintイベントをコールする命令が無い。!
どうやって表示しているのかと不思議で仕方なかったのですが、
代わりに、
[code]
'line
MoveToEx(_PromptSys_hMemDC,sx,sy,ByVal NULL)
LineTo(_PromptSys_hMemDC,ex,ey)
SetPixel(_PromptSys_hMemDC,ex,ey,GetBasicColor(ColorCode))
MoveToEx(hDC,sx,sy,ByVal NULL)
LineTo(hDC,ex,ey)
SetPixel(hDC,ex,ey,GetBasicColor(ColorCode))
[/code]
こんな風に、「2回」セットで命令が繰り返し書かれていました。
つまりhDC(ウインドウのDC、直前にGetDCで取得)と、
そのウインドウのメモリビットマップのDCであるhMemDCに
それぞれ描画命令を行っている。
これによりわざわざPaintイベントでビットマップ転送命令を使うことなく
見た目の表示も、裏画面のメモリビットマップにも描画出来、高速に
処理を終えられる。
　なるほどなーと、

　早速、それに倣って自分のプログラムの
「DrawLine()」を次の様に書き直してみました。
[code]
'
' ●ライン描画 (MoveToEx & LineTo)
'
Sub DrawLine(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
[/code]
　実行結果は、

　渦巻きの描画終了までのタイムを計ってみると、

まず、直し前のMainWnd上の描画では約「2分30秒」
(プロンプト画面を前面にしたときの描画では約「41秒」、これでも差は
歴然としています。)

　直しをした後の実行結果は、MainWndを前面にした状態で
「4秒」。

　(もっとも一回の描画で「Line」が描画される回数が増えてきたりする場合など
元々の"メモリビットマップに描いて、それから一気にビットマップ転送"の
利点も出てくるのではないかとも思います。)

　それでも、知っている方には高速化の基本の技術なのかもしれないと
思うのですが、自分は正直驚きました。
　とりあえず、これで直しをしていきたいと思います。

　それからkonisiさん、改めてレクありがとうございました。
またよろしくお願いします。

　その後の報告と、感想でした。

------------------------------------------------

　ただ、「BitBlt命令」は、その後も色々やってみたんですが
MainWndが晒されている面積の大きさによって遅くなったり、速くなったり、
まちまちで、どうにも掴めません。
　よくよく考えてみれば、このプログラム内のペイント・イベントでは
[code]
'
'●ペイント・イベント
'
Sub MainWnd_Paint(hDC As HDC)
BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub

※clientRc.right=クライアントエリアの幅
clientRc.bottom=クライアントエリアの高さ
[/code]
として、常にクライアントエリア全体を更新しているので
ウインドウの晒されている面積が大きくなろうが小さくなろうが、
まったく隠れてしまおうが、全部見えていようが
ビットマップ転送の速度は変わらない筈じゃないかとも
思うのですが、、どうなのでしょうか？
　今現状ではかなり遅いです。

　konisiさん、レスありがとうございます。

括弧でくくってAsで宣言
「x=(r+xo) As Long」
と書くんですね。
キャストの方法、教えていただいてありがとうございました。
prompt.sbpの中身も順次変えていきたいと思います。

　それから、
[quote]
れはBitBlt(描画処理)があまりにも時間がかかるので体感できるほどの差になった。
BitBltをコメントアウトすると差はあるけど早すぎて体感できないくらいの速度。
ということだと思います。
[/quote]
恐らく、言われる通りだと思います。
メインウインドウが他のウインドウの重なりから離れて、
画面に多く晒されるほど、スピードは遅くなっていくようですから。

　ただそれにしてもpromptウインドウでは何故あれだけ高速に
表示されるのかがやはり疑問なんです。
promptウインドウだって、結局のとこ内部で「BitBlt」してビットマップを
表示してるのでは？と思ったりして。
　このままだと速度が気になるプログラムでは「MainWnd」を使いづらく、
promptウインドウを使わざるを得ないのかなと、悩んでいます。

  x=r+xo

  Dim xo As Long, yo As Long '渦巻き中心座標
  Dim x As Long, y As Long   '描画地点(中心からの相対座標)
  Dim r As Double  '渦巻き円の半径初期値

    x=(r+xo) As Long

  x=(r*Cos(o)+xo) As Long
  y=(r*Sin(o)+yo) As Long

	Dim hDC As HDC
	Dim hPen As HPEN, hOldPen As VoidPtr
	Dim hBrush As HBRUSH, hOldBrush As VoidPtr

まず、90行目
[code] x=r+xo[/code]については、これはx,r,xoの型の定義が[code] Dim xo As Long, yo As Long '渦巻き中心座標
Dim x As Long, y As Long '描画地点(中心からの相対座標)
Dim r As Double '渦巻き円の半径初期値[/code]となっている事から、r+xoの演算の答えはDouble型で、しかも代入先がLong型なので警告が出ています。
つまり「少数を含む可能性のある数値が少数を扱えない変数に代入されてますよ。」という意味で、「データが失われる可能性があります。」という警告が表示されています。
この類の警告を出さないようにする方法は大抵次の2通りで、変数rを宣言するときの型をLong型等の整数型にするか、あるいは[code] x=(r+xo) As Long[/code]とキャストするという方法です。
103行目、104行目で明らかにDouble型が返る計算をしているので、キャストしましょう。[code] x=(r*Cos(o)+xo) As Long
y=(r*Sin(o)+yo) As Long[/code]

他にはprompt.sbpから警告が出ていると思いますが、Long型で宣言されているhDC,hPen,hOldPen,hBrush,hOldBrush変数についてそれぞれ[code] Dim hDC As HDC
Dim hPen As HPEN, hOldPen As VoidPtr
Dim hBrush As HBRUSH, hOldBrush As VoidPtr[/code]と書き直せば警告は出なくなると思います。
[color=gray]ちなみに、説明文中に「大抵」と書いたのは他に方法があることもあるんです。でも普通使えないので省きました。[/color]

> 　プロンプトウィンドウとメインウインドウにそれぞれ
> 同様にラインでテストパターン(渦巻き)を描いていくプログラムを
> 作ったのですが、実行時にプロンプトウインドウが
> メインウインドウより前面にあるときと、その逆に
> メインがプロンプトより前面にあるときで
> 描画速度にかなりの差が見られます。
> (プログラムソースは一番下に)

確か、Windowsはフォアグランドウィンドウに対してCPUパワーを多く割り当てる、
という記憶が。
ですのでWindowsの仕様だと思います。(レジストリで変更できたような)

処理に時間のかかるアプリを2つ同時に起動して片方をフォアグランドにしておくと
そちらが先に終了するはずです。


> 　プロンプトが前面にあるときは描画スピードは
> 速く、メインを前に持ってきたときはその半分以下くらいに
> 描画スピードがガクっと遅くなります。
> 　色々チェックをしてみたところ、メインウインドウのペイント・イベント
> の「BitBlt命令」がその速度の違いの元になっているように思えました。
> (ここをRem文にすると速度に変化は無くなりました)

これはBitBlt(描画処理)があまりにも時間がかかるので体感できるほどの差になった。
BitBltをコメントアウトすると差はあるけど早すぎて体感できないくらいの速度。
ということだと思います。

間違ってるかもしれませんが。

'
'●ペイント・イベント
'
Sub MainWnd_Paint(hDC As HDC)
 BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub

'-----------------------------------------------------------------------------
'  イベント プロシージャ
'-----------------------------------------------------------------------------
' このファイルには、ウィンドウ [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: この位置にウィンドウメッセージを処理するためのコードを記述します。

	' イベントプロシージャの呼び出しを行います。
	MainWndProc=EventCall_MainWnd(hWnd,dwMsg,wParam,lParam)
End Function


'-----------------------------------------------------------------------------
' ここから下は、イベントプロシージャを記述するための領域になります。

Sub MainWnd_Destroy()
    DeleteDC(hMemDC)
    DeleteObject(hMemBmp)
    UzumakiTest424_DestroyObjects()
    PostQuitMessage(0)
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

'------- ↓これより描画ループ -------

 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, ByVal 0,0)
  Sleep(1)
  rc.left=rc.right
  rc.top=rc.bottom

'半径を序々に小さくする
  r=r-0.02

 Next i

'------- 描画ループ終わり -------

End Sub

'
'●ペイント・イベント
'
Sub MainWnd_Paint(hDC As HDC)
 BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub

'
'●リサイズ・メインウインドウ
'
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

'
' ●ライン描画(MoveToEx & LineTo)
'
Sub DrawLine(ByVal hDC As HDC)

 Dim hPen As HPEN
 Dim hOldPen As HPEN
 
  hPen= CreatePen(PS_SOLID,0,penColor)
  hOldPen=SelectObject(hDC,hPen)
    MoveToEx(hDC,rc.left,rc.top,ByVal NULL)
    LineTo(hDC,rc.right,rc.bottom)
  SelectObject(hDC,hOldPen)
  DeleteObject(hPen)

End Sub

'
' ●四角塗りつぶし(FillRect)
'
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の用意したプロンプトウインドウと、
　自分の作成したメインウインドウの描画スピード
の違いについて教えてください。

　プロンプトウィンドウとメインウインドウにそれぞれ
同様にラインでテストパターン(渦巻き)を描いていくプログラムを
作ったのですが、実行時にプロンプトウインドウが
メインウインドウより前面にあるときと、その逆に
メインがプロンプトより前面にあるときで
描画速度にかなりの差が見られます。
(プログラムソースは一番下に)

　プロンプトが前面にあるときは描画スピードは
速く、メインを前に持ってきたときはその半分以下くらいに
描画スピードがガクっと遅くなります。
　色々チェックをしてみたところ、メインウインドウのペイント・イベント
の「BitBlt命令」がその速度の違いの元になっているように思えました。
(ここをRem文にすると速度に変化は無くなりました)
[code]
'
'●ペイント・イベント
'
Sub MainWnd_Paint(hDC As HDC)
BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub
[/code]
が、それにしてもあそこまで速度に差が出てくるのは
どうしてなのか理由が分かりません。
　もしか自分のプログラムにどこか不正なところが
あるのではないかと思っているのですが。
　原因をお知りの方がおられましたら、是非教えてください。

AB version 4.24
(OS)Windows Me

※下のプログラムを実行するとデバッグ実行時に
警告がズラズラと出てきます。
　一つのグループはx,y座標などの値をDoubleで計算し
画面表示のためLong型の変数に無理やり代入した時に
検出されるもの。
　もう一つのグループはどうも「prompt.sys」の内部で
起こっている現象のようで(ハンドル類をLongで定義している
といった種類のもの)、いずれも自分では
これらの警告を取ることは出来ませんでした。
　ただし、そのままでも実行そのものには影響は無いように
思います。

　プロジェクト名「UzumakiTest424」で製作。

[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: この位置にウィンドウメッセージを処理するためのコードを記述します。

' イベントプロシージャの呼び出しを行います。
MainWndProc=EventCall_MainWnd(hWnd,dwMsg,wParam,lParam)
End Function


'-----------------------------------------------------------------------------
' ここから下は、イベントプロシージャを記述するための領域になります。

Sub MainWnd_Destroy()
DeleteDC(hMemDC)
DeleteObject(hMemBmp)
UzumakiTest424_DestroyObjects()
PostQuitMessage(0)
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

'------- ↓これより描画ループ -------

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, ByVal 0,0)
Sleep(1)
rc.left=rc.right
rc.top=rc.bottom

'半径を序々に小さくする
r=r-0.02

Next i

'------- 描画ループ終わり -------

End Sub

'
'●ペイント・イベント
'
Sub MainWnd_Paint(hDC As HDC)
BitBlt(hDC,0,0,clientRc.right,clientRc.bottom,hMemDC,0,0,SRCCOPY)
End Sub

'
'●リサイズ・メインウインドウ
'
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

'
' ●ライン描画(MoveToEx & LineTo)
'
Sub DrawLine(ByVal hDC As HDC)

Dim hPen As HPEN
Dim hOldPen As HPEN

hPen= CreatePen(PS_SOLID,0,penColor)
hOldPen=SelectObject(hDC,hPen)
MoveToEx(hDC,rc.left,rc.top,ByVal NULL)
LineTo(hDC,rc.right,rc.bottom)
SelectObject(hDC,hOldPen)
DeleteObject(hPen)

End Sub

'
' ●四角塗りつぶし(FillRect)
'
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]