modnetradio.bas

Usb Key loock vb soucrse code. ocx not found

Attribute VB_Name = "modNetRadio"
'/////////////////////////////////////////////////////////////////////////////////
' modNetRadio.bas - Copyright (c) 2002-2005 (: JOBnik! :) [Arthur Aminov, ISRAEL]
'                                                         [http://www.jobnik.org]
'                                                         [  [e-mail]  ]
'
' * Save local copy is added by: Peter Hebels @ http://www.phsoft.nl
'                                             e-mail: [e-mail]
'
' Other sources: frmNetRadio.frm & clsFileIo.cls
'
' BASS Internet radio example
' Originally translated from - netradio.c - Example of Ian Luck
'/////////////////////////////////////////////////////////////////////////////////

Option Explicit
Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0&    'color table in RGBs

Public Type BITMAPINFOHEADER
        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

Public Type RGBQUAD
        rgbBlue As Byte
        rgbGreen As Byte
        rgbRed As Byte
        rgbReserved As Byte
End Type

Public Type BITMAPINFO
        bmiHeader As BITMAPINFOHEADER
        bmiColors(255) As RGBQUAD
End Type

Declare Sub FillMemory Lib "kernel32.dll" Alias "RtlFillMemory" (Destination As Any, ByVal length As Long, ByVal Fill As Byte)
Public Declare Function SetDIBitsToDevice Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal dX As Long, ByVal dy As Long, ByVal srcX As Long, ByVal srcY As Long, ByVal Scan As Long, ByVal NumScans As Long, Bits As Any, BitsInfo As BITMAPINFO, ByVal wUsage As Long) As Long

Public SPECWIDTH As Long    ' display width
Public SPECHEIGHT As Long   ' height (changing requires palette adjustments too)
Public specmode As Integer, specpos As Integer  ' spectrum mode (and marker pos for 2nd mode)
Public specbuf() As Byte    ' a pointer

Public bH As BITMAPINFO     'bitmap header
Public chan As Long
Public URL As Variant
Public TmpNameHold As String
Public TmpNameHold2 As String

'SAVE LOCAL COPY
Public WriteFile As clsFileIo
Public FileIsOpen As Boolean, GotHeader As Boolean
Public DownloadStarted As Boolean, DoDownload As Boolean
Public DlOutput As String, SongNameUpdate As Boolean

'THREADING
Public cthread As Long
Public Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, ByVal lpParameter As Long, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long

'MESSAGE BOX
Public Declare Function MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'display error message
Public Sub Error_(ByVal es As String)
On Error Resume Next

    Call MessageBox(frmconfig.hwnd, es & vbCrLf & vbCrLf & "error code: " & BASS_ErrorGetCode, "Error", vbExclamation)
End Sub

'update stream title from metadata
Sub DoMeta(ByVal meta As Long)
On Error Resume Next

    Dim P As String, tmpMeta As String
    If meta = 0 Then Exit Sub
    tmpMeta = VBStrFromAnsiPtr(meta)
    If ((Mid(tmpMeta, 1, 13) = "StreamTitle='")) Then
        P = Mid(tmpMeta, 14)
        TmpNameHold = Mid(P, 1, InStr(P, ";") - 2)
        
         frmconfig.SSPanel4.Caption = TmpNameHold
        
         
        If TmpNameHold = TmpNameHold2 Then
            'do noting
        Else
            TmpNameHold2 = TmpNameHold
            GotHeader = False
            DownloadStarted = False
        End If
        
         Dim savemp3 As String
         savemp3 = Readini("MUSIC_CAST", "Music_bansong_Recode_Dir")
         DlOutput = savemp3 & RemoveSpecialChar(Mid(P, 1, InStr(P, ";") - 2)) & ".mp3"
    
    
    End If
End Sub

Sub MetaSync(ByVal HANDLE As Long, ByVal channel As Long, ByVal data As Long, ByVal user As Long)
On Error Resume Next

    Call DoMeta(data)
End Sub

