module1.bas

一个mp3播放器的源码

Attribute VB_Name = "Module1"
Option Explicit

Public Type NOTIFYICONDATA '任务栏图标结构
   cbSize As Long
   hwnd As Long
   uId As Long
   uFlags As Long
   uCallBackMessage As Long
   hIcon As Long
   szTip As String * 64
End Type

'包含函数： GetDlgSelectFileInfo
'函数功能： 获取从CommonDialog中选取的文件信息

'自定义类型，用于DlgSelectFileInfo函数
Type DlgFileInfo
    iCount As Long
    sPath As String
    sFile() As String
End Type


Public Const NIM_ADD = &H0 '增加图标
Public Const NIM_MODIFY = &H1  '编辑图标
Public Const NIM_DELETE = &H2  '删除图标

Public Const WM_MOUSEMOVE = &H200

Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4

Public bModiFileListFlag As Boolean '文件列表是否被修改标志
Public bDbClickItemFlag As Boolean  '文件列表是否被双击
Public nPlayFileCount As Integer   '正在播放的文件的序号
Public bFileList As Boolean '文件列表是否为空标志
Public cFileNameList() As String    '文件名数组
Public cFilePathList() As String    '文件路径数组
Public nScreenCount As Integer  '界面及背景结构
Public nBackColor As Long
Public nListColor As Long
Public nFontColor As Long

Public Const WM_LBUTTONDBLCLK = &H203   '鼠标左键双击
Public Const WM_LBUTTONDOWN = &H201     '鼠标左键按下
Public Const WM_LBUTTONUP = &H202       '鼠标左键抬起

Public Const WM_RBUTTONDBLCLK = &H206   '鼠标右键双击
Public Const WM_RBUTTONDOWN = &H204     '鼠标右键按下
Public Const WM_RBUTTONUP = &H205       '鼠标右键抬起

Public Const WM_NCLBUTTONDOWN = &HA1
Public Const HTCAPTION = 2

