modcommon.bas

一个类似于WinAmp的Mp3播放器,功能不错,有换肤等功能,是一个不错的vb播放器.

    If Exists(F & Ext) = True Then A = F & Ext
    Return
 
End Function

'Gets the wave out volume from 0% to 100% (ignores balance control)从 0% 到 100% 出自体积拿波 (忽视指述余款控制)
Public Function GetVol() As Single
    Dim lVol As lVolType, Vol As VolType, LV As Double, RV As Double
    
    waveOutGetVolume 0, V    'read the current value读了现在的值
    
    lVol.V = V
    LSet Vol = lVol
    LV = Vol.LV: If LV < 0 Then LV = 65535 + LV
    RV = Vol.RV: If RV < 0 Then RV = 65535 + RV
    If RV > LV Then LV = RV
    
    GetVol = LV / 65535 'Convert to percent转换到百分比
    
End Function

'Sets the wave out volume from 0 to 1 (uses balance 0 to 1)从 0 到 1 出自体积设定波 ( 使用平衡 0 到 1)
Public Sub SetVol(Pct As Single)
    Dim lVol As lVolType, Vol As VolType, LV As Double, RV As Double
    Dim LB As Single, RB As Single
    
    RB = 1: If Balance < 0.45 Then RB = 1 - (0.5 - Balance) * 2 'Right Balance
    LB = 1: If Balance > 0.55 Then LB = 1 - (Balance - 0.5) * 2 'Left Balance左边的平衡
    
    LV = Pct * 65535 * LB: If LV > 32767 Then LV = LV - 65536
    RV = Pct * 65535 * RB: If RV > 32767 Then RV = RV - 65536
    Vol.LV = LV
    Vol.RV = RV
    LSet lVol = Vol
    V = lVol.V
    
    waveOutSetVolume 0, V

End Sub

'Add directory entries to playlist增加目录到 playlist
Public Sub AddDir(BrowseDir As String, ThaForm As Form, SongNames As ListBox, SongPaths As ListBox, ValExt As String)
    
    Dim TmpStr As String, Ext As String, VExt As String
    Dim SubFolderName() As String, Filename As String
    Dim i As Integer, J As Integer, p As Integer
        
    TmpStr = ValidateDir(BrowseDir): If TmpStr = "" Then Exit Sub
    
    'Loop through for subdirectory names and put into array将子目录名字放入数组

    ReDim Preserve SubFolderName(i)
    SubFolderName(0) = TmpStr
    i = 1
    J = 0
    
    While J < i
        Filename = Dir(SubFolderName(J), vbDirectory)
        Do Until Filename = ""
            DoEvents
            If (GetAttr(SubFolderName(J) & Filename) And vbDirectory) = vbDirectory Then  ' it represents a directory.
                If Filename <> "." And Filename <> ".." And Filename <> TmpStr Then
                    ReDim Preserve SubFolderName(i)
                    SubFolderName(i) = SubFolderName(J) & Filename & "\"
                    i = i + 1
                End If
            End If
            Filename = Dir
        Loop
        J = J + 1
    Wend
        
    'Loop through sub-folders and add files with matching extensions to playlist环经过子文件夹而且用相配对 playlist 的延长文件
    VExt = UCase$(ValExt)
    J = 0
    While J < i
        Filename = Dir(SubFolderName(J))
        Do Until Filename = ""
            DoEvents
            Ext = UCase$(GetExtension(Filename))
            If InStr(VExt, Ext) > 0 Then
                SongNames.AddItem MakeTitle(GetBaseName(Filename))
                SongPaths.AddItem SubFolderName(J) & Filename
            End If
            Filename = Dir
        Loop
        J = J + 1
    Wend

End Sub
'Display "Browse for folder" window with message header显示"为文件夹浏览" 和信息首领的窗户
Public Function GetBrowseDir(ThaForm As Form, Msg As String) As String
            
    GetBrowseDir = vbGetBrowseDirectory(ThaForm.hwnd, Msg)
    
End Function
Public Function vbGetBrowseDirectory(ThaForm As Long, Msg As String) As String

    Dim bi As BROWSEINFO
    Dim IDL As ITEMIDLIST
    
    Dim R As Long, pidl As Long, tmpPath As String, pos As Integer
    
    bi.hOwner = ThaForm
    bi.pidlRoot = 0&
    bi.lpszTitle = Msg
    bi.ulFlags = BIF_RETURNONLYFSDIRS
    
   'get the folder获得文件夹
    pidl = SHBrowseForFolder(bi)
    
    tmpPath = Space$(512)
    R = SHGetPathFromIDList(ByVal pidl, ByVal tmpPath)
      
    If R Then
        pos = InStr(tmpPath, Chr(0))
        tmpPath = Left(tmpPath, pos - 1)
        vbGetBrowseDirectory = ValidateDir(tmpPath)
    Else
        vbGetBrowseDirectory = ""
    End If

End Function

' Add trailing \ to path if needed (except null paths)增加拖 \ 到路径如果需要的 (除了无效力的路径以外)
Function ValidateDir(ByVal tmpPath As String) As String

    If Right(tmpPath, 1) = "\" Then
        ValidateDir = tmpPath
    Else
        If tmpPath <> "" Then
            ValidateDir = tmpPath & "\"
        Else
            ValidateDir = ""
        End If
    End If

End Function

