internet_music.bas

Usb Key loock vb soucrse code. ocx not found

Attribute VB_Name = "internet_Music"
Option Explicit
Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0&    '拿矾 抛捞喉 RGB

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    ' 叼胶敲饭捞 承捞
Public SPECHEIGHT As Long   ' 叼胶敲饭捞 臭捞
Public specmode As Integer, specpos As Integer  '胶蒲飘烦葛靛 汲沥
Public specbuf() As Byte    ' a pointer

Public bh As BITMAPINFO     '厚飘甘 秦靛
Public chan As Long
Public URL As Variant
Public TmpNameHold As String
Public TmpNameHold2 As String

'颇老墨厚 何盒 / 鞘夸绝澜
'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

'静贰靛 汲沥
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

'皋技瘤 冠胶
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

'诀单捞飘 胶蒲飘烦 鸥捞撇 - 皋鸥单捞磐甫 盒籍饶
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.Label8.Caption = TmpNameHold '规价沥焊甫 皋鸥抛捞磐甫 盒籍饶 措涝矫挪促.
         
        If TmpNameHold = TmpNameHold2 Then
            '绢栋茄 巩力啊 惯积窍瘤 臼疽促搁
        Else '巩力啊 惯积沁促搁 秦靛 棺 促款肺靛甫 摧绰促.
            TmpNameHold2 = TmpNameHold
            GotHeader = False
            DownloadStarted = False
        End If
        
        'DlOutput = App.Path & "\" & RemoveSpecialChar(Mid(P, 1, InStr(P, ";") - 2)) & ".mp3"
         Dim savemp3 As String
         savemp3 = Readini("config", "Music_bansong_Recode_Dir")
         DlOutput = savemp3 & RemoveSpecialChar(Mid(P, 1, InStr(P, ";") - 2)) & ".mp3"
         '牢磐齿 澜厩规价狼 免仿何盒阑 mp3颇老肺 历厘窍绰 何盒涝聪促.
         '绢蠢 叼泛配府俊 历厘且巴捞哥, 绢栋茄 mp3颇老疙栏肺 历厘且巴牢啊甫 搬沥钦聪促.
         '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 cast_name As String
       ' cast_name = Readini("MUSIC_CAST", "MUSIC_REC_BANGSONG_WEBADDRESS")
        chan = BASS_StreamCreateURL(CStr(frmconfig.TreeView1.SelectedItem.Child.Text), 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
             '  frmmain.Label5.Caption = "" & progress & "%"
                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
                   ' Popup "沥焊", frmmain.SSPanel1.Caption
                    
                    
                    ' frmmain.SSPanel1.Caption = IIf(Mid(tmpICY, 1, 9) = "icy-name:", Mid(tmpICY, 10), frmmain.SSPanel1.Caption)
                    ' frmmain.Label4.Caption = IIf(Mid(tmpICY, 1, 7) = "icy-br:", Mid(tmpICY, 8), frmmain.Label4.Caption)
                Loop While (tmpICY <> "")
            End If

            'get the stream title and set sync for subsequent titles
            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)
            ' frmmain.Label5.Caption = "规价吝"
            ' frmmain.count_timer.Enabled = True

        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