VBScreenCap : Capture d'écran facile en AVI v1.0.*

Table des procédures

1 - AssemblyInfo.vb

2 - frmVBScreenCap.vb
    2.1 - <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent
    2.2 - Private Sub cmdStart_Click
    2.3 - Private Sub cmdStop_Click
    2.4 - Private Sub frmVBScreenCap_Closing
    2.5 - Private Sub frmVBScreenCap_Load
    2.6 - Private Sub TerminerCapture
    2.7 - Protected Overloads Overrides Sub Dispose
    2.8 - Public Sub New

3 - Global.vb
    3.1 - Public Function bFichierExiste
    3.2 - Public Sub main



AssemblyInfo.vb


Imports System.Reflection

' Les informations générales relatives à un assembly dépendent de l'ensemble
' d'attributs suivant. Pour modifier les informations associées à un assembly,
'changez les valeurs de ces attributs

<Assembly: AssemblyTitle("VBScreenCap : Capture d'écran facile en AVI")> 
<Assembly: AssemblyDescription( _
    "VBScreenCap : Capture d'écran facile en vidéo AVI par patrice.dargenton@free.fr" & _
    "  Documentation : LisezMoi.htm")> 
<Assembly: AssemblyCompany("ORS Production")> 
<Assembly: AssemblyProduct("VBScreenCap")> 
<Assembly: AssemblyCopyright("ORS Production")> 
<Assembly: AssemblyTrademark("VBScreenCap")> 
<Assembly: AssemblyCulture("")> 

' Les informations de version pour un assembly se composent des quatre valeurs suivantes :

'	Version principale
'	Version secondaire
'	Révision
'	Numéro de build

' Vous pouvez spécifier toutes les valeurs ou indiquer des numéros de révision et de build par défaut
' en utilisant '*', comme ci-dessous 

<Assembly: AssemblyVersion("1.0.*")> 


frmVBScreenCap.vb


' VBScreenCap : Capture d'écran facile en vidéo AVI

' Par Patrice Dargenton
' patrice.dargenton@free.fr
' http://patrice.dargenton.free.fr/index.html
' www.vbfrance.com/listeauteur2.aspx?ID=1124
' Documentation : LisezMoi.htm
' Version 1.0 du 05/02/2005

' Créé d'après la source :
' Capture Activities on Screen in a Movie
' www.codeproject.com/vb/net/CaptureScreenAsVideo.asp
' Source elle-même en provenance de MSDN : Encoding a File
' http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmencode/htm/configuringanencodingsession.asp

Imports WMEncoderLib

Public Class frmVBScreenCap : Inherits Form

#Region " Windows Form Designer generated code "

    Public Sub New()
        MyBase.New()

        'This call is required by the Windows Form Designer.
        InitializeComponent()

        'Add any initialization after the InitializeComponent() call

    End Sub

    'Form overrides dispose to clean up the component list.
    Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean)
        If disposing Then
            If Not (components Is Nothing) Then
                components.Dispose()
            End If
        End If
        MyBase.Dispose(disposing)
    End Sub

    'Required by the Windows Form Designer
    Private components As System.ComponentModel.IContainer

    'NOTE: The following procedure is required by the Windows Form Designer
    'It can be modified using the Windows Form Designer.  
    'Do not modify it using the code editor.
    Friend WithEvents cmdStart As System.Windows.Forms.Button
    Friend WithEvents cmdStop As System.Windows.Forms.Button
    Friend WithEvents chbAudio As System.Windows.Forms.CheckBox
    Friend WithEvents ToolTip1 As System.Windows.Forms.ToolTip
    <System.Diagnostics.DebuggerStepThrough()> Private Sub InitializeComponent()
Me.components = New System.ComponentModel.Container
Dim resources As System.Resources.ResourceManager = New System.Resources.ResourceManager(GetType(frmVBScreenCap))
Me.cmdStart = New System.Windows.Forms.Button
Me.cmdStop = New System.Windows.Forms.Button
Me.chbAudio = New System.Windows.Forms.CheckBox
Me.ToolTip1 = New System.Windows.Forms.ToolTip(Me.components)
Me.SuspendLayout()
'
'cmdStart
'
Me.cmdStart.Location = New System.Drawing.Point(72, 16)
Me.cmdStart.Name = "cmdStart"
Me.cmdStart.Size = New System.Drawing.Size(40, 24)
Me.cmdStart.TabIndex = 2
Me.cmdStart.Text = "Start"
Me.ToolTip1.SetToolTip(Me.cmdStart, "Démarrer la capture vidéo")
'
'cmdStop
'
Me.cmdStop.Enabled = False
Me.cmdStop.Location = New System.Drawing.Point(120, 16)
Me.cmdStop.Name = "cmdStop"
Me.cmdStop.Size = New System.Drawing.Size(40, 24)
Me.cmdStop.TabIndex = 3
Me.cmdStop.Text = "Stop"
'
'chbAudio
'
Me.chbAudio.Location = New System.Drawing.Point(16, 16)
Me.chbAudio.Name = "chbAudio"
Me.chbAudio.Size = New System.Drawing.Size(56, 24)
Me.chbAudio.TabIndex = 4
Me.chbAudio.Text = "Audio"
Me.ToolTip1.SetToolTip(Me.chbAudio, "Capturer aussi l'audio")
'
'frmVBScreenCap
'
Me.AutoScaleBaseSize = New System.Drawing.Size(5, 13)
Me.ClientSize = New System.Drawing.Size(178, 53)
Me.Controls.Add(Me.chbAudio)
Me.Controls.Add(Me.cmdStop)
Me.Controls.Add(Me.cmdStart)
Me.FormBorderStyle = System.Windows.Forms.FormBorderStyle.FixedSingle
Me.Icon = CType(resources.GetObject("$this.Icon"), System.Drawing.Icon)
Me.MaximizeBox = False
Me.Name = "frmVBScreenCap"
Me.Text = "VBScreenCap"
Me.ResumeLayout(False)

    End Sub

