(舊) 다음 뮤직(BGM Shop) 핵

이것도 현재 개편이되어 이방법은 먹히질 않습니다.

소스가 더럽네요;;

그것도 저급언어;;

몇년전에 만든거라서

Dim CurrentPage As Integer


Private Sub cmdNext_Click()
    On Error Resume Next
    CurrentPage = CurrentPage + 1
    lstSong.ListItems.Clear
    Dim htMl As String, curSng As Song
    htMl = ctrlWeb1.GetSite("http://mall.planet.daum.net/mall/ItemShop/SearchBGM.jsp?type=BGM&searchCategory=" & SearType & "&keyword=" & URLEncode(txtEnT.Text) & "&page=" & CurrentPage, "GET", "Referer: http://mall.planet.daum.net/mall/ItemShop/BGM.jsp")
    htMl = Mid(htMl, InStr(htMl, ""), Len(htMl))
    
    Do Until InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") = 0
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        curSng.Number = Replace(Mid(htMl, 1, InStr(htMl, Chr(34)) - 1), "&cateid=", "")
        htMl = Mid(htMl, InStr(htMl, "title=" & Chr(34)) + Len("title=" & Chr(34)), Len(htMl))
        curSng.Title = Mid(htMl, 1, InStr(htMl, Chr(34)) - 1)
        htMl = Mid(htMl, InStr(htMl, "") + Len(""), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "title=" & Chr(34)) + Len("title=" & Chr(34)), Len(htMl))
        curSng.Artist = Mid(htMl, 1, InStr(htMl, Chr(34)) - 1)
        lstSong.ListItems.Add(, ":" & curSng.Number, curSng.Title).SubItems(1) = curSng.Artist
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
    Loop
    
    htMl = ctrlWeb1.GetSite("http://mall.planet.daum.net/mall/ItemShop/SearchBGM.jsp?type=BGM&searchCategory=BY_ARTIST&keyword=" & URLEncode(txtEnT.Text) & "&page=" & CurrentPage, "GET", "Referer: http://mall.planet.daum.net/mall/ItemShop/BGM.jsp")
    htMl = Mid(htMl, InStr(htMl, ""), Len(htMl))

    lbPage = Format(CurrentPage, "00#")
    
    
End Sub

Private Sub cmdPrev_Click()
    On Error Resume Next
    If CurrentPage = 1 Then: MsgBox "처음 페이지 입니다.", vbCritical, "알림": Exit Sub
    CurrentPage = CurrentPage - 1
    lstSong.ListItems.Clear
    Dim htMl As String, curSng As Song
    htMl = ctrlWeb1.GetSite("http://mall.planet.daum.net/mall/ItemShop/SearchBGM.jsp?type=BGM&searchCategory=" & SearType & "&keyword=" & URLEncode(txtEnT.Text) & "&page=" & CurrentPage, "GET", "Referer: http://mall.planet.daum.net/mall/ItemShop/BGM.jsp")
    htMl = Mid(htMl, InStr(htMl, ""), Len(htMl))
    
    Do Until InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") = 0
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        curSng.Number = Replace(Mid(htMl, 1, InStr(htMl, Chr(34)) - 1), "&cateid=", "")
        htMl = Mid(htMl, InStr(htMl, "title=" & Chr(34)) + Len("title=" & Chr(34)), Len(htMl))
        curSng.Title = Mid(htMl, 1, InStr(htMl, Chr(34)) - 1)
        htMl = Mid(htMl, InStr(htMl, "") + Len(""), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "title=" & Chr(34)) + Len("title=" & Chr(34)), Len(htMl))
        curSng.Artist = Mid(htMl, 1, InStr(htMl, Chr(34)) - 1)
        lstSong.ListItems.Add(, ":" & curSng.Number, curSng.Title).SubItems(1) = curSng.Artist
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        
    Loop
    
    lbPage = Format(CurrentPage, "00#")
    
    
End Sub

