sattaz
Messages postés
32
Date d'inscription
mardi 7 janvier 2003
Statut
Membre
Dernière intervention
24 novembre 2011
26 août 2011 à 09:07
Salut,
J'ai finalement réussi à adapter la class Cwmvfile afin d'utiliser une PictureBox comme source pour les images à enregistrer !!!
Il suffit de raffraichir la PictureBox par les images souhaitées puis d'appeler la fonction comme
ceci :
********** D'abord définir le profile de l'encodeur :
Dim g As New Guid(&H6E2A6955, &H81DF, &H4943, &HBA, &H50, &H68, &HA9, &H86, &HA7, &H8, &HF6) 'WMProfile_V80_56VideoOnly 6E2A6955-81DF-4943-BA50-68A986A708F6
********** Puis appeler la class Cwmvfile :
Dim MyRec As CwmvFile
********** Ensuite créer un bouton (Button1 dans ce cas) pour démarrer l'enregistrement et y placer ce code :
If MyRec Is Nothing Then
MyRec = New CwmvFile("c:\RepDuFichierDeSortie\video.wmv", g, 25, PictureBox1) 'FichierDeSortie, ProfileEncodeur, 25 images/sec, ObjetPictureBox
Button1.Text = "Stop"
Else
MyRec.Close()
MyRec = Nothing
Button1.Text = "Record Video"
End If
********** Voici la class modifiée :
Imports System.Diagnostics
Imports System.Drawing
Imports System.Drawing.Imaging
Imports System.Runtime.InteropServices
Imports WindowsMediaLib
Imports WindowsMediaLib.Defs
' Contains defs also found in DirectShowLib
Public Class CwmvFile
#Region "Member variables"
' Interface used to write to asf file
Private m_pWMWriter As IWMWriter
' Used to read and set the video properties
Private m_pInputProps As IWMInputMediaProps
Private m_iFrameRate As Integer
' # of Frames Per Second for video output
Private m_dwVideoInput As Integer
' Which channel of the asf writer to write to
Private m_dwCurrentVideoSample As Integer
' Count of current frame
Private m_msVideoTime As Long
' Timestamp of current frame
Private m_Init As Boolean
' Has init been run yet?
#End Region
#Region "APIs"
<DllImport("Kernel32.dll", EntryPoint:="RtlMoveMemory")> _
Private Shared Sub CopyMemory(ByVal Destination As IntPtr, ByVal Source As IntPtr, <MarshalAs(UnmanagedType.U4)> ByVal Length As Integer)
End Sub
#End Region
Dim MyTimer As New Timer
Dim MyPictureBox As PictureBox
''' <summary>
''' Create filename from specified profile using specified framerate
''' </summary>
''' File name to create
''' WM Profile to use for compression
''' Frames Per Second
Public Sub New(ByVal lpszFileName As String, ByRef guidProfileID As Guid, ByVal iFrameRate As Integer, ByRef PictureBox As PictureBox)
MyPictureBox = PictureBox
Dim guidInputType As Guid
Dim dwInputCount As Integer
Dim pWMProfileManager As IWMProfileManager = Nothing
Dim pWMProfile As IWMProfile = Nothing
' Initialize all member variables
m_iFrameRate = iFrameRate
m_dwVideoInput = -1
m_dwCurrentVideoSample = 0
m_msVideoTime = 0
m_pWMWriter = Nothing
m_pInputProps = Nothing
m_Init = False
Try
' Open the profile manager
WMUtils.WMCreateProfileManager(pWMProfileManager)
' Convert pWMProfileManager to a IWMProfileManager2
Dim pProfileManager2 As IWMProfileManager2 = DirectCast(pWMProfileManager, IWMProfileManager2)
' Specify the version number of the profiles to use
pProfileManager2.SetSystemProfileVersion(WMVersion.V8_0)
' Load the profile specified by the caller
pProfileManager2.LoadProfileByID(guidProfileID, pWMProfile)
' Create a writer. This is the interface we actually write with
WMUtils.WMCreateWriter(IntPtr.Zero, m_pWMWriter)
' Set the profile we got into the writer. This controls compression, video
' size, # of video channels, # of audio channels, etc
m_pWMWriter.SetProfile(pWMProfile)
' Find out how many inputs are in the current profile
m_pWMWriter.GetInputCount(dwInputCount)
' Assume we won't find any video pins
m_dwVideoInput = -1
' Find the first video input on the writer
For i As Integer = 0 To dwInputCount - 1
' Get the properties of channel #i
m_pWMWriter.GetInputProps(i, m_pInputProps)
' Read the type of the channel
m_pInputProps.[GetType](guidInputType)
' If it is video, we are done
If guidInputType = MediaType.Video Then
m_dwVideoInput = i
Exit For
End If
Next
' Didn't find a video channel
If m_dwVideoInput = -1 Then
Throw New Exception("Profile does not accept video input")
End If
' Specify the file name for the output
m_pWMWriter.SetOutputFilename(lpszFileName)
'Do
'Loop
Catch
Close()
Throw
Finally
' Release the locals
If pWMProfile IsNot Nothing Then
Marshal.ReleaseComObject(pWMProfile)
pWMProfile = Nothing
End If
If pWMProfileManager IsNot Nothing Then
Marshal.ReleaseComObject(pWMProfileManager)
pWMProfileManager = Nothing
End If
'Timer To Define Record Interval
MyTimer.Interval 40 '40 ms 25 images/sec
MyTimer.Enabled = True
AddHandler MyTimer.Tick, AddressOf OnTimerEvent
End Try
End Sub
''' <summary>
''' Destructor
''' </summary>
Protected Overrides Sub Finalize()
Try
Close()
Finally
MyBase.Finalize()
End Try
End Sub
''' <summary>
''' Close the output and release the variables
''' </summary>
Public Sub Close()
MyTimer.Enabled = False
If m_Init Then
'We are currently writing
If m_pWMWriter IsNot Nothing Then
' Close the file
Try
m_pWMWriter.EndWriting()
Catch
End Try
End If
m_Init = False
End If
If m_pInputProps IsNot Nothing Then
Marshal.ReleaseComObject(m_pInputProps)
m_pInputProps = Nothing
End If
If m_pWMWriter IsNot Nothing Then
Marshal.ReleaseComObject(m_pWMWriter)
m_pWMWriter = Nothing
End If
End Sub
''' <summary>
''' Add a frame to the output file
''' </summary>
''' Frame to add
Public Sub AppendNewFrame(ByVal hBitmap As Bitmap)
Dim hr As Integer = 0
Dim pSample As INSSBuffer = Nothing
Dim r As New Rectangle(0, 0, hBitmap.Width, hBitmap.Height)
Dim bmd As BitmapData
If Not m_Init Then
' Only call this for the first frame
Initialize(hBitmap)
End If
' Lock the bitmap, which gets us a pointer to the raw bitmap data
bmd = hBitmap.LockBits(r, ImageLockMode.[ReadOnly], hBitmap.PixelFormat)
Try
' Compute size of bitmap in bytes. Strides may be negative.
Dim iSize As Integer = Math.Abs(bmd.Stride * bmd.Height)
Dim ip As IntPtr
' Get a sample interface
m_pWMWriter.AllocateSample(iSize, pSample)
' Get the buffer from the sample interface. This is
' where we copy the bitmap data to
pSample.GetBuffer(ip)
' Copy the bitmap data into the sample buffer
LoadSample(bmd, ip, iSize)
' Write the sample to the output - Sometimes, for reasons I can't explain,
' writing a sample fails. However, writing the same sample again
' works. Go figure.
Dim iRetry As Integer = 0
'Do
Try
m_pWMWriter.WriteSample(m_dwVideoInput, 10000 * m_msVideoTime, SampleFlag.CleanPoint, pSample)
Exit Try
Catch e As COMException
If (System.Math.Max(System.Threading.Interlocked.Increment(iRetry), iRetry - 1) < 3) AndAlso (e.ErrorCode <> NSResults.E_INVALID_DATA) Then
'Continue Do
Else
Throw
End If
End Try
'Loop While True
Marshal.ThrowExceptionForHR(hr)
' update the time based on the framerate
m_msVideoTime = (System.Threading.Interlocked.Increment(m_dwCurrentVideoSample) * 1000) \ m_iFrameRate
Finally
' Release the locals
If pSample IsNot Nothing Then
Marshal.ReleaseComObject(pSample)
pSample = Nothing
End If
hBitmap.UnlockBits(bmd)
End Try
End Sub
''' <summary>
''' Read the properties of the first bitmap to finish initializing the writer.
''' </summary>
''' First bitmap
Private Sub Initialize(ByVal hBitmap As Bitmap)
Dim mt As New AMMediaType()
Dim videoInfo As New VideoInfoHeader()
' Create the VideoInfoHeader using info from the bitmap
videoInfo.BmiHeader.Size = Marshal.SizeOf(GetType(BitmapInfoHeader))
videoInfo.BmiHeader.Width = hBitmap.Width
videoInfo.BmiHeader.Height = hBitmap.Height
videoInfo.BmiHeader.Planes = 1
' compression thru clrimportant don't seem to be used. Init them anyway
videoInfo.BmiHeader.Compression = 0
videoInfo.BmiHeader.ImageSize = 0
videoInfo.BmiHeader.XPelsPerMeter = 0
videoInfo.BmiHeader.YPelsPerMeter = 0
videoInfo.BmiHeader.ClrUsed = 0
videoInfo.BmiHeader.ClrImportant = 0
Select Case hBitmap.PixelFormat
Case PixelFormat.Format32bppArgb
mt.subType = MediaSubType.RGB32
videoInfo.BmiHeader.BitCount = 32
Exit Select
Case PixelFormat.Format32bppRgb
mt.subType = MediaSubType.RGB32
videoInfo.BmiHeader.BitCount = 32
Exit Select
Case PixelFormat.Format24bppRgb
mt.subType = MediaSubType.RGB24
videoInfo.BmiHeader.BitCount = 24
Exit Select
Case PixelFormat.Format16bppRgb555
mt.subType = MediaSubType.RGB555
videoInfo.BmiHeader.BitCount = 16
Exit Select
Case Else
Throw New Exception("Unrecognized Pixelformat in bitmap")
End Select
videoInfo.SrcRect = New Rectangle(0, 0, hBitmap.Width, hBitmap.Height)
videoInfo.TargetRect = videoInfo.SrcRect
videoInfo.BmiHeader.ImageSize = hBitmap.Width * hBitmap.Height * (videoInfo.BmiHeader.BitCount / 8)
videoInfo.BitRate = videoInfo.BmiHeader.ImageSize * m_iFrameRate
videoInfo.BitErrorRate = 0
videoInfo.AvgTimePerFrame = 10000 * 1000 \ m_iFrameRate
mt.majorType = MediaType.Video
mt.fixedSizeSamples = True
mt.temporalCompression = False
mt.sampleSize = videoInfo.BmiHeader.ImageSize
mt.formatType = FormatType.VideoInfo
mt.unkPtr = IntPtr.Zero
mt.formatSize = Marshal.SizeOf(GetType(VideoInfoHeader))
' Lock the videoInfo structure, and put the pointer
' into the mediatype structure
Dim gHan As GCHandle = GCHandle.Alloc(videoInfo, GCHandleType.Pinned)
Try
' Set the inputprops using the structures
mt.formatPtr = gHan.AddrOfPinnedObject()
m_pInputProps.SetMediaType(mt)
Finally
gHan.Free()
mt.formatPtr = IntPtr.Zero
End Try
' Now take the inputprops, and set them on the file writer
m_pWMWriter.SetInputProps(m_dwVideoInput, m_pInputProps)
' Done with config, prepare to write
m_pWMWriter.BeginWriting()
m_Init = True
End Sub
''' <summary>
''' Copy the bitmap data to the sample buffer
''' </summary>
''' Source bytes
''' Point to copy the data to
''' How many bytes to copy
Private Sub LoadSample(ByVal bmd As BitmapData, ByVal ip As IntPtr, ByVal iSize As Integer)
' If the bitmap is rightside up
If bmd.Stride < 0 Then
CopyMemory(ip, bmd.Scan0, iSize)
Else
' Copy it line by line from bottom to top
Dim ip2 As IntPtr = CType(ip.ToInt32() + iSize - bmd.Stride, IntPtr)
For x As Integer = 0 To bmd.Height - 1
CopyMemory(ip2, CType(bmd.Scan0.ToInt32() + (bmd.Stride * x), IntPtr), bmd.Stride)
ip2 = CType(ip2.ToInt32() - bmd.Stride, IntPtr)
Next
End If
End Sub
Private Sub OnTimerEvent()
On Error GoTo Skip
Dim b As New Bitmap(MyPictureBox.Image)
AppendNewFrame(b)
b.Dispose()
Skip:
End Sub
End Class
@++
Sattaz