#End Region

Dim m_bAudio As Boolean
Dim m_sFichierAVI$
Dim m_oEncoder As WMEncoder

Private Sub frmVBScreenCap_Load(ByVal sender As Object, ByVal e As EventArgs) _
    Handles MyBase.Load
    m_sFichierAVI = Application.StartupPath & "\VBScreenCap.avi"
End Sub

Private Sub cmdStart_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles cmdStart.Click

    ' Initialiser l'encodage vidéo et démarrer

    Me.cmdStart.Enabled = False
    Me.Cursor = Cursors.WaitCursor
    Try
        ' Create a WMEncoder object.
        m_oEncoder = New WMEncoder
    Catch
        Me.Cursor = Cursors.Default
        If MsgBoxResult.Cancel = MsgBox( _
            "'Windows Media Encoder 9 Series' n'est pas installé !" & vbLf & _
            "Cliquez sur OK pour afficher la page de téléchargement", _
            MsgBoxStyle.Critical Or MsgBoxStyle.OKCancel, sTitreMsg) Then _
                Application.Exit() : Exit Sub

        Const sURL$ = _
            "http://www.microsoft.com/downloads/details.aspx?FamilyID=5691ba02-e496-465a-bba9-b2f1182cdf24&displaylang=en"
        Dim p As New Process
        p.StartInfo = New ProcessStartInfo(sURL)
        p.Start()
        Application.Exit()
        Exit Sub
    End Try

    ' Retrieve the source group collection and add a source group. 
    Dim SrcGrp2 As IWMEncSourceGroup2
    Dim SrcGrpColl As IWMEncSourceGroupCollection
    SrcGrpColl = m_oEncoder.SourceGroupCollection
    SrcGrp2 = SrcGrpColl.Add("SG_1")

    ' Add a video and audio source to the source group.
    Dim SrcVid As IWMEncVideoSource2
    Dim SrcAud As IWMEncAudioSource
    SrcVid = SrcGrp2.AddSource(WMENC_SOURCE_TYPE.WMENC_VIDEO)

    If Me.chbAudio.CheckState = CheckState.Checked Then m_bAudio = True
    If m_bAudio Then SrcAud = SrcGrp2.AddSource(WMENC_SOURCE_TYPE.WMENC_AUDIO)

    ' Identify the source files to encode.
    SrcVid.SetInput("ScreenCap://ScreenCapture1")
    If m_bAudio Then SrcAud.SetInput("Device://Default_Audio_Device")

    ' Crop 2 pixels from each edge of the video image.
    SrcVid.CroppingBottomMargin = 2
    SrcVid.CroppingTopMargin = 2
    SrcVid.CroppingLeftMargin = 2
    SrcVid.CroppingRightMargin = 2
    'SrcVid.Height = 640 ' Ne marche pas !
    'SrcVid.Width = 480

    ' Create a WMEncProfile2 object.
    Dim Pro2 As WMEncProfile2
    Pro2 = New WMEncProfile2

    ' Provide a name and description.
    Pro2.ProfileName = "Profil de VBScreenCap"
    Pro2.ProfileDescription = "Un profil vidéo adapté à la capture d'écran en AVI."

    ' Specify video content.
    '16 Supports video content. 
    '17 Supports audio and video content. 
    Pro2.ContentType = 16
    If m_bAudio Then Pro2.ContentType = 17

    ' Specify constant bit rate (CBR) mode.
    Pro2.VBRMode(WMENC_SOURCE_TYPE.WMENC_VIDEO, 0) = _
        WMENC_PROFILE_VBR_MODE.WMENC_PVM_NONE

    ' Débit minimal pour avoir du 640x480 avec l'audio
    ' Add audiences for 1200000 Kbps.
    Pro2.AddAudience(1200000) ' 640x480 + audio en 192 Kbps
    'Pro2.AddAudience(5000000) ' pas mieux

    ' Verify profile settings immediately as they are set.
    Pro2.ValidateMode = True

    ' Validate the settings to make sure the profile has no errors.
    Pro2.Validate()

    SrcGrp2.Profile = Pro2

    ' Choose a profile from the collection.
    '  code retiré : la compression en temps réel ne dépasse jamais 320x240 !
    ' Résolution la plus élevée : 
    ' "Windows Media Video 8 for Local Area Network (384 Kbps)"

    ' Ajout d'une description et des attributs 
    ' Cela ne fonctionne pas avec les propriétés accessibles dans l'explorateur
    '  mais seulement dans les propriétés affichées par Windows Media Player

    ' Fill in the description object members.
    Dim Descr As IWMEncDisplayInfo
    Descr = m_oEncoder.DisplayInfo
    Descr.Author = "VBScreenCap"
    Descr.Copyright = "Patrice Dargenton - ORS Production"
    Descr.Description = "VBScreenCap : Capture d'écran facile en vidéo AVI"
    Descr.Rating = "*****"
    Descr.Title = "Capture d'écran"

    ' Je n'ai pas trouvé d'autres attributs possibles
    ' Add an attribute to the collection.
    'Dim Attr As IWMEncAttributes
    'Attr = m_oEncoder.Attributes
    'Attr.Add("URL", "http://patrice.dargenton.free.fr/index.html")
    m_oEncoder.Attributes.Add("URL", "http://patrice.dargenton.free.fr/index.html")

    ' Specify a file object in which to save encoded content.
    'Dim File As IWMEncFile
    'File = m_oEncoder.File
    'File.LocalFileName = m_sFichierAVI
    m_oEncoder.File.LocalFileName = m_sFichierAVI

    ' Start the encoding process.
    m_oEncoder.Start()

    Me.chbAudio.Enabled = False
    Me.cmdStop.Enabled = True
    Me.Cursor = Cursors.Default

