リストビューの中にプログレスバーを表示するには？ (ID:84669)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文 > ちょっと長くなりますがソースを載せてみます。 無断転載なら、マズイんとちゃいまっか？ リンク貼ってもらってるんで必要なかったかと。 > カスタムドローではちらつきは抑えられないのでしょうか？ カスタムドローでその方法を見つけ出せなかっただけどす。 代替策として、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