buenas, he estado haciendo esta función pero por algún motivo que desconozco incrementa la memoria cada vez que la llamo, creo estar haciendo todo bien ya que descargo todo lo que creo. pero bien no doy con la solución al problema.
depurandola e visto que se encuentra en la llamada a la api AVIStreamGetFrameOpen esta en teoría se descarga con AVIStreamGetFrameClose pero la muy perra me deja unos 4 a 8 kb por llamada en la memoria del proceso.
La función lo que hace es obtener un imagen tipo vista previa de un video .AVI
Option Explicit
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function DrawDibDraw Lib "msvfw32.dll" (ByVal hdd As Long, ByVal hdc As Long, ByVal xDst As Long, ByVal yDst As Long, ByVal dxDst As Long, ByVal dyDst As Long, ByRef lpbi As Long, ByRef lpBits As Any, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dxSrc As Long, ByVal dySrc As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawDibOpen Lib "msvfw32.dll" () As Long
Private Declare Function DrawDibClose Lib "msvfw32.dll" (ByVal hdd As Long) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hdc As Long, ByRef lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function OleTranslateColor Lib "olepro32.dll" (ByVal OLE_COLOR As Long, ByVal hPalette As Long, pccolorref As Long) As Long
Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Sub AVIFileInit Lib "avifil32.dll" ()
Private Declare Sub AVIFileExit Lib "avifil32.dll" ()
Private Declare Function AVIStreamGetFrameOpen Lib "avifil32.dll" (ByVal pAVIStream As Long, ByRef BIH As Any) As Long
Private Declare Function AVIStreamGetFrameClose Lib "avifil32.dll" (ByVal pGetFrameObj As Long) As Long
Private Declare Function AVIStreamRelease Lib "avifil32.dll" (ByVal pavi As Long) As Long
Private Declare Function AVIStreamGetFrame Lib "avifil32.dll" (ByVal pGetFrameObj As Long, ByVal lPos As Long) As Long
Private Declare Function AVIStreamOpenFromFile Lib "avifil32.dll" Alias "AVIStreamOpenFromFileA" (ppavi As Any, ByVal szFile As String, ByVal fccType As Long, ByVal lParam As Long, ByVal mode As Long, pclsidHandler As Any) As Long
Private Declare Function AVIStreamReadFormat Lib "avifil32.dll" (pavi As Any, ByVal lPos As Long, lpFormat As Any, ByRef lpcbFormat As Long) As Long
Private Declare Function AVIStreamStart Lib "avifil32.dll" (ByVal pavi As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
hBmp As Long
hPal As Long
Reserved As Long
End Type
Private Type Size
cx As Long
cy As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const STREAM_TYPE_VIDEO = &H73646976
Private Const OF_READ = &H0
Private Const OF_SHARE_EXCLUSIVE = &H10
Private Sub Command1_Click()
Me.Picture = GetAviPreview(App.Path & "\Video.avi", 128, 128, vbWhite)
End Sub
Private Function GetAviPreview(FileName As String, ByVal Width As Long, ByVal Height As Long, Optional BackColor As OLE_COLOR = -1) As StdPicture
Dim hDCMemory As Long, hBmp As Long, hBmpPrev As Long, hBrush As Long, Rec As RECT, lColor As Long
Dim Pic As PicBmp, IPic As IPicture, IID_IDispatch As GUID
Dim PLeft As Long, PTop As Long, ReqWidth As Long, ReqHeight As Long
Dim HScale As Double, VScale As Double, MyScale As Double
Dim bBIH() As Byte
Dim pAVIStream As Long
Dim pGetFrameObj As Long
Dim hDrawDib As Long
Dim lSize As Long
Dim FrameSize As Size
Dim pDIB As Long
Dim lDC As Long
Dim FirstFrame As Long
Call AVIFileInit
If AVIStreamOpenFromFile(pAVIStream, FileName, STREAM_TYPE_VIDEO, 0, OF_READ Or OF_SHARE_EXCLUSIVE, ByVal 0&) = 0 Then
pGetFrameObj = AVIStreamGetFrameOpen(pAVIStream, ByVal 0&)
If pGetFrameObj <> 0 Then
If AVIStreamReadFormat(ByVal pAVIStream, 0, ByVal 0&, lSize) = 0 Then
ReDim bBIH(lSize - 1)
Call AVIStreamReadFormat(ByVal pAVIStream, 0, bBIH(0), lSize)
CopyMemory FrameSize, bBIH(4), 8
FirstFrame = AVIStreamStart(pAVIStream)
If FirstFrame <> -1 Then
pDIB = AVIStreamGetFrame(ByVal pGetFrameObj, FirstFrame)
If pDIB <> 0 Then
lDC = GetDC(0)
hDCMemory = CreateCompatibleDC(lDC)
hBmp = CreateCompatibleBitmap(lDC, Width, Height)
hBmpPrev = SelectObject(hDCMemory, hBmp)
If BackColor <> -1 Then
OleTranslateColor BackColor, 0, lColor
hBrush = CreateSolidBrush(lColor)
Rec.Right = Width: Rec.Bottom = Height
FillRect hDCMemory, Rec, hBrush
DeleteObject hBrush
End If
HScale = Width / FrameSize.cx
VScale = Height / FrameSize.cy
MyScale = IIf(VScale >= HScale, HScale, VScale)
ReqWidth = FrameSize.cx * MyScale
ReqHeight = FrameSize.cy * MyScale
PLeft = (Width - ReqWidth) / 2
PTop = (Height - ReqHeight) / 2
hDrawDib = DrawDibOpen
Call DrawDibDraw(hDrawDib, hDCMemory, PLeft, PTop, ReqWidth, ReqHeight, ByVal pDIB, ByVal 0&, 0, 0, -1, -1, 0)
DrawDibClose hDrawDib
hBmp = SelectObject(hDCMemory, hBmpPrev)
DeleteDC hDCMemory
DeleteDC lDC
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
With Pic
.Size = Len(Pic)
.Type = vbPicTypeBitmap
.hBmp = hBmp
End With
OleCreatePictureIndirect Pic, IID_IDispatch, 1, IPic
Set GetAviPreview = IPic
End If
End If
End If
Call AVIStreamGetFrameClose(pGetFrameObj)
End If
AVIStreamRelease pAVIStream
End If
Call AVIFileExit
End Function
