ファイルダウンロード支援ツールなどにあるリストビューの中にプログレスバーがあって、ファイルのダウンロードの進行具合を把握できるやつありますよね。あれってどうやってるのでしょう？
カスタムドローとかでやらないとなのでしょうか
そうですね、カスタムドローという事になるかと思います。
VB6であれば、下記の『グラフ機能付きリストビュー』とか。
http://www.mitene.or.jp/~sugisita/vb6_cmctl.html
解答ありがとうございます。
まさにこういうことがやりたかったので、参考になりました。
今ダウンロードしていじっているんですが、プログレスバー的な使い方をするとちらつきがかなり気になります。
ソースの中のコメントにちらつきの解決策の例が書かれているのですが、当方３週間前に初めてVBに触ったもので書いてあることがよくわかりません。
カスタムドローの処理系をメモリデバイスコンテキストを描画してからBitBltで一括転送するようにしてみると良い・・・
と書かれているのですが、どこをどういじっていいのやら・・・誰かわかる方がいたらご教授願います。
> カスタムドローの処理系をメモリデバイスコンテキストを描画してから
> BitBltで一括転送するようにしてみると良い・・・
以前試した時、カスタムドローでは、ちらつきを抑えきれなかったと思う。
代わりに、WM_PAINTメッセージで、描画処理をした様な．．．
むろん、メモリＤＣに描いてBitBltが必須。
何処かに、サンプルがあったと思うが．．．思い出せない。
以上
今、ちらつきの事に関するサイト巡りをしております。
＞以前試した時、カスタムドローでは、ちらつきを抑えきれなかったと思う。
＞代わりに、WM_PAINTメッセージで、描画処理をした様な．．．
そうなんですか？知識が浅いものでよくわからないのですが・・・
ちょっと長くなりますがソースを載せてみます。
'==============================================================================
' サブクラス化を行う際のウィンドウプロシージャ
'==============================================================================
Public Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim udtNMHdr As NMHDR
Dim udtNMLvw As NMLISTVIEW
Dim udtCdLvw As NMLVCUSTOMDRAW
Dim colBarItems As BarItems
Dim clsBarItem As BarItem
Dim lngObj As Long
Select Case uMsg
Case WM_NOTIFY
CopyMemory udtNMHdr, ByVal lParam, LenB(udtNMHdr)
If GetProp(udtNMHdr.hwndFrom, PROP_GRAPHLIST) Then
CopyMemory udtNMLvw, ByVal lParam, LenB(udtNMLvw)
If udtNMLvw.hdr.code = NM_CUSTOMDRAW Then
CopyMemory udtCdLvw, ByVal lParam, LenB(udtCdLvw)
Select Case udtCdLvw.nmcd.dwDrawStage
Case CDDS_POSTERASE, CDDS_PREERASE
WindowProc = CDRF_DODEFAULT
Case CDDS_PREPAINT
WindowProc = CDRF_NOTIFYITEMDRAW
Case CDDS_ITEMPREPAINT 'アイテムの描画を行う直前のメッセージ
WindowProc = CDRF_NOTIFYPOSTPAINT
Case CDDS_ITEMPOSTPAINT 'アイテムの描画を行った直後のメッセージ
'-- グラフの描画
Set colBarItems = objArray.Item(CStr(udtNMHdr.hwndFrom))
For Each clsBarItem In colBarItems
Call DrawGraph(udtNMLvw.hdr.hwndFrom, udtCdLvw.nmcd.hdc, _
udtCdLvw.nmcd.dwItemSpec, clsBarItem.TargetColumn, _
clsBarItem.ForeColor)
Next
WindowProc = CDRF_DODEFAULT
End Select
End If
End If
Case Else
End Select
If WindowProc = 0& Then
WindowProc = CallWindowProc(lpProcOrg, hwnd, uMsg, wParam, lParam)
End If
End Function
'==============================================================================
' グラフの描画メソッド
'==============================================================================
Private Sub DrawGraph(ByVal hwnd As Long, ByVal hdc As Long, _
ByVal iItemIndex As Long, ByVal iColumnIndex As Long, _
ByVal clrForeColor As Long)
Dim strVal As String
Dim curVal As Currency
Dim udtRect As RECT
Dim hFont As Long
Dim hOldBrush As Long
Dim hBrush As Long
Dim hOldPen As Long
Dim hPen As Long
Dim lngOldColor As Long
ListView_GetSubItemRect hwnd, iItemIndex, iColumnIndex, LVIR_BOUNDS, udtRect
'-- 見た目を良くするために各行間を1ピクセルづつあける
udtRect.Top = udtRect.Top + 1
udtRect.Bottom = udtRect.Bottom
udtRect.Left = udtRect.Left + 1
udtRect.Right = udtRect.Right - 1
hFont = GetStockObject(DEFAULT_GUI_FONT)
SelectObject hdc, hFont
'-- いったん白で塗りつぶす
hPen = GetStockObject(NULL_PEN)
hBrush = CreateSolidBrush(vbWhite)
hOldPen = SelectObject(hdc, hPen)
hOldBrush = SelectObject(hdc, hBrush)
Rectangle hdc, _
udtRect.Left, _
udtRect.Top, _
udtRect.Right, _
udtRect.Bottom
DeleteObject SelectObject(hdc, hOldBrush)
'-- テキストの描画
lngOldColor = GetTextColor(hdc)
ListView_GetItemText hwnd, iItemIndex, iColumnIndex, strVal
If IsNumeric(strVal) Then
curVal = CCur(strVal)
Else
curVal = 0
End If
SetTextColor hdc, clrForeColor
DrawText hdc, curVal & "%", -1, udtRect, DT_CENTER Or DT_VCENTER Or DT_SINGLELINE
If curVal > 100 Then
curVal = 100
End If
'-- 反転モード
SetROP2 hdc, R2_NOTXORPEN
'-- 値に応じたバーの塗りつぶし
hBrush = CreateSolidBrush(clrForeColor)
hOldBrush = SelectObject(hdc, hBrush)
Rectangle hdc, _
udtRect.Left, _
udtRect.Top, _
udtRect.Left + Fix((udtRect.Right - udtRect.Left) * curVal / 100), _
udtRect.Bottom
DeleteObject SelectObject(hdc, hOldBrush)
DeleteObject SelectObject(hdc, hOldPen)
'-- 枠線の描画
SetROP2 hdc, R2_COPYPEN
hBrush = GetStockObject(NULL_BRUSH)
hOldBrush = SelectObject(hdc, hBrush)
hPen = GetStockObject(BLACK_PEN)
hOldPen = SelectObject(hdc, hPen)
Rectangle hdc, _
udtRect.Left, _
udtRect.Top, _
udtRect.Right, _
udtRect.Bottom
Call SelectObject(hdc, hOldBrush)
Call SelectObject(hdc, hOldPen)
'-- 最後にテキストカラーを描画前の色に戻す
SetTextColor hdc, lngOldColor
End Sub
DrawGraphの中でhdc(表画面？)に逐一書き込んでいるのがちらつきの原因なんでしょうかね？サイト巡りをしてみたところ、CreateCompatibleDCなんかを使って裏画面みたいなものをつくって、それを一気に表画面に転送すればちらつきを抑えられる見たいな事がよく書かれているのですが・・・実際にどういう風にやればいいかわかりません。
それともますおさんがおっしゃるみたいにカスタムドローではちらつきは抑えられないのでしょうか？
> ちょっと長くなりますがソースを載せてみます。
無断転載なら、マズイんとちゃいまっか？
リンク貼ってもらってるんで必要なかったかと。
> カスタムドローではちらつきは抑えられないのでしょうか？
カスタムドローでその方法を見つけ出せなかっただけどす。
代替策として、WM_PAINTメッセージ処理で、グラフ機能を付けて、
ちらつきを抑えたVB6サンプルが残っていたので、載せておきます。
未完成なので、適当に手を入れて下さい。
「グラフ機能付きリストビュー」サンプルに対して以下を変更。
Private Sub Form_Load()
・・・・・・・・
'-- サブクラス化
SubClass ListView1.hwnd '// ウィンドウハンドル変更
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
'-- サブクラス化終了
UnSubClass ListView1.hwnd '// ウィンドウハンドル変更
・・・・・・・・
End Sub
'// 中身をすべて差し換える。
Public Function WindowProc(ByVal hwnd As Long, _
ByVal uMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
Select Case uMsg
Case WM_PAINT
Static fNotPaint As Boolean
Dim rcLV As RECT
Dim ps As PAINTSTRUCT
Dim hdc As Long
Dim hdcMem As Long
Dim hBmpMem As Long
Dim hOldBmpMem As Long
Dim hdcMem0 As Long
Dim hBmpMem0 As Long
Dim hOldBmpMem0 As Long
Dim iItem As Long
Dim iColumn As Long
Dim clrForeColor As Long
Dim lngOldColor As Long
Dim rcItem As RECT
Dim rc As RECT
Dim hFont As Long
Dim hOldFont As Long
Dim hPen As Long
Dim hOldPen As Long
Dim hBrush As Long
Dim hOldBrush As Long
Dim strVal As String
Dim curVal As Currency
If (fNotPaint) Then
WindowProc = CallWindowProc(lpProcOrg, hwnd, uMsg, wParam, lParam)
Exit Function
End If
fNotPaint = True
hdc = BeginPaint(hwnd, ps)
hdcMem = CreateCompatibleDC(hdc)
Call GetClientRect(hwnd, rcLV)
hBmpMem = CreateCompatibleBitmap(hdc, rcLV.Right - rcLV.Left, _
rcLV.Bottom - rcLV.Top)
hOldBmpMem = SelectObject(hdcMem, hBmpMem)
Call Rectangle(hdcMem, -1, -1, rcLV.Right - rcLV.Left + 1, _
rcLV.Bottom - rcLV.Top + 1)
Call SendMessage(hwnd, WM_PAINT, hdcMem, ByVal 0&)
clrForeColor = vbBlack
For iItem = 0 To 2
For iColumn = 3 To 4
Call ListView_GetSubItemRect(hwnd, iItem, iColumn, _
LVIR_BOUNDS, rcItem)
hdcMem0 = CreateCompatibleDC(hdc)
hBmpMem0 = CreateCompatibleBitmap(hdc, _
rcItem.Right - rcItem.Left, _
rcItem.Bottom - rcItem.Top)
hOldBmpMem0 = SelectObject(hdcMem0, hBmpMem0)
'-- いったん白で塗りつぶす
hBrush = CreateSolidBrush(vbWhite)
hOldBrush = SelectObject(hdcMem0, hBrush)
Call Rectangle(hdcMem0, -1, -1, _
rcItem.Right - rcItem.Left + 1, _
rcItem.Bottom - rcItem.Top + 1)
Call SelectObject(hdcMem0, hOldBrush)
Call DeleteObject(hBrush)
'-- 見た目を良くするために各行間を1ピクセルづつあける
Call SetRect(rc, 1, 1, rcItem.Right - rcItem.Left - 1, _
rcItem.Bottom - rcItem.Top - 1)
'-- テキストの描画
hFont = GetStockObject(DEFAULT_GUI_FONT)
hOldFont = SelectObject(hdcMem0, hFont)
lngOldColor = SetTextColor(hdcMem0, clrForeColor)
Call ListView_GetItemText(hwnd, iItem, iColumn, strVal)
If (IsNumeric(strVal)) Then
curVal = CCur(strVal)
Else
curVal = 0
End If
Call DrawText(hdcMem0, curVal & "%", -1, rc, _
DT_CENTER Or DT_VCENTER Or DT_SINGLELINE)
If (curVal > 100) Then curVal = 100
Call SelectObject(hdcMem0, hOldFont)
Call SetTextColor(hdcMem0, lngOldColor)
'-- 反転モード
Call SetROP2(hdcMem0, R2_NOTXORPEN)
'-- 値に応じたバーの塗りつぶし
hPen = GetStockObject(NULL_PEN)
hOldPen = SelectObject(hdcMem0, hPen)
hBrush = CreateSolidBrush(clrForeColor)
hOldBrush = SelectObject(hdcMem0, hBrush)
Call Rectangle(hdcMem0, rc.Left, rc.Top, rc.Left + _
Fix((rc.Right - rc.Left) * curVal / 100), _
rc.Bottom)
Call SelectObject(hdcMem0, hOldBrush)
Call DeleteObject(hBrush)
Call SelectObject(hdcMem0, hOldPen)
'-- 枠線の描画
Call SetROP2(hdcMem0, R2_COPYPEN)
hPen = GetStockObject(BLACK_PEN)
hOldPen = SelectObject(hdcMem0, hPen)
hBrush = GetStockObject(NULL_BRUSH)
hOldBrush = SelectObject(hdcMem0, hBrush)
Call Rectangle(hdcMem0, rc.Left, rc.Top, _
rc.Right, rc.Bottom)
Call BitBlt(hdcMem, rcItem.Left, rcItem.Top, _
rcItem.Right - rcItem.Left, _
rcItem.Bottom - rcItem.Top, _
hdcMem0, 0, 0, vbSrcCopy)
Call SelectObject(hdcMem0, hOldBrush)
Call SelectObject(hdcMem0, hOldPen)
Call SelectObject(hdcMem0, hOldBmpMem0)
Call DeleteObject(hBmpMem0)
Call DeleteDC(hdcMem0)
Next
Next
Call BitBlt(hdc, rcLV.Left, 16, rcLV.Right - rcLV.Left, _
rcLV.Bottom - rcLV.Top, hdcMem, 0, 16, vbSrcCopy)
Call SelectObject(hdcMem, hOldBmpMem)
Call DeleteObject(hBmpMem)
Call DeleteDC(hdcMem)
Call EndPaint(hwnd, ps)
fNotPaint = False
WindowProc = 0
Exit Function
Case WM_ERASEBKGND
WindowProc = 1
Exit Function
End Select
WindowProc = CallWindowProc(lpProcOrg, hwnd, uMsg, wParam, lParam)
End Function
'// 標準モジュールの宣言部に追加する。
Private Const WM_PAINT = &HF
Private Const WM_ERASEBKGND = &H14
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
Private Type PAINTSTRUCT
hdc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved As Byte
End Type
Private Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal dwRop As Long) As Long
>無断転載なら、マズイんとちゃいまっか？
>リンク貼ってもらってるんで必要なかったかと。
確かに(;--) 配慮に欠けてました。
事後報告になってしまうけどサイトさんのほうには謝罪メールを入れておきます。
ますおさん ヒントをありがとうございました。いろいろサイト巡りをして得た知識とあわせて、描画のコツがわかった気がします。これから試行錯誤して完成させたいと思います。