Public Const SW_SHOWNORMAL = 1
Public Const SW_SHOWMINIMIZED = 2

Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1

Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As NOTIFYICONDATA) As Boolean
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub ReleaseCapture Lib "user32" ()


Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Declare Function SetWindowPos Lib "user32" _
         (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, _
          ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Declare Function ShellExecute Lib "shell32.dll" 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
Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Function PutWindowOnTop(pFrm As Form, bOnTopFlag As Boolean)
    Dim lngWindowPosition As Long
    Dim HWND_TOPMOST As Integer
    If bOnTopFlag = True Then
        HWND_TOPMOST = -1
    Else
        HWND_TOPMOST = 1
    End If
  
    lngWindowPosition = SetWindowPos(pFrm.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
End Function

Function GetFileList()
    
    Dim i As Integer, j As Integer
    Dim nCount As Integer
    Dim nReturn As Long
    
    Dim cFileName As String
    Dim cFilePath As String

    Dim cString As String * 255
    Dim cFileListItem() As String
    
    nScreenCount = -1000
    nBackColor = -1000
    nListColor = -1000
    nFontColor = -1000
    
    If Dir(App.Path & "\Filelist.lst") <> "" Then
        
        nCount = GetPrivateProfileInt("FileCount", "Count", nReturn, App.Path & "\Filelist.lst")
        
        If nCount > 0 Then
        
            If nCount > 300 Then
                nCount = 300
            End If
            
            j = nCount
            ReDim cFileListItem(nCount)
            
            For i = 1 To nCount
                cString = String(255, Chr(32))
                GetPrivateProfileString "Item", "File" & i, "", cString, Len(cString), App.Path & "\Filelist.lst"
                If Len(Trim(cString)) > 7 And InStr(1, Trim(cString), ".mp", 1) > 0 Then
                    cFileListItem(i) = Trim(cString)
                Else
                    j = j - 1
                End If
            Next i
            
            If j > 0 Then
                ReDim cFileNameList(j)
                ReDim cFilePathList(j)
                bFileList = True
                
                j = 1
                For i = 1 To nCount
                    If Len(Trim(cFileListItem(i))) > 7 Then
                        cFileName = ""
                        cFilePath = ""

                        File_NamePath Trim(cFileListItem(i)), cFileName, cFilePath
                        cFileNameList(j) = cFileName
                        cFilePathList(j) = cFilePath
                        j = j + 1
                    End If
                Next i
            End If
        Else
            bFileList = False
        End If
        
        cString = String(255, Chr(32))
        GetPrivateProfileString "Screen", "nScreenCount", "", cString, Len(cString), App.Path & "\Filelist.lst"
        If IsNumeric(Trim(cString)) = True Then
            nScreenCount = CLng(cString)
        End If
        
        cString = String(255, Chr(32))
        GetPrivateProfileString "Screen", "nBackColor", "", cString, Len(cString), App.Path & "\Filelist.lst"
        If IsNumeric(Trim(cString)) = True Then
            nBackColor = CLng(cString)
        End If
        
        cString = String(255, Chr(32))
        GetPrivateProfileString "Screen", "nListColor", "", cString, Len(cString), App.Path & "\Filelist.lst"
        If IsNumeric(Trim(cString)) = True Then
            nListColor = CLng(cString)
        End If

        cString = String(255, Chr(32))
        GetPrivateProfileString "Screen", "nFontColor", "", cString, Len(cString), App.Path & "\Filelist.lst"
        If IsNumeric(Trim(cString)) = True Then
            nFontColor = CLng(cString)
        End If
        
    Else
        bFileList = False
    End If
End Function

'功能：     返回CommonDialog所选择的文件数量和文件名
'参数说明:  strFileName是CommonDialog.Filename
'函数类型:  DlgFileInfo。这是一个自定义类型，声明如下：
'               Type DlgFileInfo
'                   iCount As Long
'                   sPath As String
'                   sFile() As String
'               End Type
'           其中，iCount为选择文件的数量，sPath为所选文件的路径，sFile()为所选择的文件名
'注意事项:  在CommonDialog.ShowOpen后立即使用，以免当前路径被更改
'           在打开了*.pif文件后须将Filename属性置空，否则当选取多个*.pif文件后，当前路径会改变会
'           在CommonDialong.Flags属性中使用cdlOFNNoDereferenceLinks风格，就可以正确的返回*.pif文件的文件名了

Function GetDlgSelectFileInfo(strFilename As String) As DlgFileInfo
    
    '思路： 用CommonDialog控件选择文件后，其Filename属性值如下：
    '       1、如果选择的是"C:\Test.txt"，  Filename="C:\Test.txt"，    CurDir()="C:\"
    '       2、如果选择的是"C:\1\Test.txt"，Filename="C:\1\Test.txt"，  CurDir()="C:\1"
    '       3、如果选择的是"C:\1.txt"和"C:\2.txt"，则：
    '                                   Filename="C:\1 1.txt 2.txt"，  CurDir()="C:\1"
    '       因此先将路径分离开，再利用多文件之间插入的Chr$(0)字符分解各个文件名即可。
    
    Dim sPath, tmpStr As String
    Dim sFile() As String
    Dim iCount As Integer
    Dim i As Integer
        
    If Len(Trim(strFilename)) > 7 Then
        sPath = CurDir()  '获得当前的路径，因为在CommonDialog中改变路径时会改变当前的Path
        tmpStr = Right$(strFilename, Len(strFilename) - Len(sPath)) '将文件名分离出来
        
        If Left$(tmpStr, 1) = Chr$(0) Then
            '选择了多个文件(表现为第一个字符为空格)
            For i = 1 To Len(tmpStr)
                If Mid$(tmpStr, i, 1) = Chr$(0) Then
                    iCount = iCount + 1
                    ReDim Preserve sFile(iCount)
                Else
                    sFile(iCount) = sFile(iCount) & Mid$(tmpStr, i, 1)
                End If
            Next i
        Else
            '只选择了一个文件(注意：根目录下的文件名除去路径后没有"\"）
            iCount = 1
            ReDim Preserve sFile(iCount)
            If Left$(tmpStr, 1) = "\" Then tmpStr = Right$(tmpStr, Len(tmpStr) - 1)
            sFile(iCount) = tmpStr
        End If
        
        GetDlgSelectFileInfo.iCount = iCount
        ReDim GetDlgSelectFileInfo.sFile(iCount)
        
        If Right$(sPath, 1) <> "\" Then sPath = sPath & "\"
        GetDlgSelectFileInfo.sPath = sPath
        
        For i = 1 To iCount
            GetDlgSelectFileInfo.sFile(i) = sFile(i)
        Next i
    End If
End Function

Function File_NamePath(cFileFullPath As String, cFileName As String, cFilePath As String)   '分离文件名和路径
    
    Dim j As Integer
    Dim nStart As Integer
    
    nStart = Len(Trim(cFileFullPath))
        
    For j = Len(Trim(cFileFullPath)) To 1 Step -1
        If InStr(j, Trim(cFileFullPath), "\") > 0 Then
            nStart = j
            Exit For
        End If
    Next j
    
    cFileName = Right(Trim(cFileFullPath), Len(Trim(cFileFullPath)) - nStart)
    cFilePath = Left(Trim(cFileFullPath), nStart - 1)
    
End Function

Sub Main()
    PlayMp3.Show
End Sub