Find all our projects in development below.
All source code is GNU General Public License (GPL)
Browsing MainForm.frm (31.05 KB)
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form MainForm
BorderStyle = 1 'Fixed Single
Caption = "SHOUTcast Stream Disk Writer"
ClientHeight = 6855
ClientLeft = 45
ClientTop = 435
ClientWidth = 5055
BeginProperty Font
Name = "Tahoma"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "MainForm.frx":0000
MaxButton = 0 'False
ScaleHeight = 6855
ScaleWidth = 5055
StartUpPosition = 2 'CenterScreen
Begin VB.Timer NewLocTimer
Enabled = 0 'False
Interval = 1
Left = 2160
Top = 0
End
Begin MSComDlg.CommonDialog FileDialog
Left = 1200
Top = 0
_ExtentX = 847
_ExtentY = 847
_Version = 393216
CancelError = -1 'True
DialogTitle = "Open Playlist File"
Filter = "Playlist Files (*.pls;*.m3u)|*.pls;*.m3u|All Files (*.*)|*.*"
End
Begin MSWinsockLib.Winsock ws3
Left = 720
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Timer DelayTimer
Enabled = 0 'False
Interval = 1000
Left = 1680
Top = 0
End
Begin VB.Timer BarTimer
Enabled = 0 'False
Interval = 200
Left = 4440
Top = 3600
End
Begin MSWinsockLib.Winsock ws2
Left = 360
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Timer StatisticsTimer
Enabled = 0 'False
Interval = 1000
Left = 4080
Top = 3600
End
Begin MSWinsockLib.Winsock ws
Left = 0
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.Frame Frame2
Caption = "S&tatistics"
Height = 2895
Left = 120
TabIndex = 18
Top = 3480
Width = 4815
Begin VB.TextBox txtInfo
BackColor = &H8000000F&
BorderStyle = 0 'None
Height = 1815
Left = 240
Locked = -1 'True
MultiLine = -1 'True
TabIndex = 19
Top = 360
Width = 4335
End
Begin VB.Label lblBar2
Caption = "Disk Write Buffer:"
Height = 255
Left = 240
TabIndex = 22
Top = 2540
Width = 1335
End
Begin VB.Label lblBar1
Caption = "Metadata Buffer:"
Height = 255
Left = 240
TabIndex = 21
Top = 2280
Width = 1335
End
Begin VB.Shape Bar2
BackColor = &H0000C0C0&
BackStyle = 1 'Opaque
BorderColor = &H8000000F&
Height = 255
Left = 1680
Top = 2520
Width = 15
End
Begin VB.Shape Bar1
BackColor = &H000000C0&
BackStyle = 1 'Opaque
BorderColor = &H8000000F&
Height = 255
Left = 1680
Top = 2280
Width = 15
End
End
Begin VB.CommandButton Command2
Caption = "E&xit"
Height = 375
Left = 3360
TabIndex = 17
Top = 2880
Width = 1575
End
Begin VB.CommandButton Command1
Caption = "&Begin Disk Write"
Default = -1 'True
Height = 375
Left = 120
TabIndex = 16
Top = 2880
Width = 1575
End
Begin VB.Frame Frame1
Caption = "Settings"
Height = 2535
Left = 120
TabIndex = 23
Top = 120
Width = 4815
Begin VB.TextBox txtMask
Height = 315
Left = 1560
MaxLength = 100
TabIndex = 13
Text = "xxxx $filename"
Top = 1800
Width = 2655
End
Begin VB.CheckBox chkEnable
Alignment = 1 'Right Justify
Caption = "&Enable"
Height = 255
Left = 3720
TabIndex = 11
Top = 1460
Width = 855
End
Begin VB.TextBox txtMaxSize
Enabled = 0 'False
Height = 315
Left = 1560
MaxLength = 4
TabIndex = 10
Text = "100"
Top = 1440
Width = 615
End
Begin VB.CommandButton Command5
Enabled = 0 'False
Height = 255
Left = 4275
Picture = "MainForm.frx":0E42
Style = 1 'Graphical
TabIndex = 15
ToolTipText = "Listen to the SHOUTcast stream..."
Top = 2115
Width = 300
End
Begin VB.CommandButton Command4
Caption = "..."
Height = 255
Left = 4280
Style = 1 'Graphical
TabIndex = 2
ToolTipText = "Browse for playlist file..."
Top = 380
Width = 300
End
Begin VB.CheckBox chkReStream
Caption = "&ReStream data on localhost"
Height = 255
Left = 1560
TabIndex = 14
ToolTipText = "Check if you want the SHOUTcast stream to be restreamed on localhost"
Top = 2160
Value = 1 'Checked
Width = 2535
End
Begin VB.CommandButton Command3
Caption = "..."
Height = 255
Left = 4280
Style = 1 'Graphical
TabIndex = 5
ToolTipText = "Browse for folder..."
Top = 740
Width = 300
End
Begin VB.TextBox txtDelay
Height = 315
Left = 1560
MaxLength = 2
TabIndex = 7
Text = "3"
ToolTipText = "Sets the delay of how long to wait until writing new file (in seconds)"
Top = 1080
Width = 615
End
Begin VB.CheckBox chkOneFile
Caption = "&Write as one file"
Height = 255
Left = 2280
TabIndex = 8
ToolTipText = "Check if you want the entire stream written to disk as one file"
Top = 1120
Width = 2295
End
Begin VB.TextBox txtFolder
Height = 315
Left = 1560
MaxLength = 1000
TabIndex = 4
Text = "C:\"
ToolTipText = "Specifies the folder where the songs will be written to"
Top = 720
Width = 2655
End
Begin VB.ComboBox cboServer
Height = 315
Left = 1560
TabIndex = 1
ToolTipText = "Specifies the server and/or port of the SHOUTcast stream"
Top = 360
Width = 2655
End
Begin VB.Label lblFNameMask
Alignment = 1 'Right Justify
Caption = "F&ile Name Mask:"
Height = 255
Left = 120
TabIndex = 12
Top = 1860
Width = 1335
End
Begin VB.Label lblSizeMsg
Caption = "(in megabytes)"
Height = 255
Left = 2280
TabIndex = 24
Top = 1500
Width = 1215
End
Begin VB.Label lblFileSize
Alignment = 1 'Right Justify
Caption = "&Max Write Size:"
Height = 255
Left = 120
TabIndex = 9
Top = 1500
Width = 1335
End
Begin VB.Label lblDelay
Alignment = 1 'Right Justify
Caption = "&New Song Delay:"
Height = 255
Left = 120
TabIndex = 6
Top = 1140
Width = 1335
End
Begin VB.Label lblFolder
Alignment = 1 'Right Justify
Caption = "&Folder:"
Height = 255
Left = 240
TabIndex = 3
Top = 765
Width = 1215
End
Begin VB.Label lblServer
Alignment = 1 'Right Justify
Caption = "&Server:"
Height = 255
Left = 240
TabIndex = 0
Top = 420
Width = 1215
End
End
Begin VB.Label lblStatus
BorderStyle = 1 'Fixed Single
Caption = " No Connection."
Height = 255
Left = 120
TabIndex = 20
Top = 6480
Width = 4815
End
End
Attribute VB_Name = "MainForm"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim sRequestURI As String
Dim dNetworkRecv As Double
Dim dNetworkRecv2 As Double
Dim lMetadataRecv As Long
Dim lMetadataInterval As Long
Dim sStreamName As String
Dim sStreamGenre As String
Dim sStreamURL As String
Dim sStreamTitle As String
Dim iStreamPub As Integer
Dim iStreamBr As Integer
Dim sNotice1 As String
Dim sNotice2 As String
Dim sServer As String
Dim sFilename As String
Dim iFilenum As Integer
Dim lSongNum As Long
Dim Bar1Width As Single
Dim Bar2Width As Single
Dim bCanSendData As Boolean
Private Const SW_NORMAL = 1
Private Declare Function ShellExecute Lib "shell32" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const MAX_PATH = 260
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function InitCommonControls Lib "comctl32.dll" () As Long
Private Sub ExecFile(ByVal File As String, ByVal Path As String)
ShellExecute 0&, vbNullString, File, vbNullString, Path, SW_NORMAL
End Sub
Private Function GetDirSize(ByVal strPath As String) As Double
Dim TotalSize As Double
Dim strFile As String
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
strFile = Dir(strPath)
Do While strFile <> ""
If strFile <> "." And strFile <> ".." And GetAttr(strPath + strFile) <> vbDirectory Then TotalSize = TotalSize + FileLen(strPath + strFile)
strFile = Dir
Loop
GetDirSize = TotalSize
End Function
Private Function Getstr(ByVal ItemName As String, File As String) As String
On Error GoTo NoF
Dim FNum As Integer
Dim L As String
Dim Lines() As String
Dim i As Long
FNum = FreeFile
ItemName = ItemName + "="
Open File For Input As #FNum
Do While Not EOF(FNum)
Line Input #FNum, L
If Left(L, Len(ItemName)) = ItemName Then
Getstr = Mid(L, Len(ItemName) + 1)
Close #FNum
Exit Function
End If
Loop
Close #FNum
NoF:
If File <> "" Then
Lines = Split(File, vbCrLf)
For i = LBound(Lines) To UBound(Lines)
If Left(Lines(i), Len(ItemName)) = ItemName Then
Getstr = Mid(Lines(i), Len(ItemName) + 1)
Exit Function
End If
Next i
Else
Getstr = ""
End If
End Function
Private Sub RebuildFile(inFile As String, Optional outFile As String, Optional ByVal StrIn As String, Optional ByVal StrOut As String)
On Error GoTo OpenErr
Dim nFile1 As Integer
Dim nFile2 As Integer
Dim sRandomFile As String
nFile1 = FreeFile
nFile2 = FreeFile + 1
sRandomFile = CreateRandomFile
If StrIn = "" Then StrIn = Chr(10)
If StrOut = "" Then StrOut = vbCrLf
Open inFile For Input As #nFile1
If outFile <> "" Then
Open outFile For Output As #nFile2
Else
Open sRandomFile For Output As #nFile2
End If
Print #nFile2, Replace(Input(LOF(nFile1), nFile1), StrIn, StrOut);
Close #nFile1
Close #nFile2
If outFile = "" Then
Kill inFile
Name sRandomFile As inFile
End If
Exit Sub
OpenErr:
Close
MsgBox "Unexpected Error (Error #" & Err & "): " + Err.Description, vbCritical
End Sub
Private Function CreateRandomFile(Optional FileExtension As String = "tmp", Optional FileLength As Integer = 8, Optional ExtensionLength As Integer = 3, Optional bIncludeNumbers As Boolean = True, Optional bIncludeLetters As Boolean = True) As String
Dim sTempFile As String
Dim i As Integer
Randomize Timer
If bIncludeNumbers = False And bIncludeLetters = False Then Exit Function
For i = 1 To FileLength + ExtensionLength
If Int(Rnd * 2) Then
If bIncludeNumbers Then
sTempFile = sTempFile & Int(Rnd * 10)
Else
i = i - 1
End If
Else
If bIncludeLetters Then
sTempFile = sTempFile + Chr(Int((122 - 65) * Rnd) + 65)
Else
i = i - 1
End If
End If
If i = FileLength Then
If ExtensionLength > 0 Then sTempFile = sTempFile + "."
If FileExtension <> "" Then
sTempFile = sTempFile + FileExtension
Exit For
End If
End If
Next i
CreateRandomFile = sTempFile
End Function
Private Sub LoadPlaylistFile(File As String)
On Error GoTo ErrHandler
Dim sLine As String
Dim bFirstLine As Boolean
Dim iNumOfEntries As Long
Dim i As Integer
Dim FNum As Integer
FNum = FreeFile
bFirstLine = True
cboServer.Clear
Open File For Input As #FNum
Do While Not EOF(FNum)
Line Input #FNum, sLine
If bFirstLine = True And LCase(Left(sLine, 10)) = "[playlist]" Then
Close #FNum
RebuildFile File, , Chr(10), vbCrLf
iNumOfEntries = Val(Getstr("numberofentries", File))
If iNumOfEntries = 0 Then iNumOfEntries = Val(Getstr("NumberOfEntries", File))
For i = 1 To iNumOfEntries
sLine = Getstr("File" & i, File)
If Left(LCase(sLine), 7) = "http://" Then sLine = Mid(sLine, 8)
cboServer.AddItem sLine
Next i
If cboServer.ListCount > 0 Then cboServer.ListIndex = 0
Exit Sub
Else
bFirstLine = False
End If
If Left(sLine, 1) <> "#" Then cboServer.AddItem sLine
Loop
ErrHandler:
On Error Resume Next
Close #FNum
If cboServer.ListCount > 0 Then cboServer.ListIndex = 0
End Sub
Private Sub BarTimer_Timer()
If Bar1Width > 2880 Then Bar1Width = 2880
If Bar2Width > 2880 Then Bar2Width = 2880
Bar1.Width = Bar1Width
Bar2.Width = Bar2Width
If Bar1Width = 0 Or Bar2Width = 0 Then
lblStatus.Caption = " SHOUTcast Stream Opened (Syncronization: 0%)."
Else
lblStatus.Caption = " SHOUTcast Stream Opened (Syncronization: " & IIf(Int((Bar1Width / Bar2Width) * 100) > 100, Int((Bar2Width / Bar1Width) * 100), Int((Bar1Width / Bar2Width) * 100)) & "%)."
End If
Bar1Width = 0
Bar2Width = 0
End Sub
Private Sub chkEnable_Click()
If chkEnable.Value = 0 Then
txtMaxSize.Enabled = False
Else
txtMaxSize.Enabled = True
End If
End Sub
Private Sub chkOneFile_Click()
If chkOneFile.Value = 0 Then
txtDelay.Enabled = True
Else
txtDelay.Enabled = False
End If
End Sub
Private Sub Command1_Click()
Dim sckHost As String
Dim sckPort As Integer
If Command1.Caption = "&Begin Disk Write" Then
If cboServer.Text = "" Then
MsgBox "Please enter a SHOUTcast server address and port.", vbExclamation
cboServer.SetFocus
Exit Sub
End If
If txtMask.Text = "" Then
MsgBox "Please enter a filename mask.", vbExclamation
txtMask.Text = "xxxx $filename"
txtMask.SetFocus
txtMask.SelStart = 0
txtMask.SelLength = Len(txtMask.Text)
Exit Sub
End If
If txtFolder.Text = "" Then txtFolder.Text = "C:\"
lblStatus.Caption = " Connecting to: " & cboServer.Text & "..."
cboServer.Enabled = False
Command4.Enabled = False
txtFolder.Enabled = False
Command3.Enabled = False
txtMask.Enabled = False
chkReStream.Enabled = False
If chkReStream.Value = 1 Then Command5.Enabled = True
If Right(txtFolder.Text, 1) <> "\" Then txtFolder.Text = txtFolder.Text + "\"
Command1.Caption = "&End Disk Write"
Command1.Cancel = True
lSongNum = 0
sckHost = cboServer.Text
If InStr(sckHost, "//") Then sckHost = Mid(sckHost, InStr(sckHost, "//") + 2)
If InStr(sckHost, "/") Then
sRequestURI = Mid(sckHost, InStr(sckHost, "/"))
sckHost = Left(sckHost, InStr(sckHost, "/") - 1)
Else
sRequestURI = "/"
End If
If InStr(sckHost, ":") Then
sckPort = Val(Mid(sckHost, InStr(sckHost, ":") + 1))
sckHost = Left(sckHost, InStr(sckHost, ":") - 1)
If sckPort < 1 Then sckPort = 8001
Else
sckPort = 8001
End If
ws.Close
ws.Connect sckHost, sckPort
Else
ws_Close
End If
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
Dim strFolder As String
strFolder = FolderBrowse(hWnd, "Browsing for mp3 output folder...")
If strFolder <> "" Then txtFolder.Text = strFolder
End Sub
Private Sub Command4_Click()
On Error GoTo CancelErr
FileDialog.ShowOpen
LoadPlaylistFile FileDialog.FileName
CancelErr:
End Sub
Private Sub Command5_Click()
On Error GoTo ErrHandler
Dim sPath As String
Dim FNum As Integer
sPath = GetTempDirectory
FNum = FreeFile
If Right(sPath, 1) <> "\" Then sPath = sPath + "\"
Open sPath + "localscs.pls" For Output As #FNum
Print #FNum, "[playlist]"
Print #FNum, "numberofentries=1"
Print #FNum, "File1=http://localhost:" & ws.RemotePort
Print #FNum, "Title1=localhost SHOUTcast server"
Print #FNum, "Length1=-1"
Close #FNum
ExecFile sPath + "localscs.pls", sPath
Exit Sub
ErrHandler:
MsgBox "Error: " + Err.Description, vbCritical
End Sub
Private Function GetTempDirectory() As String
Dim sBuf As String * MAX_PATH
GetTempPath MAX_PATH, sBuf
If InStr(sBuf, Chr(0)) Then sBuf = Left(sBuf, InStr(sBuf, Chr(0)) - 1)
GetTempDirectory = Trim(sBuf)
End Function
Private Sub DelayTimer_Timer()
On Error Resume Next
Static iMin As Integer
If iMin = Val(txtDelay.Text) Then
Dim sSongNum As String
Dim sCurrSongNum As String
Dim sNewFileName As String
Dim i As Integer
iMin = 0
DelayTimer.Enabled = False
sCurrSongNum = Right(CStr(lSongNum), 8)
sSongNum = String(8 - Len(sCurrSongNum), "0") + sCurrSongNum
sNewFileName = Replace(txtMask.Text, "$filename", sStreamTitle)
For i = 8 To 2 Step -1
sNewFileName = Replace(sNewFileName, String(i, "x"), Right(sSongNum, i))
Next i
sFilename = txtFolder.Text + sNewFileName + ".mp3"
Kill sFilename
If iFilenum > 0 Then Close #iFilenum
iFilenum = FreeFile
Open sFilename For Binary Access Write As #iFilenum
lSongNum = lSongNum + 1
ws2.Close
ws2.Connect ws.RemoteHost, ws.RemotePort
Exit Sub
End If
iMin = iMin + 1
End Sub
Private Sub Form_Load()
Call InitCommonControls
CButton Command3
CButton Command4
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If iFilenum > 0 Then
MsgBox "Can not quit until disk writing is stopped.", vbExclamation
Cancel = True
Exit Sub
End If
End Sub
Private Sub NewLocTimer_Timer()
NewLocTimer.Enabled = False
Command1_Click
End Sub
Private Sub StatisticsTimer_Timer()
' txtInfo.Text = "Network received: " & dNetworkRecv & " bytes" + vbCrLf + _
"Server: " + sServer + vbCrLf + _
"Metadata received: " & lMetadataRecv & " bytes" + vbCrLf + _
"Metadata interval: " & lMetadataInterval & " bytes" + vbCrLf + _
"Stream name: " + sStreamName + vbCrLf + _
"Current title: " + sStreamTitle
txtInfo.Text = "Network received: " & dNetworkRecv & "/" & dNetworkRecv2 & " bytes" + vbCrLf + _
"Server: " + sServer + vbCrLf + _
"Metadata received: n/a" + vbCrLf + _
"Metadata interval: " & lMetadataInterval & " bytes" + vbCrLf + _
"Stream name: " + sStreamName + vbCrLf + _
"Current title: " + sStreamTitle
End Sub
Private Sub txtDelay_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtDelay_LostFocus()
txtDelay.Text = Val(txtDelay.Text)
End Sub
Private Sub txtMaxSize_KeyPress(KeyAscii As Integer)
If KeyAscii >= 48 And KeyAscii <= 57 Or KeyAscii = 8 Then Exit Sub
KeyAscii = 0
End Sub
Private Sub txtMaxSize_LostFocus()
txtMaxSize.Text = Val(txtMaxSize.Text)
End Sub
Private Sub ws_Close()
ws.Close
ws2.Close
ws3.Close
If iFilenum > 0 Then Close #iFilenum
iFilenum = 0
StatisticsTimer.Enabled = False
BarTimer.Enabled = False
Command1.Caption = "&Begin Disk Write"
Command1.Cancel = False
cboServer.Enabled = True
Command4.Enabled = True
txtFolder.Enabled = True
Command3.Enabled = True
txtMask.Enabled = True
chkReStream.Enabled = True
Command5.Enabled = False
txtInfo.Text = ""
Bar1.Width = 0
Bar2.Width = 0
bBufReady = False
lblStatus.Caption = " No Connection."
End Sub
Private Sub ws_Connect()
Dim sHeader As String
lblStatus.Caption = " Connected to " + cboServer.Text
dNetworkRecv = 0
lMetadataRecv = 0
lMetadataInterval = 0
sStreamName = ""
sStreamGenre = ""
sStreamURL = ""
sStreamTitle = ""
iStreamPub = 0
iStreamBr = 0
sServer = ""
sFilename = ""
iFilenum = 0
bCanSendData = False
StatisticsTimer.Enabled = True
BarTimer.Enabled = True
sHeader = "GET " + sRequestURI + " HTTP/1.0" + vbCrLf + _
"Host: " + cboServer.Text + vbCrLf + _
"User-Agent: WinampMPEG/2.8" + vbCrLf + _
"Accept: */*" + vbCrLf + _
"Icy-MetaData:1" + vbCrLf + _
"Connection: close" + vbCrLf + vbCrLf
ws.SendData sHeader
End Sub
Private Sub ws_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
Dim i As Integer
Dim tmpstr() As String
Dim sStreamTitlePrev As String
ws.GetData RecvData
If RecvData = "" Then Exit Sub
dNetworkRecv = dNetworkRecv + bytesTotal
If Err.Number <> 0 Then dNetworkRecv = 0
If chkReStream.Value = 1 And bCanSendData = True Then ws3.SendData RecvData
If Left(RecvData, 10) = "ICY 200 OK" Then
lblStatus.Caption = " SHOUTcast Stream Opened."
tmpstr = Split(RecvData, vbCrLf)
For i = 0 To UBound(tmpstr)
If Left(tmpstr(i), 12) = "icy-notice1:" Then
sNotice1 = Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1)
ElseIf Left(tmpstr(i), 12) = "icy-notice2:" Then
sNotice2 = Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1)
sServer = Replace(sNotice2, "<BR>", "")
End If
Next i
If chkReStream.Value = 1 Then
ws3.LocalPort = ws.RemotePort
ws3.Listen
End If
Exit Sub
ElseIf Left(RecvData, 18) = "HTTP/1.0 302 Found" Then
tmpstr = Split(RecvData, vbCrLf)
For i = 0 To UBound(tmpstr)
If Left(tmpstr(i), 9) = "Location:" Then
ws_Close
cboServer.AddItem Trim(Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1))
cboServer.ListIndex = cboServer.NewIndex
NewLocTimer.Enabled = True
End If
Next i
Exit Sub
ElseIf Left(RecvData, 9) = "icy-name:" Then
tmpstr = Split(RecvData, vbCrLf)
For i = 0 To UBound(tmpstr)
If Left(tmpstr(i), 9) = "icy-name:" Then
sStreamName = Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1)
ElseIf Left(tmpstr(i), 10) = "icy-genre:" Then
sStreamGenre = Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1)
ElseIf Left(tmpstr(i), 8) = "icy-url:" Then
sStreamURL = Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1)
ElseIf Left(tmpstr(i), 8) = "icy-url:" Then
iStreamPub = CInt(Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1))
ElseIf Left(tmpstr(i), 12) = "icy-metaint:" Then
lMetadataInterval = CLng(Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1))
ElseIf Left(tmpstr(i), 7) = "icy-br:" Then
iStreamBr = CInt(Mid(tmpstr(i), InStr(tmpstr(i), ":") + 1))
End If
Next i
RecvData = Mid(RecvData, InStr(RecvData, vbCrLf + vbCrLf) + 4)
ElseIf InStr(RecvData, "StreamTitle=") Then
Dim sChar As String
Dim sData As String
sChar = Mid(RecvData, InStr(RecvData, "StreamTitle=") + 12, 1)
sData = Mid(RecvData, InStr(RecvData, "StreamTitle=") + 13)
sStreamTitlePrev = sStreamTitle
sStreamTitle = Left(sData, InStr(sData, sChar) - 1)
RecvData = Left(RecvData, InStr(RecvData, "StreamTitle=") - 2)
If sStreamTitle <> sStreamTitlePrev Then
Put #iFilenum, , RecvData
If chkOneFile.Value = 0 Then
If Val(txtDelay.Text) > 0 Then
DelayTimer.Enabled = True
Else
DelayTimer_Timer
End If
End If
End If
End If
Bar1Width = (bytesTotal / 3000) * 2880
End Sub
Private Sub ws_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Winsock Error: " + Description, vbCritical, App.Title + " (source: ws)"
ws_Close
End Sub
Private Sub ws2_Connect()
Dim sHeader As String
sHeader = "GET " + sRequestURI + " HTTP/1.0" + vbCrLf + _
"Host: " + cboServer.Text + vbCrLf + _
"User-Agent: WinampMPEG/2.8" + vbCrLf + _
"Accept: */*" + vbCrLf + _
"Icy-MetaData:0" + vbCrLf + _
"Connection: close" + vbCrLf + vbCrLf
ws2.SendData sHeader
End Sub
Private Sub ws2_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
Dim RecvData As String
ws2.GetData RecvData
If RecvData = "" Then Exit Sub
dNetworkRecv2 = dNetworkRecv2 + bytesTotal
If Err.Number <> 0 Then dNetworkRecv2 = 0
If Left(RecvData, 10) = "ICY 200 OK" Then
Exit Sub
ElseIf Left(RecvData, 9) = "icy-name:" Then
Exit Sub
End If
Put #iFilenum, , RecvData
If chkEnable.Value = 1 Then
If GetDirSize(txtFolder.Text) > (Val(txtMaxSize.Text) * 1000000) Then
ws_Close
MsgBox "The maximum disk write size has been acheived, stopping disk write.", vbExclamation
Exit Sub
End If
End If
Bar2Width = (bytesTotal / 3000) * 2880
End Sub
Private Sub ws2_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Winsock Error: " + Description, vbCritical, App.Title + " (source: ws2"
ws_Close
End Sub
Private Sub ws3_Close()
ws3.Close
If chkReStream.Value = 1 Then
ws3.LocalPort = ws.RemotePort
ws3.Listen
End If
End Sub
Private Sub ws3_ConnectionRequest(ByVal requestID As Long)
ws3.Close
ws3.Accept requestID
End Sub
Private Sub ws3_DataArrival(ByVal bytesTotal As Long)
Dim RecvData As String
Dim SendBuf As String
ws3.GetData RecvData
If Left(RecvData, 3) = "GET" Then
SendBuf = "ICY 200 OK" + vbCrLf + _
"icy-notice1:" + sNotice1 + vbCrLf + _
"icy-notice2:" + sNotice2 + vbCrLf
ws3.SendData SendBuf
SendBuf = "icy-name:" + sStreamName + vbCrLf + _
"icy-genre:" + sStreamGenre + vbCrLf + _
"icy-url:" + sStreamURL + vbCrLf + _
"icy-pub:" + sStreamURL + vbCrLf + _
"icy-metaint:" & iStreamPub & vbCrLf + _
"icy-br:" & iStreamBr & vbCrLf + vbCrLf
ws3.SendData SendBuf
bCanSendData = True
End If
End Sub
Private Sub ws3_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
ws3.Close
If chkReStream.Value = 1 Then
ws3.LocalPort = ws.RemotePort
ws3.Listen
End If
End Sub