End Sub

Private Sub cmdStop_Click(ByVal sender As Object, ByVal e As EventArgs) _
    Handles cmdStop.Click
    TerminerCapture() : Application.Exit()
End Sub

Private Sub frmVBScreenCap_Closing(ByVal sender As Object, _
    ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing
    TerminerCapture()
End Sub

Private Sub TerminerCapture()

    If m_oEncoder Is Nothing Then Exit Sub
    If Not m_oEncoder.RunState = WMENC_ENCODER_STATE.WMENC_ENCODER_RUNNING Then _
        Exit Sub

    m_oEncoder.Stop()

    If MsgBoxResult.Cancel = MsgBox( _
        "Le fichier " & m_sFichierAVI & vbLf & _
        "a été créé avec succès !" & vbLf & _
        "Cliquez sur OK pour le visionner", _
        MsgBoxStyle.Exclamation Or MsgBoxStyle.OKCancel, sTitreMsg) Then _
        Exit Sub

    ' Si on essaie de compresser la vidéo après coup, au lieu de le faire 
    '  en temps réel, cela ne change rien, on retombe en 320x200
    'http://msdn.microsoft.com/library/default.asp?url=/library/en-us/wmencode/htm/configuringanencodingsession.asp
    'CompresserVideo(m_bAudio)

    Dim p As New Process
    p.StartInfo = New ProcessStartInfo(m_sFichierAVI)
    p.Start()

End Sub

End Class


Global.vb


Module Global

Public Const sTitreMsg$ = "VBScreenCap"

Public Sub main()

    ' On peut démarrer l'application sur la feuille, ou bien sur la procédure 
    '  main() si on veut pouvoir détecter l'absence de la dll sans plantage

    If Not bFichierExiste(Application.StartupPath & _
        "\Interop.WMEncoderLib.dll", bPrompt:=True) Then Exit Sub

    'Dim oFrm As New frmVBScreenCap
    'oFrm.ShowDialog()
    ' Récupération de toutes les erreurs, par exemple fichier vidéo en lecture seule
    ' Pb : ne marche que dans l'ide !!!???
    Try
        Dim oFrm As New frmVBScreenCap
        oFrm.ShowDialog()
    Catch Ex As Exception
        MsgBox("Erreur : " & Ex.Message & Ex.Source, _
            MsgBoxStyle.Critical, sTitreMsg)
    Catch
        MsgBox("Erreur non managée !", MsgBoxStyle.Critical, sTitreMsg)
    End Try

End Sub

Public Function bFichierExiste(ByVal sFiltre$, _
    Optional ByVal bPrompt As Boolean = False) As Boolean

    ' Retourner True si un fichier correspondant au filtre sFiltre est trouvé
    bFichierExiste = IO.File.Exists(sFiltre)

    ' Avertir l'utilisateur si on le demande
    If Not bFichierExiste And bPrompt Then _
        MsgBox("Impossible de trouver le fichier :" & vbLf & sFiltre, _
            MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable")

End Function

End Module