'Return the Filename part of the filespec返回 filespec 的 文件名部份
Function GetFileName(ByVal Filename As String) As String
    Dim L As Integer, J As Integer
    
    L = Len(Filename)
    For J = L To 1 Step -1
        If Mid(Filename, J, 1) = "\" Then Exit For
    Next J
    
    GetFileName = Mid(Filename, J + 1)
    
End Function

'Return the Extension part of the filespec返回 filespec 的 延长部份
Function GetExtension(ByVal Filename As String) As String
    Dim L As Integer, J As Integer
    
    L = Len(Filename)
    For J = L To 1 Step -1
        If Mid(Filename, J, 1) = "." Then Exit For
    Next J
    
    GetExtension = Mid(Filename, J + 1)
    
End Function

'Return the Path and Filename parts from Filespec返回 filespec 的路径和文件名部份
Function GetBaseName(ByVal Filename As String) As String
    Dim L As Integer, J As Integer
    
    L = Len(Filename)
    For J = L To 1 Step -1
        If Mid(Filename, J, 1) = "." Then Exit For
    Next J
    
    GetBaseName = Left(Filename, J - 1)
    
End Function

'Extracts the Path from a filespec获取filespec 的路径
Public Function GetPath(ByVal Filename As String) As String
    Dim p As Integer, J As Integer
    
    p = 0
    For J = Len(Filename) To 1 Step -1
        If Mid(Filename, J, 1) = "\" Then p = J: Exit For
    Next
    If p > 0 Then GetPath = Left$(Filename, p) Else GetPath = ""
    
End Function

' Check if a file exists检查一个文件是否存在
Public Function Exists(ByVal Filename As String) As Boolean
      
    On Local Error GoTo ExErr
    
    Exists = False
    If Filename <> "" Then
        If Dir(Filename) <> "" Then Exists = True
    End If
    Exit Function

ExErr:
End Function

'Convert filename to friendly name (remove extra characters etc)将 filename 转换成友好的名字 ( 距离额外的个性及其他)
Public Function MakeTitle(ByVal A As String) As String
    Dim p As Integer, L As Integer, SS As Integer
    Dim J As Integer, T As String
    
    p = Len(A): L = p + 1: SS = 1
    For J = 1 To p
    'Mid(字符串,从第几个字符开始,取字符的长度)
        T = Mid(A, J, 1)
        If OptFriendly > 0 Then
            If T = "_" Then Mid(A, J, 1) = " "
            If T = "." Then
                'is it extension or just period in name?它是名字的延长或正直的时期吗?
                If J > p - 5 Then L = J Else Mid(A, J, 1) = " "
            End If
        End If
        If T = "\" Then SS = J + 1
    Next J
    
    T = Mid(A, SS, L - SS)
    If OptFriendly > 0 Then
        If Val(T) > 0 Then
            'remove track number距离轨道数字
            If Mid(T, 3, 1) = "-" Then T = Mid(T, 4)
            If Mid(T, 3, 2) = " -" Then T = Mid(T, 5)
        End If
    End If
  
    MakeTitle = Trim(T) 'remove spaces距离空间
  
End Function

'Lookup in string table using bit(s) in byte as offset
Function LTable$(n As Byte, B1 As Integer, B2 As Integer, W As Integer, A$)
    Dim Power As Integer, V As Integer, J As Integer
    'N=byte to look in, B1=first bit, B2=second bit
    'W=Width of each entry in string, A$=the string table
    V = 0
    For J = B1 To B2
        Power = 2 ^ J
        If (n And Power) = Power Then V = V + Power
    Next J
    V = V \ (2 ^ B1) 'shift
    LTable$ = Trim$(Mid$(A$, V * W + 1, W))
End Function

' Process bitmap and return a region that does not include pixels of the specified color
Public Function GetBitmapRegion(cPicture As StdPicture, cTransparent As Long)

    Dim hRgn As Long, tRgn As Long
    Dim X As Integer, Y As Integer, X0 As Integer
    Dim hDC As Long, BM As BITMAP
    
    hDC = CreateCompatibleDC(0) 'Create a new memory DC, where we will scan the picture
    
    If hDC Then
        SelectObject hDC, cPicture 'Let the new DC select the Picture
        'Get the Picture dimensions and create a new rectangular region
        GetObject cPicture, Len(BM), BM
        hRgn = CreateRectRgn(0, 0, BM.bmWidth, BM.bmHeight)
        
        'Start scanning the picture from top to bottom
        For Y = 0 To BM.bmHeight
            For X = 0 To BM.bmWidth
                'Scan a line of non transparent pixels
                While X <= BM.bmWidth And GetPixel(hDC, X, Y) <> cTransparent
                    X = X + 1
                Wend
                
                X0 = X 'Mark the start of a line of transparent pixels
                
                'Scan a line of transparent pixels
                While X <= BM.bmWidth And GetPixel(hDC, X, Y) = cTransparent
                    X = X + 1
                Wend
                
                'Create a new Region that corresponds to the row of
                'Transparent pixels and then remove it from the main Region
                If X0 < X Then
                    tRgn = CreateRectRgn(X0, Y, X, Y + 1)
                    CombineRgn hRgn, hRgn, tRgn, 4
                    DeleteObject tRgn 'Free the memory used by the new temporary Region
                End If
            Next X
        Next Y
        GetBitmapRegion = hRgn 'Return the memory address to the shaped region
        DeleteObject SelectObject(hDC, cPicture) 'Free memory by deleting the Picture
    End If
    DeleteDC hDC 'Free memory by deleting the created DC
End Function