Public Sub OpenURL(ByVal clkURL As Long)
'On Error Resume Next

    Dim iRow As Integer
    With frmconfig
        Call BASS_StreamFree(chan)  'close old stream
        Dim MU_ADD As String
        MU_ADD = Readini("MUSIC_CAST", "mUSIC_REC_BANGSONG_WEBADDRESS")
        chan = BASS_StreamCreateURL(MU_ADD, 0, BASS_STREAM_STATUS, AddressOf SUBDOWNLOADPROC, 0)

        If chan = 0 Then
           MsgBox "Stream阑 佬瘤 给沁嚼聪促.", vbCritical, frmconfig.Caption
        Else
            Do
                Dim progress As Long, len_ As Long
                len_ = BASS_StreamGetFilePosition(chan, BASS_FILEPOS_END)
                If (len_ = -1) Then GoTo done 'something's gone wrong! (eg. BASS_Free called)
               
                progress = (BASS_StreamGetFilePosition(chan, BASS_FILEPOS_DOWNLOAD) _
                    - BASS_StreamGetFilePosition(chan, BASS_FILEPOS_CURRENT)) * 100 / len_ ' percentage of buffer filled
               
                
                If (progress > 75) Then Exit Do ' over 75% full, enough
                Call Sleep(10)
            Loop While 1

            Dim icyPTR As Long  'a pointer where ICY info is stored
            Dim tmpICY As String
           
            
            'get the broadcast name and bitrate
            icyPTR = BASS_ChannelGetTags(chan, BASS_TAG_ICY)

            If (icyPTR) Then
                Do
                    tmpICY = VBStrFromAnsiPtr(icyPTR)
                    icyPTR = icyPTR + Len(tmpICY) + 1
                    
                Loop While (tmpICY <> "")
            End If

            Call DoMeta(BASS_ChannelGetTags(chan, BASS_TAG_META))
            Call BASS_ChannelSetSync(chan, BASS_SYNC_META, 0, AddressOf MetaSync, 0)

            'play it!
            Call BASS_ChannelPlay(chan, BASSFALSE)
    End If
  End With
done:
    Call CloseHandle(cthread)   'close the thread
    cthread = 0
End Sub

'The following functions where added by Peter Hebels
Public Sub SUBDOWNLOADPROC(ByVal Buffer As Long, ByVal length As Long, ByVal user As Long)
On Error Resume Next

    If (Buffer And length = 0) Then
        'frm_new_list.listview1.SelectedItem.SubItems(3) = VBStrFromAnsiPtr(buffer) 'display connection status
        'frmmain.Label4.Caption = VBStrFromAnsiPtr(Buffer) '& " bps"
        Exit Sub
    End If

    If (Not DoDownload) Then
        DownloadStarted = False
        Call WriteFile.CloseFile
        Exit Sub
    End If

    If (Trim(DlOutput) = "") Then Exit Sub

    If (Not DownloadStarted) Then
        DownloadStarted = True
        Call WriteFile.CloseFile
        If (WriteFile.OpenFile(DlOutput)) Then
            SongNameUpdate = False
        Else
            
            SongNameUpdate = True
            
            GotHeader = False
        End If
    End If

    If (Not SongNameUpdate) Then
        If (length) Then
            Call WriteFile.WriteBytes(Buffer, length)
        Else
            Call WriteFile.CloseFile
            GotHeader = False
        End If
    Else
        DownloadStarted = False
        Call WriteFile.CloseFile
        GotHeader = False
    End If
End Sub


Public Function RemoveSpecialChar(strFileName As String)
On Error Resume Next

    Dim i As Byte
    Dim SpecialChar As Boolean
    Dim SelChar As String, OutFileName As String

    For i = 1 To Len(strFileName)
        SelChar = Mid(strFileName, i, 1)
        SpecialChar = InStr(":/\?*|<>" & Chr$(34), SelChar) > 0

        If (Not SpecialChar) Then
            OutFileName = OutFileName & SelChar
            SpecialChar = False
        Else
            OutFileName = OutFileName
            SpecialChar = False
        End If
    Next i

    RemoveSpecialChar = OutFileName
End Function


Public Sub UpdateSpectrum()
    Static quietcount As Integer
    Dim X As Long, Y As Long, Y1 As Long
    Dim fft(2048) As Single     ' get the FFT data
    Call BASS_ChannelGetData(chan, fft(0), BASS_DATA_FFT4096)

    If (specmode = 0) Then   ' "normal" FFT
        ReDim specbuf(SPECWIDTH * (SPECHEIGHT + 1)) As Byte  ' clear display
        For X = 0 To (SPECWIDTH / 2) - 1
