ltmmConvertCtrl.WMProfile Example for Visual Basic

'**********************************************************************
'* The demo converts any video file to WMV file with custom profile   *
'* The demo adds 1 audio stream and 5 video streams that differ in    *
'* bitrate, this example will show how to use mutual exclusion object *
'**********************************************************************

Private m_bEnableButtons As Boolean
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) 

Const CODEC_AUDIO_MSAUDIO = 353    ' Microsoft WMAudio
Const CODEC_VIDEO_WMV1 = 827739479 ' FOURCC( 'W', 'M', 'V', '1' ) 

Const MEDIATYPE_Audio = "{73647561-0000-0010-8000-00AA00389B71}"
Const MEDIATYPE_Video = "{73646976-0000-0010-8000-00AA00389B71}"
Const FORMAT_WaveFormatEx = "{05589f81-c356-11ce-bf01-00aa0055595a}"
Const FORMAT_VideoInfo = "{05589f80-c356-11ce-bf01-00aa0055595a}"

Private Type waveformatex ' 18 bytes
    wFormatTag As Integer
    nChannels As Integer
    nSamplesPerSec As Long
    nAvgBytesPerSec As Long
    nBlockAlign As Integer
    wBitsPerSample As Integer
    cbSize As Integer
End Type

Private Type BITMAPINFOHEADER '40 bytes
        biSize As Long
        biWidth As Long
        biHeight As Long
        biPlanes As Integer
        biBitCount As Integer
        biCompression As Long
        biSizeImage As Long
        biXPelsPerMeter As Long
        biYPelsPerMeter As Long
        biClrUsed As Long
        biClrImportant As Long
End Type

Private Type RECT    ' 16 bytes
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type REFERENCE_TIME  ' 8 bytes
    lowpart As Long
    highpart As Long
End Type

Private Type VIDEOINFOHEADER ' 88 bytes
    rcSource As RECT
    rcTarget As RECT
    dwBitRate As Long
    dwBitErrorRate As Long
    AvgTimePerFrame As REFERENCE_TIME
    bmiHeader As BITMAPINFOHEADER
End Type

Private Sub CopyWaveFormatEx(wfex As waveformatex, wfexarr() As Byte) 
    CopyMemory wfex, wfexarr(0), 18
End Sub

Private Sub CopyVideoInfoHeader(vih As VIDEOINFOHEADER, viharr() As Byte) 
    CopyMemory vih, viharr(0), 88
End Sub

Private Sub EnableButtons()
    Dim f As Boolean
    Dim fname As String
    Dim b As Boolean

    ' avoid reentrancy. 
    If (Not m_bEnableButtons) Then
        m_bEnableButtons = True
        f = ltmmConvertCtrl1.HasDialog (ltmmConvert_Dlg_Source) 
        cmdSourceProps.Enabled = f
        b = False
        fname = txtSource.Text
        If (Len(fname) > 0) Then
            fname = txtTarget.Text
            If (Len(fname) > 0) Then
                b = True
            End If
        End If
        cmdConvert.Enabled = b
        m_bEnableButtons = False
    End If
End Sub

Private Sub cmbTargetFormat_Change()
    ltmmConvertCtrl1.TargetFormat = cmbTargetFormat.ItemData(cmbTargetFormat.ListIndex) 
#If WMSupport <> 1 Then
    If ltmmConvertCtrl1.TargetFormat = ltmmConvert_TargetFormat_Asf Then
        MsgBox "WMV format unavailable. Please see the documentation for instructions on enabling Windows Media formats"
    End If
#End If
End Sub

Private Sub cmdAudioProcessors_Click()
    ltmmConvertCtrl1.ShowDialog ltmmConvert_Dlg_AudioProcessors, frmMain.hWnd
End Sub

