How can I make an application that can record the audio output of another application using VB.net?
I've extracted some parts of my old TextToSpeek program.
The MCI-recording works very well. The Windows Mixer is included in all versions. So you can record the output of all programs. I hope I have not forgotten anything. Just ask then.
Private ActMediaFolder As String
Private RecAlias As String
Private MciRS As String = Space(1024)
Private MciRL As Integer = 1024
Private MciLength As Integer
Private mciStopped As Boolean
Private IsRecorded As Boolean = False
Private Mp3Quality As Integer
Private axMpIsInPlayState As Boolean = False
Public Declare Function mciSendString Lib "winmm.dll" _
Alias "mciSendStringA" ( _
ByVal lpstrCommand As String, _
ByVal lpstrReturnString As String, _
ByVal uReturnLength As Long, _
ByVal hwndCallback As Long) As Long
#Region "MCI RECORDING"
Public Function MciOpen(ByVal sFile As String, ByVal sAlias As String) As Boolean
Try
mciSendString("close " & sAlias, 0, 0, 0)
' OPEN MCI:
If mciSendString("open " & Chr(34) & sFile & Chr(34) & _
" type waveaudio alias " & sAlias, 0, 0, 0) = 0 Then
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Function
Private Sub MciRecord()
'Dim bits As String = "16"
'Dim samples As String = "44100"
'Dim bytes As String = "176400"
'Dim c As String = "2"
Try
Dim CB As Long = 0
mciSendString("close " & RecAlias, 0, 0, 0)
mciSendString("open new type waveaudio alias " & RecAlias, MciRS, 128, 0)
mciSendString("SET MyRec TIME FORMAT MS", MciRS, MciRL, CB)
mciSendString("SET MyRec BITSPERSAMPLE 16", MciRS, MciRL, CB)
mciSendString("SET MyRec CHANNELS 2", MciRS, MciRL, CB)
mciSendString("SET MyRec SAMPLESPERSEC 44100", MciRS, MciRL, CB)
mciSendString("SET MyRec BYTESPERSEC 176400", MciRS, MciRL, CB)
mciSendString("record " & RecAlias, MciRS, MciRL, CB)
IsRecorded = True
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub MciStopRecord()
TimerRecTime.Stop()
Try
mciSendString("stop " & RecAlias, MciRS, MciRL, 0)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub MciPlayRecord()
Try
mciSendString("play " & RecAlias & " from 0", MciRS, MciRL, 0)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Private Sub MciSaveRecord(ByVal sfile As String)
Try
mciSendString("save " & RecAlias & " " & Chr(34) & sfile & Chr(34), MciRS, MciRL, 0)
mciSendString("close " & RecAlias, MciRS, MciRL, 0)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Public Function MciPlay(ByVal sfile As String, ByVal sAlias As String) As Boolean
Try
Dim sBuffer As String = Space(256)
MP3_Stop("MyAlias")
mciSendString("close MyAlias", 0, 0, 0)
mciSendString("open " & Chr(34) & sfile & Chr(34) & " ALIAS MyAlias", 0, 0, 0)
mciSendString("play MyAlias from 0", 0, 0, 0)
mciSendString("status MyAlias mode", sBuffer, Len(sBuffer), 0)
MsgBox(sBuffer)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Function
Public Sub MP3_Stop(ByVal sAlias As String)
Try
mciSendString("stop " & sAlias, 0, 0, 0)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
Public Function mciGetLength() As Integer
Try
Dim sBuffer As String = Space(256)
mciSendString("status MyAlias length", sBuffer, Len(sBuffer), 0)
mciGetLength = Val(sBuffer)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Function
Public Function mciCurPos() As Integer
Try
Dim sBuffer As String = Space(256)
mciSendString("status MyAlias position", sBuffer, Len(sBuffer), 0)
mciCurPos = Val(sBuffer)
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Function
Public Function mciGetStatus() As String
Try
Dim sBuffer As String = Space(256)
mciSendString("status MyAlias mode", sBuffer, Len(sBuffer), 0)
mciGetStatus = sBuffer
Catch ex As Exception
MsgBox(ex.Message)
End Try
Return "Error"
End Function
Private Sub TimerMCI_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles TimerMCI.Tick
Try
If InStr(mciGetStatus(), "stop") Then
mciStopped = True
MsgBox("STOP")
TimerMCI.Stop()
ElseIf InStr(mciGetStatus(), "Error") Then
mciStopped = True
MsgBox("ERROR")
TimerMCI.Stop()
Else
mciStopped = False
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
#End Region
Related
I am trying to save received sms from my modem to MySQL database, and I am using MySQL Workbench for my database.
Here's my functionalities:
1. Auto detect modem
2. Connect modem
3. Send Messages
4. Read Messages
5. Handles (SerialPort Data received)
Here's the Code:1. Auto Detect Modem
'Some Imports
Imports System.Management
Imports System.Threading
Imports System.Text.RegularExpressions
Imports MySql.Data.MySqlClient
Public Class Form1
Dim result() As String
Dim query As String
Dim rcvdata As String = ""
Private Sub Form1_Load(sender As System.Object, e As System.EventArgs) Handles MyBase.Load
Dim ports() As String
ports = Split(ModemsConnected(), "***")
For i As Integer = 0 To ports.Length - 2
ComboBox1.Items.Add(ports(i))
Next
End Sub
Public Function ModemsConnected() As String
Dim modems As String = ""
Try
Dim searcher As New ManagementObjectSearcher("root\CIMV2", "SELECT * FROM Win32_POTSModem")
For Each queryObj As ManagementObject In searcher.Get()
If queryObj("Status") = "OK" Then
modems = modems & (queryObj("AttachedTo") & " - " & queryObj("Description") & "***")
End If
Next
Catch err As ManagementException
MessageBox.Show("An error occurred while querying for WMI data: " & err.Message)
Return ""
End Try
Return modems
End Function
'Show Detected or Available modem
Private Sub ComboBox1_SelectedValueChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles ComboBox1.SelectedValueChanged
Label1.Text = Trim(Mid(ComboBox1.Text, 1, 5))
End Sub
2. Connect/Disconnect Modem
'button connect
Private Sub btnConnect_Click(sender As System.Object, e As System.EventArgs) Handles btnConnect.Click
Try
With SerialPort1
.PortName = Label1.Text
.BaudRate = 9600
.Parity = IO.Ports.Parity.None
.DataBits = 8
.StopBits = IO.Ports.StopBits.One
.Handshake = IO.Ports.Handshake.None
.RtsEnable = True
.ReceivedBytesThreshold = 1
.NewLine = vbCr
.ReadTimeout = 1000
.Open()
End With
If SerialPort1.IsOpen Then
Label3.Visible = True
btnDisconnect.Visible = True
Label3.Text = "Connected - Port " & Label1.Text & " is used"
Else
Label3.Text = "Got some Error, Check your connection with your Modem."
End If
Catch ex As Exception
MsgBox(ex.Message, MsgBoxStyle.Exclamation, "Text Messaging")
End Try
End Sub
'button Disconnect
Private Sub btnDisconnect_Click(sender As System.Object, e As System.EventArgs) Handles btnDisconnect.Click
Try
If SerialPort1.IsOpen Then
With SerialPort1
.Close()
.Dispose()
Label1.Visible = False
Label3.Visible = False
btnDisconnect.Visible = False
ListView1.Items.Clear()
End With
End If
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
3. Send Messages
Private Sub btnSend_Click(sender As System.Object, e As System.EventArgs) Handles btnSend.Click
Dim query As String
Try
Connection()
query = "INSERT INTO thesis.tblsentitems (PhoneNumber, message) VALUES('" & txtNumber.Text & "', '" & txtMessage.Text & "')"
sqlcmd = New MySqlCommand(query, conn)
sqlreader = sqlcmd.ExecuteReader
With SerialPort1
.Write("at" & vbCrLf)
Threading.Thread.Sleep(200)
.Write("at+cmgf=1" & vbCrLf)
Threading.Thread.Sleep(200)
.Write("at+cmgs=" & Chr(34) & txtNumber.Text & Chr(34) & vbCrLf)
.Write(txtMessage.Text & Chr(26))
Threading.Thread.Sleep(200)
End With
If rcvdata.ToString.Contains(">") Then
MsgBox("Message Succesfully Sent")
conn.Close()
Else
MsgBox("Got some error!")
End If
Catch ex As Exception
MsgBox(ex.Message, MsgBoxStyle.Exclamation, "Text Messaging")
End Try
End Sub
4. Read Messages
Private Sub btnReadsms_Click(sender As System.Object, e As System.EventArgs) Handles btnReadsms.Click
Try
With SerialPort1
.Write("AT" & vbCrLf)
Threading.Thread.Sleep(1000)
.Write("AT+CMGF=1" & vbCrLf)
Threading.Thread.Sleep(1000)
.Write("AT+CPMS=""SM""" & vbCrLf)
Threading.Thread.Sleep(1000)
.Write("AT+CMGL=""ALL""" & vbCrLf)
Threading.Thread.Sleep(1000)
'MsgBox(rcvdata.ToString)
readmsg()
End With
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
'Save Received message to ListView1
Private Sub readmsg()
Try
Dim lineoftext As String
Dim i As Integer
Dim arytextfile() As String
lineoftext = rcvdata.ToString
arytextfile = Split(lineoftext, "+CMGL", , CompareMethod.Text)
For i = 1 To UBound(arytextfile)
Dim input As String = arytextfile(i)
Dim pattern As String = "(:)|(,"")|("","")"
result = Regex.Split(input, pattern)
Dim concat() As String
With ListView1.Items.Add("null")
'for index
.SubItems.AddRange(New String() {result(2).ToString})
'for status
.SubItems.AddRange(New String() {result(4).ToString})
'for number
Dim my_string, position As String
my_string = result(6)
position = my_string.Length - 2
my_string = my_string.Remove(position, 2)
.SubItems.Add(my_string)
'for date and time
concat = New String() {result(8)}
.SubItems.AddRange(concat)
'for message
Dim lineoftexts As String
Dim arytextfiles() As String
lineoftexts = arytextfile(i)
arytextfiles = Split(lineoftexts, "+32", , CompareMethod.Text)
.SubItems.Add(arytextfiles(1))
End With
Next
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
5. Handles (SerialPort Data received)
Private Sub SerialPort1_datareceived(ByVal sender As Object, ByVal e As System.IO.Ports.SerialDataReceivedEventArgs) Handles SerialPort1.DataReceived
Dim datain As String = ""
Dim numbytes As Integer = SerialPort1.BytesToRead
For i As Integer = 1 To numbytes
datain &= Chr(SerialPort1.ReadChar)
Next
test(datain)
End Sub
Private Sub test(ByVal indata As String)
rcvdata &= indata
End Sub
Hope someone can Help, please... :/
below is my code for my project.
hope you can help me.
thanks in advance. :)
this is my sqlcontrol code
Imports System.Data
Imports System.Data.SqlClient
Public Class SQLControl
Public SQLCon As New SqlConnection With {.ConnectionString = "Server=xxx\SQLEXPRESS;Database=SQLTest;User=sa;Pwd=xxxx;"}
Public SQLCmd As SqlCommand 'allow us to fire query at the data base
Public SQLDA As SqlDataAdapter
Public SQLDataset As DataSet
Public dtable As New DataTable
Public bs As New BindingSource
'QUERY PARAMETERS
Public Params As New List(Of SqlParameter)
Public RecordCount As Integer
Public Exception As String
Public Function HasConnection() As Boolean
Try
SQLCon.Open()
SQLCon.Close()
Return True
Catch ex As Exception
MsgBox(ex.Message)
Return False
End Try
End Function
Public Sub ExecQuery(ByVal Query As String)
Try
SQLCon.Open()
'CREATE SQL COMMAND
SQLCmd = New SqlCommand(Query, SQLCon)
'LOAD PARAMETER INTO SQL COMMAND
Params.ForEach(Sub(x) SQLCmd.Parameters.Add(x))
'CLEAR PARAMETER LIST
Params.Clear()
'EXCUTE COMMAND FILL MY DATASET
SQLDataset = New DataSet
'EXCUTE COMMAND WIHTOUT ADAPTER
SQLDA = New SqlDataAdapter(SQLCmd)
RecordCount = SQLDA.Fill(SQLDataset)
SQLCon.Close()
Catch ex As Exception
Exception = ex.Message
End Try
If SQLCon.State = ConnectionState.Open Then SQLCon.Close()
End Sub
Public Sub RunQuery(ByVal Query As String)
Try
SQLCon.Open()
SQLCmd = New SqlCommand(Query, SQLCon)
'LOAD SQL RECORDS FOR DATAGRID
SQLDA = New SqlDataAdapter(SQLCmd)
SQLDataset = New DataSet
SQLDA.Fill(SQLDataset)
SQLCon.Close()
Catch ex As Exception
MsgBox(ex.Message)
If SQLCon.State = ConnectionState.Open Then
SQLCon.Close()
End If
End Try
End Sub
Public Sub AddMember(ByVal PC As String, ByVal IP As String, ByVal Name As String, ByVal Email As String, ByVal Department As String, ByVal Location As String,
ByVal Model As String, ByVal Specs As String, ByVal Dt As String, ByVal Asset As String, ByVal Rent As String)
Try
Dim strInsert As String = "INSERT INTO MEMBERS (pc,ip,name,email,department,location,model,specs,date,asset,rent) " & _
"VALUES (" & _
"'" & PC & "'," & _
"'" & IP & "'," & _
"'" & Name & "'," & _
"'" & Email & "'," & _
"'" & Department & "'," & _
"'" & Location & "'," & _
"'" & Model & "'," & _
"'" & Specs & "'," & _
"'" & Dt & "'," & _
"'" & Asset & "'," & _
"'" & Rent & "')"
MsgBox(strInsert)
SQLCon.Open()
SQLCmd = New SqlCommand(strInsert, SQLCon)
SQLCmd.ExecuteNonQuery()
SQLCon.Close()
Catch ex As Exception
MsgBox(ex.Message)
End Try
End Sub
End Class
And this is my form code:
Public Class Form1
Private SQL As New SQLControl
Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
'EXECUTE QUERY AND POPULATE GRID
SQL.ExecQuery("SELECT * FROM members")
LoadGrid()
'DISABLE SAVE BUTTON
cmdSave.Enabled = False
End Sub
Private Sub LoadGrid()
'IF OUR DATA IS RETURNED AND POPULATE GRID & BUILD UPDATE COMMAND
If SQL.RecordCount > 0 Then
dgvData.DataSource = SQL.SQLDataset.Tables(0)
dgvData.Rows(0).Selected = True
SQL.SQLDA.UpdateCommand = New SqlClient.SqlCommandBuilder(SQL.SQLDA).GetUpdateCommand
End If
End Sub
Private Sub dgvData_CellValueChanged(ByVal sender As Object, ByVal e As System.Windows.Forms.DataGridViewCellEventArgs) Handles dgvData.CellValueChanged
cmdSave.Enabled = True
End Sub
Private Sub dgvData_RowsRemoved(ByVal sender As Object, ByVal e As System.Windows.Forms.DataGridViewRowsRemovedEventArgs) Handles dgvData.RowsRemoved
cmdSave.Enabled = True
End Sub
Private Sub cmdSave_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdSave.Click
'SAVE UPDATE TO THE DATA BASE
Try
SQL.SQLDA.Update(SQL.SQLDataset) ' TO DO: DATA VALIDATION
Catch ex As Exception
MsgBox("Already Exists")
End Try
'REFRESH GRID DATA
LoadGrid()
'DISABLE SAVE BUTTON
cmdSave.Enabled = False
End Sub
Private Sub cmdAdd_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles cmdAdd.Click
If Trim(txtPC.Text) = "" Then
MsgBox("Please fill out the pc name.")
Exit Sub
End If
If Trim(txtIP.Text) = "" Then
MsgBox("Please fill out the ip address.")
Exit Sub
End If
'Query for user
SQL.RunQuery("SELECT * FROM members WHERE members.PC = '" & txtPC.Text & "'")
If SQL.SQLDataset.Tables(0).Rows.Count > 0 Then
MsgBox("The name that you have enter enter is already exists")
Exit Sub
End If
SQL.RunQuery("SELECT * FROM members WHERE members.IP = '" & txtIP.Text & "'")
If SQL.SQLDataset.Tables(0).Rows.Count > 0 Then
MsgBox("The IP Address that you have enter is already exists!")
Exit Sub
End If
SQL.RunQuery("SELECT * FROM members WHERE members.Asset = '" & txtAsset.Text & "'")
If SQL.SQLDataset.Tables(0).Rows.Count > 0 Then
MsgBox("The Asset that you have enter is already exists")
Exit Sub
Else
CreateUser()
txtPC.Clear()
txtIP.Clear()
txtName.Clear()
txtEmail.Clear()
txtDepartment.Clear()
txtLocation.Clear()
txtModel.Clear()
txtSpecs.Clear()
txtDt.Clear()
txtAsset.Clear()
txtRent.Clear()
End If
End Sub
Public Sub CreateUser()
SQL.AddMember(txtPC.Text, txtIP.Text, txtName.Text, txtEmail.Text, txtDepartment.Text,
txtLocation.Text, txtModel.Text, txtSpecs.Text, txtDt.Text, txtAsset.Text, txtRent.Text)
End Sub
End Class
I don't know how to refresh the datagridview
this will works. just
Copy And Paste this to your load form.
Public Sub RefreshUserGrid()
' RUN QUERY
SQL.ExecQuery("SELECT * FROM members")
If SQL.SQLDataset.Tables.Count > 0 Then
dgvData.DataSource = SQL.SQLDataset.Tables(0)
dgvData.Rows(0).Selected = True
End If
End Sub
and also copy and paste this RefreshUserGrid() at your add command.
we are using a vb.net chat application which uses a TCP client to send message.it uses TCP port 25025.In some cases we get an error 10060 from client when sending message.Also the error is not continuous and is intermediate.In both PC windows firewall and antivirus firewall is off.To troubleshoot the problem i have tried telnet and netstat command and it worked without any error.what may be possible reasons for this error and how to troubleshoot?
Error 10060 is 'connection timed out'.
Check your timeout parameters for all sockets/TCP client/server objects.
Check that you are not looping somewhere waiting for a response, etc.
Without any source code or further information, other diagnosis is difficult!
these are client side and server side code.
we get Error 10053 and 10061 also
Client side code
in our application when user clicks 'send' message' button this procedure will be called..
Public Sub SendMessageByPort(ByVal PCName As String, ByVal Port As Integer, ByVal Message As String)
Try
'add winsock control added
Dim TempWinClient As New AxMSWinsockLib.AxWinsock
Me.Controls.Add(TempWinClient)
AddHandler TempWinClient.CloseEvent, AddressOf TcpClient_CloseEvent
AddHandler TempWinClient.ConnectEvent, AddressOf TcpClient_ConnectEvent
AddHandler TempWinClient.DataArrival, AddressOf TcpClient_DataArrival
AddHandler TempWinClient.Error, AddressOf TcpClient_Error
TempWinClient.RemoteHost = PCName
TempWinClient.RemotePort = Port
TempWinClient.Tag = Message
TempWinClient.Connect()
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "UpdateToServer")
End Try
End Sub
Private Sub TcpClient_ConnectEvent(ByVal sender As System.Object, ByVal e As System.EventArgs)
Try
sender.SendData(sender.tag)
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "WinClient_ConnectEvent")
End Try
End Sub
Private Sub TcpClient_DataArrival(ByVal sender As Object, ByVal e As AxMSWinsockLib.DMSWinsockControlEvents_DataArrivalEvent)
Try
Dim TempStr As String = ""
Dim MsgID As String = "" '
Dim ErrorMsgstr As String = ""
sender.GetData(TempStr)
If TempStr.IndexOf("[ERROR]") >= 0 Then
MessageBox.Show("Error when Message send to " & sender.RemoteHost.ToString & " " & TempStr, "ERROR", MessageBoxButtons.OK, MessageBoxIcon.Error)
ElseIf TempStr.IndexOf("[SUCCESS]") >= 0 Then
MessageBox.Show("Message Sucssesfully sent to port", "Success", MessageBoxButtons.OK, MessageBoxIcon.Information)
Else
MessageBox.Show(TempStr, "ERROR", MessageBoxButtons.OK, MessageBoxIcon.Error)
End If
sender.Close()
Me.Controls.Remove(sender)
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "TcpClient_DataArrival")
End Try
End Sub
Private Sub TcpClient_CloseEvent(ByVal sender As Object, ByVal e As System.EventArgs)
Try
sender.Close()
Me.Controls.Remove(sender)
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "WinClient_CloseEvent")
End Try
End Sub
Private Sub TcpClient_Error(ByVal sender As Object, ByVal e As AxMSWinsockLib.DMSWinsockControlEvents_ErrorEvent)
Try
Dim retryCnt As Integer
Dim MessageData As String = sender.tag
Dim RetryProcess As Boolean
Dim ErrorDetails As String = "Not Uploaded to Web because of connection failure in network " & sender.RemoteHost.ToString & ". DataSent:" & MessageData
'for this error we tried three times
If InStr(e.description, "Connection is aborted due to timeout or other failure", CompareMethod.Text) > 0 Then
retryCnt = Val(getArgColVal("RetryProcess", MessageData))
If retryCnt < 3 Then
MessageData = Replace(MessageData, "#RetryProcess$" & retryCnt & "|", "", , , CompareMethod.Text)
MessageData = MessageData & "#RetryProcess$" & (retryCnt + 1) & "|"
RetryProcess = True
End If
End If
If RetryProcess = True Then 'retry sending message to port on error
Call SendMessageByPort(sender.RemoteHost.ToString, sender.RemotePort, MessageData)
Else
Call Write_toErrorLog("", e.description, e.number, Me.Name, "TcpClient_Error", True, , , ErrorDetails) '
Call MsgWinman("785", "sender" & MsgVarSep & "description" & MsgVarSep & "number", sender.RemoteHost.ToString & MsgVarSep & e.description & MsgVarSep & e.number)
End If
End If
sender.Close()
Me.Controls.Remove(sender)
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "TcpClient_Error") 'sod 19.9.13'Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "WinClient_Error")
End Try
End Sub
Server side code
'global variables
Dim TempWebDetails() As WebUpLoadDetails
Dim WinSocketArray As AxMSWinsockLib.AxWinsock() = New AxMSWinsockLib.AxWinsock() {}
Dim WinSocketName() As String
'''
''' 0-->Close,1-->Listen,2-->Others
'''
Dim WinSocketState() As Integer
Dim WinTimer() As Integer
'frmpaydet is form name
Private Sub frmPayDet_Shown(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Shown
Try
LoadNewSocket()
ListenFreeSocket()
Me.Hide()
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Text, "frmPayDet_Shown")
End Try
End Sub
Private Sub LoadNewSocket()
Dim IsVisible As Boolean = Me.Visible
Try
Me.Visible = True
Dim i As Integer = WinSocketArray.GetUpperBound(0) + 1
ReDim Preserve WinSocketArray(i)
ReDim Preserve WinSocketState(i)
ReDim Preserve WinSocketName(i)
ReDim Preserve WinTimer(i)
WinSocketArray(i) = New AxMSWinsockLib.AxWinsock
WinSocketArray(i).Name = "WinServer" & i
WinSocketName(i) = WinSocketArray(i).Name
Me.Controls.Add(WinSocketArray(i))
AddHandler WinSocketArray(i).CloseEvent, AddressOf tcpServer_CloseEvent
AddHandler WinSocketArray(i).ConnectionRequest, AddressOf tcpServer_ConnectionRequest
AddHandler WinSocketArray(i).DataArrival, AddressOf tcpServer_DataArrival
AddHandler WinSocketArray(i).Error, AddressOf tcpServer_Error
ToolSeverCount.Text = " | WinSocket Count is " & i + 1 & " |"
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "LoadNewSocket")
Finally
Me.Visible = IsVisible
End Try
End Sub
Private Sub ListenFreeSocket()
On Error GoTo ListenFreeSocket_eh
Dim ListenFlg As Boolean
Timer1.Enabled = True
ToolServer.Text = ""
If WinSocketArray.Length > 0 Then
For i As Integer = 0 To WinSocketState.GetUpperBound(0)
If WinSocketState(i) = 1 Then
ToolServer.Text = " | " & WinSocketArray(i).Name & " Sever Listen at Port " & WinSocketArray(i).LocalPort & " | "
ListenFlg = True
Exit For
End If
Next
'if not found then listen socket which is free
If ListenFlg = False Then
For i As Integer = 0 To WinSocketState.GetUpperBound(0)
If WinSocketState(i) = 0 Then
WinSocketArray(i).LocalPort = Split("PC110:8000", ":")(1)
WinSocketArray(i).Listen()
ToolServer.Text = " | " & WinSocketArray(i).Name & " Sever Listen at Port " & WinSocketArray(i).LocalPort & " | "
WinSocketState(i) = 1
If i = WinSocketState.GetUpperBound(0) Then LoadNewSocket()
ListenFlg = True
Exit For
End If
Next
End If
End If
If ListenFlg = False Then
'Enable Timer
LoadNewSocket()
Timer1.Enabled = True
Else
'Disable Timer
Timer1.Enabled = False
End If
Exit Sub
ListenFreeSocket_eh:
'Write_toErrorLog_old(Err.Description, Err.Number, Me.Name, "ListenFreeSocket")'this line must be commented
End Sub
Private Sub Timer1_Tick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Timer1.Tick
Try
Call ListenFreeSocket()
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "Timer1_Tick")
End Try
End Sub
Private Sub tcpServer_ConnectionRequest(ByVal sender As Object, ByVal e As AxMSWinsockLib.DMSWinsockControlEvents_ConnectionRequestEvent) ' Handles tcpServer1.ConnectionRequest, tcpServer2.ConnectionRequest, tcpServer3.ConnectionRequest, tcpServer4.ConnectionRequest, tcpServer5.ConnectionRequest, tcpServer0.ConnectionRequest
Try
CloseWinSocket(sender.name)
sender.Accept(e.requestID)
ConnectWinSocket(sender.name)
ListenFreeSocket()
ToolStatus.Text = " | " & sender.RemoteHostIP & " IP Address Accepted | "
Catch ex As Exception
ToolServer.Text = ex.Message & " Please Call Coding Team"
End Try
End Sub
Private Sub CloseWinSocket(ByVal SocketName As String)
Try
If SocketName.Trim <> "" Then
Dim i As Integer = Array.IndexOf(WinSocketName, SocketName)
WinSocketArray(i).Close()
WinSocketState(i) = 0
WinTimer(i) = 0
Else
If Not WinSocketState Is Nothing Then
For i As Integer = 0 To WinSocketState.GetUpperBound(0)
If WinSocketState(i) <> 0 Then
WinSocketArray(i).Close()
WinSocketState(i) = 0
WinTimer(i) = 0
End If
Next
End If
End If
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "CloseWinSocket")
End Try
End Sub
Private Sub ConnectWinSocket(ByVal SocketName As String)
Try
Dim i As Integer = Array.IndexOf(WinSocketName, SocketName)
WinSocketState(i) = 2
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "ConnectWinSocket")
End Try
End Sub
Private Sub tcpServer_DataArrival(ByVal sender As Object, ByVal e As AxMSWinsockLib.DMSWinsockControlEvents_DataArrivalEvent)
Try
Dim TempStr As String = ""
Dim ReplyMessage As String = ""
sender.GetData(TempStr)
If TempStr Is Nothing Then TempStr = ""
If TempStr.Trim <> "" Then
''some process is done
'ReplyMessage string assigned proper reply string
sender.SendData(ReplyMessage)
Else
CloseWinSocket(sender.name)
ToolStatus.Text = " | No Data Sent to IPAddress:- " & sender.RemoteHostIP & " | "
End If
Catch ex As Exception
Write_toErrorLog(ex.StackTrace, Err.Description, Err.Number, Me.Name, "tcpServer_DataArrival")
End Try
End Sub
Private Sub tcpServer_Error(ByVal sender As Object, ByVal e As AxMSWinsockLib.DMSWinsockControlEvents_ErrorEvent)
Try
ToolServer.Text = e.description & " Please Call Coding Team"
CloseWinSocket(sender.name)
ListenFreeSocket()
ToolServer.Text = "Sever Listen on Local Port " & sender.LocalPort()
Catch ex As Exception
ToolServer.Text = ex.Message & " Please Call Coding Team"
End Try
End Sub
Private Sub tcpServer_CloseEvent(ByVal sender As Object, ByVal e As System.EventArgs)
Try
CloseWinSocket(sender.name)
ListenFreeSocket()
Catch ex As Exception
ToolServer.Text = ex.Message & " Please Call Coding Team"
End Try
End sub
I've been wondering about this, I have tried multiple suggestions I have got from different sites. I have my code here but it's not working.
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal _
uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
Private Sub Button3_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles Button3.Click
Dim fileName As String
FileName = Chr(34) & (Button1.Text) & Chr(34)
mciSendString("open " & FileName & " alias myDevice", Nothing, 0, 0)
mciSendString("play myDevice", Nothing, 0, 0)
FileName = Chr(34) & (Button2.Text) & Chr(34)
mciSendString("open " & FileName & " alias myDevice", Nothing, 0, 0)
mciSendString("play myDevice", Nothing, 0, 0)
This code only plays the first song and will not play the second one...I'm thinking of creating another function similar to the one above with different name but still no luck.
Private Declare Function mciSendString2 Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal _
uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
Any idea? Or is it possible to play multiple mp3 at the same time?
Although I am dealing with a different issue myself, I came across this in my search and can tell you the reason it cannot play the 2 files at the same time is because your alias is the same for both.
This method has worked well for me only during development but most computers I installed on would crash when i would issue the open command via mcisendstring. I haven't figured out why. Here's my code. Maybe it will help someone and maybe someone can figure out what I'm doing wrong. I've had problems getting 32 bit apps to run from my 64 bit development machine.
Imports System.Runtime.InteropServices
Imports System.Text
Public Class MediaPlayerClass
<DllImport("winmm.dll")> _
Private Shared Function mciSendString(ByVal command As String, ByVal buffer As StringBuilder, ByVal bufferSize As Integer, ByVal hwndCallback As IntPtr) As Integer
End Function
<DllImport("winmm.dll")> _
Private Shared Function mciGetErrorString(errCode As Integer, ByVal errMsg As StringBuilder, bufferSize As Integer) As Integer
End Function
<DllImport("kernel32.dll", SetLastError:=True, CharSet:=CharSet.Auto)> _
Public Shared Function GetShortPathName(ByVal longPath As String, _
<MarshalAs(UnmanagedType.LPTStr)> ByVal ShortPath As System.Text.StringBuilder, _
<MarshalAs(Runtime.InteropServices.UnmanagedType.U4)> ByVal bufferSize As Integer) As Integer
End Function
Private _filename As String
Private _MediaAlias As String
Private _Length As TimeSpan
Private _err As Integer
Public Property PlaylistId As Integer = 0
Private _OriginalVolume As Integer = 1000
Function ShortPathName(ByVal Path As String) As String
Dim sb As New System.Text.StringBuilder(1024)
Dim tempVal As Integer = GetShortPathName(Path, sb, 1024)
If tempVal <> 0 Then
Dim Result As String = sb.ToString()
Return Result
Else
Throw New Exception("Failed to return a short path")
End If
End Function
Public Sub New(Filename As String, MediaAlias As String)
_filename = ShortPathName(Filename)
_MediaAlias = MediaAlias.Replace(" ", "_")
'_Length = GetLength()
Try
My.Application.Log.WriteEntry("MediaPlayerClass.New - calling MCI OPEN")
' here is where it crashes
_err = mciSendString("open """ & _filename & """ alias " & MediaAlias, Nothing, 0, 0)
Catch ex As Exception
MsgBox(ex.ToString & vbCrLf & GetLastErrorMessage())
End Try
End Sub
Public Sub NewMP3(Filename As String)
Me.StopIt()
Me.CloseIt()
_filename = Filename
Try
My.Application.Log.WriteEntry("MediaPlayerClass.NewMP3 - calling MCI OPEN ")
_err = mciSendString("open """ & Filename & """ alias " & _MediaAlias, Nothing, 0, 0)
Catch ex As Exception
MsgBox(ex.ToString & vbCrLf & GetLastErrorMessage())
End Try
End Sub
Public ReadOnly Property Length As TimeSpan
Get
Return _length
End Get
End Property
Private Function GetLength() As TimeSpan
Dim lengthBuf As New StringBuilder(32)
Try
My.Application.Log.WriteEntry("MediaPlayerClass.GetLength - calling MCI OPEN")
_err = mciSendString("open """ & _filename & """ type waveaudio alias " & _MediaAlias, Nothing, 0, 0)
Catch ex As Exception
MsgBox(ex.ToString & vbCrLf & GetLastErrorMessage())
End Try
' Get the duration of the music
Try
_err = mciSendString("status wave length", lengthBuf, lengthBuf.Capacity, 0)
Catch ex As Exception
MsgBox(ex.ToString & vbCrLf & GetLastErrorMessage())
End Try
'mciSendString("close wave", Nothing, 0, 0)
Dim len As Integer = Integer.TryParse(lengthBuf.ToString, len)
Dim ts As TimeSpan = TimeSpan.FromMilliseconds(len)
Return ts
End Function
Public Function PlayIt(Optional WaitUntilFinishedPlaying As Boolean = False) As Integer
Try
My.Application.Log.WriteEntry("MediaPlayerClass.PlayIt - calling MCI PLAY")
_err = mciSendString("play " & _MediaAlias, Nothing, 0, IntPtr.Zero)
Catch ex As Exception
MsgBox(ex.ToString)
End Try
While WaitUntilFinishedPlaying
If IsPlaying() Then
Threading.Thread.Sleep(250)
Else
Exit While
End If
End While
Return _err
End Function
Public Function PauseIt() As Integer
_err = mciSendString("pause " & _MediaAlias, Nothing, 0, IntPtr.Zero)
Return _err
End Function
Public Function ResumeIt() As Integer
_err = mciSendString("resume " & _MediaAlias, Nothing, 0, IntPtr.Zero)
Return _err
End Function
Public Function StopIt() As Boolean
_err = mciSendString("stop " & _MediaAlias, Nothing, 0, IntPtr.Zero)
Return _err
End Function
Public Function CloseIt() As Boolean
_err = mciSendString("close " & _MediaAlias, Nothing, 0, IntPtr.Zero)
Return _err
End Function
Public Function IsPlaying() As Boolean
Dim returnData As New StringBuilder(128)
_err = mciSendString("status " & _MediaAlias & " mode", returnData, 128, IntPtr.Zero)
Return (returnData.Length = 7 AndAlso returnData.ToString.Substring(0, 7) = "playing")
End Function
Public Function SetVolume(vol As Integer) As Integer
_err = -1
If vol >= 0 And vol <= 1000 Then
_err = mciSendString("setaudio " & _MediaAlias & " volume to " & vol.ToString, Nothing, 0, IntPtr.Zero)
End If
Return _err
End Function
Public Sub FadeOutAndPause()
_OriginalVolume = GetVolume()
For x As Integer = 30 To 1 Step -1
Me.SetVolume(Int(x / 30 * _OriginalVolume))
Threading.Thread.Sleep(100)
Next
Me.PauseIt()
End Sub
Public Sub PlayAndFadeIn()
Me.PlayIt()
For x As Integer = 1 To 30 Step 1
Me.SetVolume(Int(x / 30 * _OriginalVolume))
Threading.Thread.Sleep(100)
Next
End Sub
Public Function GetVolume() As Integer
Dim returnData As New StringBuilder(128)
_err = mciSendString("status " & _MediaAlias & " volume", returnData, 128, IntPtr.Zero)
'MsgBox(returnData.ToString)
If _err = 0 Then
Return CInt(returnData.ToString)
Else
Return 1000
End If
End Function
Public Function SetBalance(bal As Integer) As Integer
If bal >= 0 AndAlso bal <= 1000 Then
_err = mciSendString("setaudio " & _MediaAlias & " left volume to " + (1000 - bal).ToString, Nothing, 0, IntPtr.Zero)
_err = mciSendString("setaudio " & _MediaAlias & " right volume to " + bal.ToString, Nothing, 0, IntPtr.Zero)
End If
Return _err
End Function
Public Function GetLastErrorMessage() As String
Dim returnData As New StringBuilder(128)
_err = mciGetErrorString(_err, returnData, 128)
Return returnData.ToString.Trim
End Function
Protected Overrides Sub Finalize()
MyBase.Finalize()
CloseIt()
End Sub
End Class
I read some tutorials on how to play a WAV file in VB.Net using the mciSendString() function. For some reason, it succeeds in recording and saving the sound into a file (I listened to the file with a sound application), but plays nothing and triggers no error.
Here's the code:
'Start recording
If OvalShape1.FillColor = Color.DarkRed Then
OvalShape1.FillColor = Color.Red
Try
mciSendString("open new Type waveaudio Alias recsound", "", 0, 0)
mciSendString("record recsound", "", 0, 0)
Catch ex As Exception
MessageBox.Show(ex.ToString)
OvalShape1.FillColor = Color.DarkRed
End Try
'Stop recording
Else
OvalShape1.FillColor = Color.DarkRed
Try
'generate unique filename and save as tmp file
Dim TempFullFileName As String = IO.Path.GetTempFileName()
'save recording
mciSendString("save recsound " & Chr(34) & TempFullFileName & Chr(34), "", 0, 0)
mciSendString("close recsound", "", 0, 0)
mciSendString("open " & Chr(34) & TempFullFileName & Chr(34) & " Alias recsound", "", 0, 0)
mciSendString("play recsound", Nothing, 0, 0)
mciSendString("close recsound", "", 0, 0)
Catch ex As Exception
MessageBox.Show(ex.ToString)
OvalShape1.FillColor = Color.DarkRed
End Try
End If
Originally, I simply saved and played the file, next I closed/reopened the sound file but it makes no difference. Am I missing something?
Thank you.
Edit:
Try/catch doesn't display errors returned by mciSendString -> Use mciGetErrorString() to check the returned value
To play the whole sound file, you must add "wait" before closing
Here's some working code:
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" _
(ByVal lpstrCommand As String, ByVal lpstrReturnString As String, _
ByVal uReturnLength As Integer, ByVal hwndCallback As Integer) As Integer
Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Integer, ByVal lpstrBuffer As String, ByVal uLength As Integer) As Integer
Private Function GetMCIErrorString(ByVal ErrorCode As Integer) As String
GetMCIErrorString = Space(1024)
mciGetErrorString(ErrorCode, GetMCIErrorString, Len(GetMCIErrorString))
GetMCIErrorString = Trim(GetMCIErrorString)
End Function
Private Sub Form1_DoubleClick(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.DoubleClick
Dim SoundFile As String = "C:\Documents and Settings\joe\Local Settings\Temp\tmp8FED.wav"
SoundFile = ControlChars.Quote & SoundFile & ControlChars.Quote
Dim StringToOpen As String = "open " & DummyFile & " alias recsound"
ErrCode = mciSendString(StringToOpen, "", 0, 0)
If ErrCode <> 0 Then
MessageBox.Show(GetMCIErrorString(ErrCode))
Exit Sub
End If
ErrCode = mciSendString("play recsound wait", Nothing, 0, 0)
If ErrCode <> 0 Then
MessageBox.Show(GetMCIErrorString(ErrCode))
Exit Sub
End If
ErrCode = mciSendString("close recsound", "", 0, 0)
If ErrCode <> 0 Then
MessageBox.Show(GetMCIErrorString(ErrCode))
Exit Sub
End If
End Sub