#If 1 Then
            Y = Sqrt(fft(X + 1)) * 3 * SPECHEIGHT - 4 ' scale it (sqrt to make low values more visible)
#Else
            Y = fft(X + 1) * 10 * SPECHEIGHT ' scale it (linearly)
#End If
            If (Y > SPECHEIGHT) Then Y = SPECHEIGHT 'cap it
            If (X) Then  ' interpolate from previous to make the display smoother
                Y1 = (Y + Y1) / 2
                Y1 = Y1 - 1
                While (Y1 >= 0)
                    specbuf(Y1 * SPECWIDTH + X * 2 - 1) = Y1 + 1
                    Y1 = Y1 - 1
                Wend
            End If
            Y1 = Y
            Y = Y - 1
            While (Y >= 0)
                specbuf(Y * SPECWIDTH + X * 2) = Y + 1 ' draw level
                Y = Y - 1
            Wend
        Next X
    ElseIf (specmode = 1) Then
        ReDim specbuf(SPECWIDTH * (SPECHEIGHT + 1)) As Byte ' clear display
        Dim b0 As Long, BANDS As Integer
        b0 = 0
        BANDS = 28
        Dim sc As Long, b1 As Long
        Dim sum As Single
        For X = 0 To BANDS - 1
            sum = 0
            b1 = 2 ^ (X * 10# / (BANDS - 1))
            If (b1 > 1023) Then b1 = 1023
            If (b1 <= b0) Then b1 = b0 + 1 ' make sure it uses at least 1 FFT bin
            sc = 10 + b1 - b0
            Do
                sum = sum + fft(1 + b0)
                b0 = b0 + 1
            Loop While b0 < b1
            Y = (Sqrt(sum / Log10(sc)) * 1.7 * SPECHEIGHT) - 4 ' scale it
            If (Y > SPECHEIGHT) Then Y = SPECHEIGHT ' cap it
            Y = Y - 1
            While (Y >= 0)
                Call FillMemory(specbuf(Y * SPECWIDTH + X * Int(SPECWIDTH / BANDS)), SPECWIDTH / BANDS - 2, Y + 1)
                Y = Y - 1
            Wend
        Next X
    ElseIf (specmode = 2) Then ' "3D"
        For X = 0 To SPECHEIGHT - 1
            Y = Sqrt(fft(X + 1)) * 3 * 127 ' scale it (sqrt to make low values more visible)
            If (Y > 127) Then Y = 127 ' cap it
            specbuf(X * SPECWIDTH + specpos) = 128 + Y ' plot level
        Next X
        ' move marker onto next position
        specpos = (specpos + 1) Mod SPECWIDTH
        For X = 0 To SPECHEIGHT - 1
            specbuf(X * SPECWIDTH + specpos) = 255
        Next X
    End If

    ' update the display
    ' to display in a PictureBox, simply change the .hDC to Picture1.hDC :)
    Call SetDIBitsToDevice(frmconfig.Picture1.hdc, 0, 0, SPECWIDTH, SPECHEIGHT, 0, 0, 0, SPECHEIGHT, specbuf(0), bH, 0)
   
    If (LoWord(BASS_ChannelGetLevel(chan)) < 500) Then ' check if it's quiet
        quietcount = quietcount + 1
        If (quietcount > 40 And (quietcount And 16)) Then ' it's been quiet for over a second
            Dim sNoise As String
            sNoise = "make some noise!"
            With frmconfig.Picture1
                .ForeColor = vbWhite
                .BackColor = vbWhite
                .CurrentX = (SPECWIDTH - .TextWidth(sNoise)) / 2
                .CurrentY = (SPECHEIGHT - .TextHeight(sNoise)) / 2
                frmconfig.Picture1.Print sNoise
            End With
        End If
    Else
        quietcount = 0 ' not quiet
    End If
End Sub

' Recording callback - not doing anything with the data
Public Function DuffRecording(ByVal HANDLE As Long, ByVal Buffer As Long, ByVal length As Long, ByVal user As Long) As Integer
    DuffRecording = BASSTRUE 'continue recording
End Function

Public Function Sqrt(ByVal num As Double) As Double
    Sqrt = num ^ 0.5
End Function

Function Log10(ByVal X As Double) As Double
    Log10 = Log(X) / Log(10#)
End Function