Hola, ayuda con DeleteObject del HDC

[xmbeat]

bueno, lo que pasa es que tengo en un procedimiento el repintado del PRINTWINDOW a un HDC de un control Picture de un formulario, el cual se muestra justo abajo del los Menu que tengo, el codigo  que tengo es este:

Código: [Seleccionar]

Private Sub ChkMenu_MouseOver(Index As Integer)
 
   
    Dim DC As Long, hDCMemory As Long, hBmp As Long
    If Index = ChkMenu.UBound Then Exit Sub
    With FrmPopUp
    .Move Me.Left + ChkMenu(Index).Left * Screen.TwipsPerPixelX, _
        Me.Top + (ChkMenu(Index).Top + ChkMenu(Index).Height) * Screen.TwipsPerPixelY
   
   
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, PicArray(Index).Width, PicArray(Index).Height)
    Call SelectObject(hDCMemory, hBmp)
       
    PrintWindow PicArray(Index).hwnd, hDCMemory, 0
    SetStretchBltMode .Picture1.hdc, vbPaletteModeNone
    StretchBlt .Picture1.hdc, 0, 0, .Picture1.ScaleWidth, .Picture1.ScaleHeight, _
    hDCMemory, 0, 0, PicArray(Index).Width, PicArray(Index).Height, vbSrcCopy
   
    Select Case Index
    Case 0
        .Label1.Caption = "Descricion del Menu"
        .Label2.Caption = "Menu Tip:"
    Case 1
    Case 2
    '....
    End Select
    Mi = Index
    .Visible = True
    SetWindowPos .hwnd, -1, 0, 0, 0, 0, 3
    .Picture1.Refresh
    End With
    DeleteDC DC
    DeleteDC hDCMemory
    DeleteObject hBmp
End Sub
aqui la captura:



pero lo que pasa despues que lo ejecuto en varias veces, el sistema se sobrecarga y me empieza a fallar el VBasic y al momento de querer ejecutar otra vez me aparece: "Memory Stack" o algo asi. y me hizo recordar lo que un frances que llego al foro hablando de esto. pero no supe como arreglarlo. me ayudan, estoy casi seguro que es en ese procedimiento porque es el unico que uso los HDC

[LeandroA]

Hola yo no estoy seguro de que sea por eso, a mi nunca me produjo incremento en la memoria, pero bien según dicen los que saben y la msdn hay que hacerlo asi. despues contames si era por eso el problema.

Private Sub ChkMenu_MouseOver(Index As Integer)
 
   
    Dim DC As Long, hDCMemory As Long, hBmp As Long
    Dim OldhBmp As Long
    If Index = ChkMenu.UBound Then Exit Sub
    With FrmPopUp
    .Move Me.Left + ChkMenu(Index).Left * Screen.TwipsPerPixelX, _
        Me.Top + (ChkMenu(Index).Top + ChkMenu(Index).Height) * Screen.TwipsPerPixelY
   
   
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, PicArray(Index).Width, PicArray(Index).Height)
    OldhBmp = SelectObject(hDCMemory, hBmp)
       
    PrintWindow PicArray(Index).hWnd, hDCMemory, 0
    SetStretchBltMode .Picture1.hDC, vbPaletteModeNone
    StretchBlt .Picture1.hDC, 0, 0, .Picture1.ScaleWidth, .Picture1.ScaleHeight, _
    hDCMemory, 0, 0, PicArray(Index).Width, PicArray(Index).Height, vbSrcCopy
   
    Select Case Index
    Case 0
        .Label1.Caption = "Descricion del Menu"
        .Label2.Caption = "Menu Tip:"
    Case 1
    Case 2
    '....
    End Select
    Mi = Index
    .Visible = True
    SetWindowPos .hWnd, -1, 0, 0, 0, 0, 3
    .Picture1.Refresh
    End With
    SelectObject hDCMemory, OldhBmp
    DeleteDC DC
    DeleteDC hDCMemory
    DeleteObject hBmp
End Sub

[xmbeat]

el incremento en memoria no es notorio o por lo menos a mi me consumia unos 15kb cada que se hacia el procedimiento.

[TheWatcher]

Hola Leandro y xmbeat,

Más correcciones deben hacerse aquí para hacer el código de Windows-compatible. DeleteDC () nunca debe ser usado para un DC que obtuvo con GetDC (). Usted debe usar ReleaseDC () en su lugar:

Private Sub ChkMenu_MouseOver(Index As Integer)
 
   
    Dim DC As Long, hDCMemory As Long, hBmp As Long
    Dim OldhBmp As Long
    Dim hDeskWnd As Long
    If Index = ChkMenu.UBound Then Exit Sub
    With FrmPopUp
    .Move Me.Left + ChkMenu(Index).Left * Screen.TwipsPerPixelX, _
        Me.Top + (ChkMenu(Index).Top + ChkMenu(Index).Height) * Screen.TwipsPerPixelY
   
    hDeskWnd = GetDesktopWindow()
    DC = GetDC(hDeskWnd)
    DC = GetDC(0)
    hDCMemory = CreateCompatibleDC(0)
    hBmp = CreateCompatibleBitmap(DC, PicArray(Index).Width, PicArray(Index).Height)
    OldhBmp = SelectObject(hDCMemory, hBmp)
       
    PrintWindow PicArray(Index).hWnd, hDCMemory, 0
    SetStretchBltMode .Picture1.hDC, vbPaletteModeNone
    StretchBlt .Picture1.hDC, 0, 0, .Picture1.ScaleWidth, .Picture1.ScaleHeight, _
    hDCMemory, 0, 0, PicArray(Index).Width, PicArray(Index).Height, vbSrcCopy
   
    Select Case Index
    Case 0
        .Label1.Caption = "Descricion del Menu"
        .Label2.Caption = "Menu Tip:"
    Case 1
    Case 2
    '....
    End Select
    Mi = Index
    .Visible = True
    SetWindowPos .hWnd, -1, 0, 0, 0, 0, 3
    .Picture1.Refresh
    End With
    SelectObject hDCMemory, OldhBmp
    DeleteDC DC
    ReleaseDC hDeskWnd, DC
    DeleteDC hDCMemory
    DeleteObject hBmp
End Sub

Espero que esto ayude. Si no, la causa de la pérdida de memoria no está en esta función.

Saludos,

Mike