Private Sub Command1_Click()
    fDummy.Show
    
End Sub

Private Sub Form_Load()
    On Error Resume Next

    lstSong.ColumnHeaders(1).Width = (lstSong.Width / 3) * 2
    lstSong.ColumnHeaders(2).Width = lstSong.Width / 3
    searchType.ComboItems.Add , , "제목"
    searchType.ComboItems.Add , , "가수"
    searchType.ComboItems.Add , , "앨범"


End Sub

Private Sub Label2_Click()
fDummy.Show

End Sub

Private Sub Label1_Click()
Shell "explorer http://youdie.net/"

End Sub

Private Sub lstSong_ItemClick(ByVal Item As MSComctlLib.ListItem)
On Error GoTo errType
    fDownLoad.Show
    fDownLoad.lstDown.ListItems.Add(, Item.Key, Item.Text & "-" & Item.SubItems(1)).Checked = True
'    fBeta.Show
'    fBeta.sngNumber = Mid(Item.Key, 2, Len(Item.Key))
'
Exit Sub
errType:
    If Err.Number = 35602 Then
        MsgBox "이미 추가되어있는 곡입니다.", vbInformation, "알림"
    End If
End Sub

Private Sub txtEnT_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    On Error Resume Next
    CurrentPage = 1
    lstSong.ListItems.Clear
    Dim htMl As String, curSng As Song
    htMl = ctrlWeb1.GetSite("http://mall.planet.daum.net/mall/ItemShop/SearchBGM.jsp?type=BGM&searchCategory=" & SearType & "&keyword=" & URLEncode(txtEnT.Text), "GET", "Referer: http://mall.planet.daum.net/mall/ItemShop/BGM.jsp")
    htMl = Mid(htMl, InStr(htMl, ""), Len(htMl))
    
    Do Until InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") = 0
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        curSng.Number = Replace(Mid(htMl, 1, InStr(htMl, Chr(34)) - 1), "&cateid=", "")
        htMl = Mid(htMl, InStr(htMl, "title=" & Chr(34)) + Len("title=" & Chr(34)), Len(htMl))
        curSng.Title = Mid(htMl, 1, InStr(htMl, Chr(34)) - 1)
        htMl = Mid(htMl, InStr(htMl, "") + Len(""), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "title=" & Chr(34)) + Len("title=" & Chr(34)), Len(htMl))
        curSng.Artist = Mid(htMl, 1, InStr(htMl, Chr(34)) - 1)
        lstSong.ListItems.Add(, ":" & curSng.Number, curSng.Title).SubItems(1) = curSng.Artist
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
        htMl = Mid(htMl, InStr(htMl, "/mall/ItemShop/oneNone.jsp?prod_seq=") + Len("/mall/ItemShop/oneNone.jsp?prod_seq="), Len(htMl))
    Loop

    lbPage = Format(CurrentPage, "00#")
    
End If
End Sub

Function SearType() As String
    On Error Resume Next
    Select Case searchType.Text
    Case "제목"
        SearType = "BY_NAME"
    Case "가수"
        SearType = "BY_ARTIST"
    Case "앨범"
        SearType = "BY_ALBUMNAME"
    End Select
End Function

다운로드 부분

