Sub RecPlaySave()
' Total Recorder (Developer Edition) Automation client sample:
'  recording 10 sec from sound board with telephone quality,
'  playing,
'  saving,
'  restore all settings and close TR.

Dim TR_Appl      As Object
Dim TR_Doc       As Object
Dim TR_RcP_old   As Object
Dim TR_RcP_new   As Object
Dim TR_Fmt       As Object
Dim MessMode_old As Boolean
Dim StartTime    As Date
Dim SaveFileName As Variant
Dim ErrMess      As String
Dim iTmp         As Integer

ErrMess = ""
Range("Status").ClearContents
Range("Position").ClearContents
Set TR_Appl = CreateObject("TotalRecorder.Application")

' Check is TR not busy

If TR_Appl.AutoJob Then
    iTmp = MsgBox("Total Recorder is busy - it is in AutoJob mode", _
        vbOKOnly, "RecPlaySave: error")
    Exit Sub
End If

If TR_Appl.Recording Then
    iTmp = MsgBox("Total Recorder is busy - it is recording now", _
        vbOKOnly, "RecPlaySave: error")
    Exit Sub
End If

If TR_Appl.ModalDialog Then
    iTmp = MsgBox("Total Recorder is busy - modal dialog is active", _
        vbOKOnly, "RecPlaySave: error")
    Exit Sub
End If

Set TR_Doc = TR_Appl.ActiveDocument
If Not TR_Doc.Saved Then
    iTmp = MsgBox("Total Recorder is busy - current document is not saved", _
        vbOKOnly, "RecPlaySave: error")
    Exit Sub
End If
TR_Doc.Close

' Set recording parameters

Set TR_RcP_old = TR_Appl.RecordingParameters
If TypeName(TR_RcP_old) = "Nothing" Then GoTo RestoreAll ' error
Set TR_RcP_new = TR_Appl.RecordingParameters
TR_RcP_new.Source = 1 ' Board
TR_RcP_new.UseMixer = True ' Use current mixer settings
Set TR_Fmt = TR_RcP_new.Format
TR_Fmt.Clear
TR_Fmt.FormatTag = 1 ' PCM
TR_Fmt.SamplesPerSec = 11025
TR_Fmt.BitsPerSample = 8
TR_Fmt.Channels = 1 ' Mono
TR_Fmt.Validate
If Not TR_Fmt.Valid Then
    iTmp = MsgBox("Unable to use Telephone Quality format", _
        vbOKOnly, "RecPlaySave: error")
    Exit Sub
End If
TR_RcP_new.Format = TR_Fmt
TR_Appl.RecordingParameters = TR_RcP_new
MessMode_old = TR_Appl.MessageMode
TR_Appl.MessageMode = True ' intercept of TR messages

ErrMess = TR_Appl.LastErrorMessage
If ErrMess <> "" Then GoTo RestoreAll ' error

' Recording

TR_Appl.Recording = True
If Not TR_Appl.Recording Then GoTo RestoreAll
StartTime = Time
Do While Time < StartTime + TimeValue("0:00:10")
    Range("Status").Value = TR_Appl.StatusMessage(0)
    Range("Position").Value = TR_Appl.Position
    Application.Wait (Time + TimeValue("0:00:01"))
    If Not TR_Appl.Recording Then GoTo RestoreAll ' error
Loop
TR_Appl.Recording = False

ErrMess = TR_Appl.LastErrorMessage
If ErrMess <> "" Then GoTo RestoreAll ' error

' Playing

TR_Appl.Position = 0
TR_Appl.Playing = True
Do While TR_Appl.Playing
    Range("Status").Value = TR_Appl.StatusMessage(0)
    Range("Position").Value = TR_Appl.Position
    Application.Wait (Time + TimeValue("0:00:01"))
Loop

Range("Status").Value = TR_Appl.StatusMessage(0)
Range("Position").Value = TR_Appl.Position
ErrMess = TR_Appl.LastErrorMessage
If ErrMess <> "" Then GoTo RestoreAll ' error

' Saving

SaveFileName = Environ("temp")
SaveFileName = Application.GetSaveAsFilename(SaveFileName + "\TestTR.wav", _
    "Sound files (*.wav),*.wav")
If SaveFileName = False Then GoTo RestoreAll ' Cancel button was pressed

TR_Doc.SaveAs (SaveFileName)

' Restore settings and close file

RestoreAll:
Range("Status").ClearContents
Range("Position").ClearContents
Do
    If ErrMess = "" Then ErrMess = TR_Appl.LastErrorMessage
    If ErrMess = "" Then Exit Do
    iTmp = MsgBox(ErrMess, vbOKOnly, "RecPlaySave: TR message")
    ErrMess = ""
Loop While True
TR_Appl.MessageMode = MessMode_old
TR_Appl.RecordingParameters = TR_RcP_old
TR_Doc.Close (False)
End Sub