Private Sub cmdBrowseSource_Click()
    comdlg.CancelError = True
    comdlg.Filter = "Video Files (*.avi; *.qt; *.mov; *.mpg; *.mpeg; *.m1v)|*.avi; *.qt; *.mov; *.mpg; *.mpeg; *.m1v|Audio files (*.wav; *.mpa; *.mp2; *.mp3; *.au; *.aif; *.aiff; *.snd)|*.wav; *.mpa; *.mp2; *.mp3; *.au; *.aif; *.aiff; *.snd|WMT Files (*.wma; *.wmv)|*.wma; *.wmv|All Files (*.*)|*.*;"
    comdlg.DefaultExt = "avi"
    comdlg.Flags = cdlOFNFileMustExist + cdlOFNReadOnly + cdlOFNPathMustExist
    On Error GoTo CancelErr
    comdlg.ShowOpen
    txtSource.Text = comdlg.FileName
    Exit Sub
CancelErr: 
    Err.Clear
End Sub

Private Sub cmdBrowseTarget_Click()
    comdlg.CancelError = True
    comdlg.Filter = "WMT Files (*.wma; *.wmv)|*.wma; *.wmv|All Files (*.*)|*.*;"
    comdlg.DefaultExt = "avi"
    comdlg.Flags = cdlOFNOverwritePrompt + cdlOFNPathMustExist + cdlOFNCreatePrompt
    On Error GoTo CancelErr
    comdlg.ShowSave
    txtTarget.Text = comdlg.FileName
    Exit Sub
CancelErr: 
    Err.Clear
End Sub

Private Sub cmdConvert_Click()
    Set frmConvert.ltmmConvertCtrl1 = ltmmConvertCtrl1
    On Error Resume Next
    SetSourceFile
    SetTargetFile
    frmConvert.Show 1, Me
    SetEmptyTargetFile
End Sub

Private Sub cmdExit_Click()
    Unload Me
End Sub

Private Sub cmdSourceProps_Click()
    ltmmConvertCtrl1.ShowDialog ltmmConvert_Dlg_Source, frmMain.hWnd
End Sub

Private Sub cmdVideoProcessors_Click()
    ltmmConvertCtrl1.ShowDialog ltmmConvert_Dlg_VideoProcessors, frmMain.hWnd
End Sub

Private Sub Form_Load()
    ' Add Windows Media support? 
'#If WMSupport = 1 Then
    ltmmConvertCtrl1.WMCertificate = LTMM_WMCreateCertificate(WMKey$)
'#End If
    
    ltmmConvertCtrl1.WMProfile = CreateCustomProfile
    
    cmbTargetFormat.AddItem ("WMV (Windows Media Codecs)") 
    cmbTargetFormat.ItemData(cmbTargetFormat.ListCount - 1) = ltmmConvert_TargetFormat_Asf
    cmbTargetFormat.AddItem ("WMV (Windows Media Codecs - LEAD Mux)") 
    cmbTargetFormat.ItemData(cmbTargetFormat.ListCount - 1) = ltmmConvert_TargetFormat_Asf_Compressor_Mux
    
    cmbTargetFormat.ListIndex = 1
    ltmmConvertCtrl1.TargetFormat = ltmmConvert_TargetFormat_Asf_Compressor_Mux
    
    cmdSourceProps.Enabled = ltmmConvertCtrl1.HasDialog (ltmmConvert_Dlg_Source) 
    
    SetEmptyTargetFile
End Sub

Private Sub SetTargetFile()
    ltmmConvertCtrl1.TargetFile = txtTarget.Text
    EnableButtons
End Sub

Private Sub SetSourceFile()
    ltmmConvertCtrl1.SourceFile = txtSource.Text
    EnableButtons
End Sub

Private Sub txtSource_Change()
    EnableButtons
End Sub

Private Sub txtTarget_Change()
    EnableButtons
End Sub

Private Sub SetEmptyTargetFile()
    ltmmConvertCtrl1.TargetFile = ""
    EnableButtons
End Sub

 