Dim DwnHeader As String
Private Declare Sub SetLastError Lib "kernel32" (ByVal dwErrCode As Long)
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Const PBM_SETBARCOLOR = &H409
Const PBM_SETBKCOLOR = &H2001
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_DONTGOBELOWDOMAIN = 2
Private Const MAX_PATH = 260
Private Declare Function SHBrowseForFolder Lib "shell32" (lpBI As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Type BrowseInfo
   hwndOwner      As Long
   pIDLRoot       As Long
   pszDisplayName As Long
   lpszTitle      As Long
   ulFlags        As Long
   lpfnCallback   As Long
   lParam         As Long
   iImage         As Long
End Type

Function ReciveFolder() As String

   Dim lpIDList As Long
   Dim sBuffer As String
   Dim szTitle As String
   Dim tBrowseInfo As BrowseInfo

   szTitle = "음악을 저장할 곳을 선택하세요."
   With tBrowseInfo
      .hwndOwner = Me.hWnd
      .lpszTitle = lstrcat(szTitle, "")
      .ulFlags = BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN
   End With

   lpIDList = SHBrowseForFolder(tBrowseInfo)

   If (lpIDList) Then
      sBuffer = Space(MAX_PATH)
      SHGetPathFromIDList lpIDList, sBuffer
      sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
      SaveSetting "ComeMusic", "Dir", "Path", sBuffer
      ReciveFolder = sBuffer
   End If

End Function



Function isRunning(curPID As Long) As Boolean
    Dim ret&
    If curPID = 0 Then
    Else
        SetLastError 0
        ret = OpenProcess(1, 0, curPID)
        If Err.LastDllError = 0& Then
            CloseHandle ret
            isRunning = True
        End If
    End If
End Function

Private Sub cmdDown_Click()
On Error GoTo erTab
cmdDown.Enabled = False
cmdMore.Enabled = False

If Dir(txtPath.Text, vbDirectory) = "" Or txtPath.Text = "" Then
    MsgBox "저장 폴더가 존재하지 않습니다.", vbExclamation, "다운로드"
    GoTo EndOfWork
End If

Dim wN As Integer

Do
in_Rabel:
    
    wN = wN + 1
    
    If lstDown.ListItems.Count < wN Then: GoTo EndOfWork
    
    If lstDown.ListItems(wN).SubItems(1) = "완료." Then
        GoTo Skip_Rabel
    End If
    
    lstDown.ListItems(wN).Tag = "ing"
    lstDown.ListItems(wN).ForeColor = RGB(255, 204, 51)
    
    lstDown.ListItems.Item(wN).SubItems(1) = "다운로드 준비중..."
    Dim rBuffer As String, fURL As String
    IGet.Execute "http://mall.planet.daum.net/mall/bgm/preview.jsp?prodSeq=" & Mid(lstDown.ListItems.Item(wN).Key, 2, Len(lstDown.ListItems.Item(wN).Key)), , , DwnHeader
    
    Do Until IGet.StillExecuting = False: DoEvents: Loop
    rBuffer = IGet.GetChunk(False, icString)
    rBuffer = Mid(rBuffer, InStr(rBuffer, "") - 1)
    rBuffer = Mid(rBuffer, InStr(rBuffer, "") + Len(""), Len(rBuffer))
    'lArti.Caption = Mid(rBuffer, 1, InStr(rBuffer, "") - 1)
    rBuffer = Mid(rBuffer, InStr(rBuffer, ""))
    Const SEND_DATA_SIZE As Long = 64
    Dim fName As String, tName As String
    Dim hFile As Integer, TempFileLen As Long, lDownloadeD As Long, FileLens As Long
    Dim Buffer() As Byte
    tName = ""
    hFile = 0:    TempFileLen = 0:    lDownloadeD = 0:    FileLens = 0:    Erase Buffer:    fName = ""
    iFile.Cancel
    iFile.Execute fURL, "GET"
    Do Until iFile.StillExecuting = False: DoEvents: Loop

    TempFileLen = CLng(iFile.GetHeader("Content-Length"))

    FileLens = TempFileLen

    hFile = FreeFile
    
    tName = Format(Now, "DDHHMMSS")
    lstDown.ListItems.Item(wN).SubItems(1) = "다운로드중... "
    Pr.Value = 0
    Pr.Max = FileLens / 10
    Open txtPath.Text & "\" & tName & ".wma" For Binary Access Write As #hFile
        Do While FileLens >= lDownloadeD
            Buffer() = iFile.GetChunk(SEND_DATA_SIZE, icByteArray)
            Put #hFile, , Buffer
            lDownloadeD = lDownloadeD + SEND_DATA_SIZE
            ' (lDownloadeD / FileLens) * 100 & "%"
            On Error Resume Next
            Pr.Value = (lDownloadeD / 10) - 64
            On Error GoTo erTab
            DoEvents
        Loop
    Close #hFile

    If lstDown.ListItems.Item(wN).Checked Then
        lstDown.ListItems.Item(wN).SubItems(1) = "변환중.. 1/3"
        Dim pId As Long
        pId = Shell(App.Path & "\ffmpeg.exe -i " & Chr(34) & txtPath.Text & "\" & tName & ".wma" & Chr(34) & " -vn -f wav " & Chr(34) & txtPath.Text & "\" & tName & ".wav" & Chr(34), vbHide)
        Do Until isRunning(pId) = False
            DoEvents
        Loop
        lstDown.ListItems.Item(wN).SubItems(1) = "변환중.. 2/3"
        Kill txtPath.Text & "\" & tName & ".wma"
        pId = Shell(App.Path & "\lame.exe -V 6 " & Chr(34) & txtPath.Text & "\" & tName & ".wav" & Chr(34) & " " & Chr(34) & txtPath.Text & "\" & FixFileName(lstDown.ListItems.Item(wN).Text) & ".mp3" & Chr(34), vbHide)
        Do Until isRunning(pId) = False
            DoEvents
        Loop
        Kill txtPath.Text & "\" & tName & ".wav"
    Else
        Name txtPath.Text & "\" & tName & ".wma" As txtPath.Text & "\" & FixFileName(lstDown.ListItems.Item(wN).Text) & ".wma"
    End If
    lstDown.ListItems(wN).Tag = ""
    lstDown.ListItems.Item(wN).SubItems(1) = "완료."
    lstDown.ListItems(wN).ForeColor = vbBlue
Skip_Rabel:
Loop



EndOfWork:
cmdDown.Enabled = True
cmdMore.Enabled = True
iFile.Cancel
Exit Sub
erTab:
lstDown.ListItems(wN).SubItems(1) = "실패 : " & Err.Number
lstDown.ListItems(wN).ForeColor = vbRed
GoTo in_Rabel
End Sub

Private Sub cmdMore_Click()
txtPath.Text = ReciveFolder
End Sub

Private Sub Form_Load()
On Error Resume Next
mnuItem.Visible = False
lstDown.ColumnHeaders(1).Width = (lstDown.Width / 3) * 2
lstDown.ColumnHeaders(2).Width = lstDown.Width / 3
DwnHeader = "Accept: */*" & vbCrLf & "User-Agent: Windows-Media-Player/10.00.00.3319" & vbCrLf & "UA-CPU: x86" & vbCrLf & _
"Host: mall.planet.daum.net" & vbCrLf
txtPath.Text = GetSetting("ComeMusic", "Dir", "Path", App.Path)

    PostMessage Pr.hWnd, PBM_SETBARCOLOR, 0, RGB(255, 204, 51)
    PostMessage Pr.hWnd, PBM_SETBKCOLOR, 0, RGB(0, 0, 0)
End Sub

Function FixFileName(chFile As String) As String
On Error Resume Next
        chFile = Replace(chFile, "\", "_")
        chFile = Replace(chFile, "/", "_")
        chFile = Replace(chFile, "<", "_")
        chFile = Replace(chFile, ">", "_")
        chFile = Replace(chFile, "|", "_")
        chFile = Replace(chFile, "*", "_")
        chFile = Replace(chFile, ":", "_")
        chFile = Replace(chFile, "?", "_")
        FixFileName = Replace(chFile, Chr(34), "_")
End Function

Private Sub lstDown_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo fcError
If Button <> 2 Then: Exit Sub
Dim test As String: test = lstDown.SelectedItem.Text
If lstDown.ListItems(wN).Tag = "ing" Then: Exit Sub

PopupMenu mnuItem
Exit Sub
fcError:

End Sub