VBA/GDIでUserFormに描画/Picture更新時のチラツキを防止するには (ID:142074)

名前

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

本文

半年ぶりに質問させていただきます。
昔WEBで調べて切り貼りして作った（写した？）コードですが、エクセルのUserFormに描画するのに、Windowが隠れた時に消えないように、メモリ上のBitmapに描画してから、Bitmap2にコピーし、Picture型に変換してUserFormにセットしているのですが、チラツキが発生します。UserFormのDrawBufferの値を10倍すると良いという記事をみつけて試しましたが、Celeron2.4GHz,256MByteメモリ、オンボードグラフィック、WIN2Kというチープな環境のためか変わり映えしません。何か他に対処方法がありましたら御教示下さい。
コード抜粋を載せます。○一個描くのに、都度Pictureを更新するというコードです。
(前略）
Sub drawCircle(x As Long, y As Long)
    Dim hbr As Long
    Dim ret As Long
    Dim hOldBr As Long
    Dim hbmp2 As Long
    
    hdcForm = GetDC(hwndForm)
    If hdcForm = 0 Then Exit Sub
    hdc = CreateCompatibleDC(hdcForm)
    hdc2 = CreateCompatibleDC(hdcForm)
    hbmp2 = CreateCompatibleBitmap(hdcForm, rc.Right, rc.Bottom)
    hbmpOld = SelectObject(hdc, hbmp)   
    hbmpOld2 = SelectObject(hdc2, hbmp2)
    ReleaseDC hwndForm, hdcForm
    hbr = CreateSolidBrush(plotColor)
    hOldBr = SelectObject(hdc, hbr)
    Ellipse hdc, x - 3, y - 3, x + 3, y + 3
    SelectObject hdc, hOldBr
    DeleteObject hbr
    ret = BitBlt(hdc2, 0, 0, rc.Right, rc.Bottom, hdc, 0, 0, SRCCOPY)
    SelectObject hdc, hbmpOld
    SelectObject hdc2, hbmpOld2
    DeleteDC hdc
    DeleteDC hdc2
 
    Set pic = GetPictureObject(hbmp2)
    If pic Is Nothing Then DeleteObject hbmp2
    Set UserForm1.Picture = pic
End Sub

Private Function GetPictureObject(ByVal hbmp As Long) As Object
    Dim iid As GUID    
    Dim pd As PICTDESC
    If hbmp = 0 Then Exit Function
    With iid
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With pd
        .cbSizeofstruct = Len(pd)   
        .picType = PICTYPE_BITMAP   
        .hbitmap = hbmp            
    End With
    OleCreatePictureIndirect pd, iid, 1, GetPictureObject
End Function

←解決時は質問者本人がここをチェックしてください。

戻る