Function CreateCustomProfile() As ltmmWMProfile
    Dim manager As ltmmWMProfileManager
    Dim profile As ltmmWMProfile
    ' create an empty profile
    Set manager = New ltmmWMProfileManager
    Set profile = manager.CreateEmptyProfile (ltmmWMT_VER_7_0) 
    profile.Name = "Custom Profile"
    profile.Description = "Custom Profile Description"
    
    ' add a single audio stream
    AddAudioStream manager, profile, 1, CODEC_AUDIO_MSAUDIO, 8000, 8000, 1, True
    
    ' add 5 video streams with different bit rates
    For i = 0 To 4
        AddVideoStream manager, profile, 2 + i, CODEC_VIDEO_WMV1, (1024 * 20) + i * 1024, 320, 240, 5 * (i + 1), 0, 8
    Next
    ' mark all the video streams for mutual exclusion
    AddMutexObject profile, 2, 5

    Set CreateCustomProfile = profile
End Function

 

Function AddVideoStream(manager As ltmmWMProfileManager, profile As ltmmWMProfile, streamnum As Integer, fourcc As Long, bitrate As Long, width As Long, height As Long, fps As Long, quality As Long, secperkey As Long) As Boolean
    Dim codecformat As ltmmWMStreamConfig
    Dim mediatype As ltmmMediaType
    Dim vih As VIDEOINFOHEADER
    Dim candidate As Boolean
    Dim candidatevih As VIDEOINFOHEADER
    Dim candidatemt As ltmmMediaType
    Dim mt As ltmmMediaType
    Dim candidatestream As ltmmWMStreamConfig
    Dim viharr(87) As Byte
    
    candidate = False
    
    ' get the number of video codecs
    codecs = manager.GetCodecInfoCount (MEDIATYPE_Video) 
    ' search for matching codec
    For codecindex = 0 To (codecs - 1) 
        txtInfo.Text = txtInfo.Text + manager.GetCodecName (MEDIATYPE_Video, codecindex) 
        formats = manager.GetCodecFormatCount (MEDIATYPE_Video, codecindex) 
        For formatindex = 0 To (formats - 1) 
             txtInfo.Text = txtInfo.Text + manager.GetCodecFormatDesc (MEDIATYPE_Video, codecindex, formatindex) 
            Set codecformat = manager.GetCodecFormat (MEDIATYPE_Video, codecindex, formatindex) 
            Set mediatype = codecformat.GetMediaType ()
            If (UCase(mediatype.formattype) = UCase(FORMAT_VideoInfo)) Then
                CopyVideoInfoHeader vih, mediatype.Format
                If (vih.bmiHeader.biCompression = fourcc) Then
                    candidate = True
                    candidatevih = vih
                    Set candidatemt = mediatype
                    Set candidatestream = codecformat
                End If
            End If
        Next
    Next
    If candidate Then
        ' modify the selected codec to support this bitrate and size
        candidatevih.dwBitRate = bitrate
        candidatevih.rcSource.Right = width
        candidatevih.rcSource.Bottom = height
        candidatevih.rcTarget.Right = width
        candidatevih.rcTarget.Bottom = height
        candidatevih.bmiHeader.biWidth = width
        candidatevih.bmiHeader.biHeight = height
    
        candidatevih.AvgTimePerFrame.lowpart = CLng((10000000# / fps) Mod &H10000) 
        candidatevih.AvgTimePerFrame.highpart = CLng((10000000# / fps) / &H10000) 
        
        CopyMemory viharr(0), candidatevih, 88
        candidatemt.SetFormatData -1, viharr
        
        candidatestream.quality = quality
        candidatestream.MaxKeyFrameSpacing = secperkey
        candidatestream.StreamNumber = streamnum
        candidatestream.StreamName = "Video Stream"
        candidatestream.ConnectionName = "Video"
        candidatestream.Bitrate = bitrate
        candidatestream.SetMediaType candidatemt
        profile.AddStream candidatestream
        AddVideoStream = True
        
    Else
        AddVideoStream = False
    End If

End Function

 

Function AddAudioStream(manager As ltmmWMProfileManager, profile As ltmmWMProfile, streamnum As Integer, formattag As Integer, prefbitrate As Long, samplespersec As Long, channels As Integer, withvideo As Boolean) As Boolean
    Dim codecformat As ltmmWMStreamConfig
    Dim mediatype As ltmmMediaType
    Dim wfex As waveformatex
    Dim candidate As Boolean
    Dim candidatewfex As waveformatex
    Dim candidatemt As ltmmMediaType
    Dim mt As ltmmMediaType
    Dim stream As ltmmWMStreamConfig
    
    candidate = False
    
    ' get the number of audio codecs
    codecs = manager.GetCodecInfoCount (MEDIATYPE_Audio) 
    ' search for matching codec
    For codecindex = 0 To (codecs - 1) 
        formats = manager.GetCodecFormatCount (MEDIATYPE_Audio, codecindex) 
        For formatindex = 0 To (formats - 1) 
            Set codecformat = manager.GetCodecFormat (MEDIATYPE_Audio, codecindex, formatindex) 
            Set mediatype = codecformat.GetMediaType ()
            If (UCase(mediatype.formattype) = UCase(FORMAT_WaveFormatEx)) Then
                CopyWaveFormatEx wfex, mediatype.Format
                diff = (wfex.nAvgBytesPerSec * 8 - prefbitrate) 
                If (diff < 250 And diff > -250 And wfex.nSamplesPerSec = samplespersec And wfex.nChannels = channels And wfex.wFormatTag = formattag) Then
                    If candidate Then
                        If withvideo Then
                           '
                           ' For audio/video configurations, we want to
                           ' find the smaller blockalign. In this case, 
                           ' the blockalign is larger, so we want to
                           ' use the old format. 
                            If (wfex.nBlockAlign <= candidatewfex.nBlockAlign) Then
                                candidatewfex = wfex
                                Set candidatemt = mediatype
                            End If
                        
                        Else
                            If (wfex.nBlockAlign >= candidatewfex.nBlockAlign) Then
                                candidatewfex = wfex
                                Set candidatemt = mediatype
                            End If
                        End If
                    Else
                        candidate = True
                        candidatewfex = wfex
                        Set candidatemt = mediatype
                    End If
                End If
            End If
        Next
    Next
    If candidate Then
        ' modify the selected codec to support this bitrate and format
        Set mt = New ltmmMediaType
        mt.Type = MEDIATYPE_Audio
        mt.subtype = "{" & String(8 - Len(Hex(formattag)), "0") & Hex(formattag) & "-0000-0010-8000-00AA00389B71}"
        mt.FixedSizeSamples = True
        mt.TemporalCompression = False
        mt.SampleSize = candidatewfex.nBlockAlign
        mt.formattype = FORMAT_WaveFormatEx
        mt.SetFormatData -1, candidatemt.Format
        Set stream = profile.CreateNewStream (MEDIATYPE_Audio) 
        stream.StreamNumber = streamnum
        stream.StreamName = "Audio Stream"
        stream.ConnectionName = "Audio"
        stream.Bitrate = candidatewfex.nAvgBytesPerSec * 8
        stream.SetMediaType mt
        profile.AddStream stream
        AddAudioStream = True
        
    Else
        AddAudioStream = False
    End If
    
    profile.ReconfigStream stream
End Function

 

Function AddMutexObject(profile As ltmmWMProfile, basestream As Integer, streamcount As Integer) As Boolean

    Dim excl As ltmmWMMutualExclusion

    ' create an exclusion object
    Set excl = profile.CreateNewMutualExclusion ()

    ' indicate that the streams differ by bit rate
    ' see CLSID_WMMUTEX_Bitrate in the WMSDK
    excl.Type = "{D6E22A01-35DA-11D1-9034-00A0C90349BE}"

    ' mark all the streams for mutual exclusion
    For i = 0 To (streamcount - 1) 
        excl.AddStream basestream + i
    Next

    ' assign the exclusion object to the profile
    profile.AddMutualExclusion excl
    AddMutexObject = True
End Function