modcommon.bas

一个无需MP3控件的MP3播放器源码

Attribute VB_Name = "modCommon"
'VB-Amp Pro Common Code
'======================
' These are routines used by the other forms. There are common
' filename manipulation and low-level API calling routines.
' This code also contains the definitions for structures used
' by the API's etc, and declarations for common/public variables
' (such as preference options).
'
'Additional code submitted personally:
'* Tnatsni ([e-mail]):
'   - Snap2ViewPoint, AlwaysOnTop, GetRealEstate
'* [e-mail]:
'   - Volume API calling/variable conversion help
'
'Code found on the web and incorporated:
'* Ben Baird <[e-mail]>:
'   - NotifyIcon, stuff for system tray icon and menu
'---------------------------------------------------------------

'Option Explicit

Public Const SPI_GETWORKAREA& = 48
Public Const WM_MOUSEMOVE = &H200
Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4
Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const MAX_TOOLTIP As Integer = 64
Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const MIXER_SHORT_NAME_CHARS = 16
Public Const MIXER_LONG_NAME_CHARS = 64

'Used for tray icon
Type NOTIFYICONDATA
    cbSize As Long
    hWnd As Long
    uID As Long
    uFlags As Long
    uCallbackMessage As Long
    hIcon As Long
    szTip As String * MAX_TOOLTIP
End Type

'Used for screen functions
Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

'Used for browsing directories
Public Type SHITEMID
  cb      As Long
  abID    As Byte
End Type

'Used for browsing directories
Public Type ITEMIDLIST
  mkid    As SHITEMID
End Type

'Used for browsing directories
Public Type BROWSEINFO
  hOwner          As Long
  pidlRoot        As Long
  pszDisplayName  As String
  lpszTitle       As String
  ulFlags         As Long
  lpfn            As Long
  lParam          As Long
  iImage          As Long
End Type

'Used for region points
Type Coord
  X As Long
  Y As Long
End Type

'Used to store extended coordinate info for skin elements
Type DEx
  X  As Integer 'source
  Y  As Integer
  W  As Integer
  H  As Integer
  X2 As Integer 'dest
  Y2 As Integer
  W2 As Integer
  H2 As Integer
  S  As Integer 'spacing
  F  As Integer 'format
End Type

' Used for Volume Control
Type lVolType
  v As Long
End Type

Type VolType
  LV As Integer
  RV As Integer
End Type


Public Prg As String, Sect As String

Public StartTime As Single, MaxTime As Single
Public Reg_Name As String, Reg_Code As String
Public InActCnt As Integer

Public OptDefPath As String
Public OptCardType As Integer, OptCardPort As Integer
Public OptAlwaysOnTop As Integer, OptSnap As Integer
Public OptAuto As Integer, OptSnooze As Integer, OptSnoozeMd As Integer
Public SnoozeTm As Integer, OptSnoozeAt As String, OptMinOnSnz As Integer
Public OptSkinName As String, OptSkinPath As String, OptSavePos As Integer
Public OptExitMd As Integer, OptStartMd As Integer, OptValExt As String
Public OptStartMin As Integer, OptStartMute As Integer
Public OptStartPlaylist As String, OptVisPLPath As String
Public OptTimeFmt As Integer, OptClrPl As Integer
Public OptAutoPlay As Integer, OptPBOverlap As Integer
Public SkinInfo As String

Public nfIconData As NOTIFYICONDATA

'System tray functions
Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) 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
Public Declare Function SystemParametersInfo Lib "User32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, lpvParam As Any, ByVal fuWinIni As Long) As Long

'Directory browsing functions
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

'Window Region declares
Public Declare Function SetWindowRgn Lib "User32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As Coord, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long
Public Declare Function CreatePolyPolygonRgn Lib "gdi32" (lpPoint As Coord, lpPolyCounts As Long, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long

'Mixer functions
Declare Function waveOutSetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, ByVal dwVolume As Long) As Long
Declare Function waveOutGetVolume Lib "winmm.dll" (ByVal uDeviceID As Long, lpdwVolume As Long) As Long

'Popup menu functions
Declare Function TrackPopupMenu Lib "User32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hWnd As Long, lpReserved As Any) As Long
Declare Function GetMenu Lib "User32" (ByVal hWnd As Long) As Long
Declare Function GetSubMenu Lib "User32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
'

'Sets the specified form to be on top or not
Public Sub AlwaysOnTop(frmForm As Form, fOnTop)
        
    Const HWND_TOPMOST = -1
    Const HWND_NOTOPMOST = -2
        
    Dim lState As Long
    Dim iLeft As Integer, iTop As Integer, iWidth As Integer, iHeight As Integer
    
    With frmForm
        iLeft = .Left / Screen.TwipsPerPixelX
        iTop = .Top / Screen.TwipsPerPixelY
        iWidth = .Width / Screen.TwipsPerPixelX
        iHeight = .Height / Screen.TwipsPerPixelY
    End With
        
    If fOnTop Then
        lState = HWND_TOPMOST
    Else
        lState = HWND_NOTOPMOST
    End If
    Call SetWindowPos(frmForm.hWnd, lState, iLeft, iTop, iWidth, iHeight, 0)
    
End Sub

'Snaps form to edges of screen area
Sub Snap2ViewPoint(ThaForm As Form)
   Dim RC As RECT, Zone As Integer
    
    RC = GetRealEstate
    Zone = 240
    
    'Snap Main Window to Viewpoint
    If OptSnap Then
        If (ThaForm.Top > -Zone) And (ThaForm.Top < Zone) Then ThaForm.Top = 0
        If (ThaForm.Left > -Zone) And (ThaForm.Left < Zone) Then ThaForm.Left = 0
        If (ThaForm.Top + ThaForm.Height > RC.Bottom - Zone) And (ThaForm.Top + ThaForm.Height < RC.Bottom + Zone) Then ThaForm.Top = RC.Bottom - ThaForm.Height - 15
        If (ThaForm.Left + ThaForm.Width > RC.Right - Zone) And (ThaForm.Left + ThaForm.Width < RC.Right + Zone) Then ThaForm.Left = RC.Right - ThaForm.Width
    End If
End Sub

'Find the desktop size
Public Function GetRealEstate() As RECT
    Dim RC As RECT
    Dim R As Long
    Dim Msg As String
    
    R = SystemParametersInfo(SPI_GETWORKAREA, 0&, RC, 0&)

    RC.Left = RC.Left * Screen.TwipsPerPixelX
    RC.Top = RC.Top * Screen.TwipsPerPixelY
    RC.Right = RC.Right * Screen.TwipsPerPixelX
    RC.Bottom = RC.Bottom * Screen.TwipsPerPixelY

    GetRealEstate = RC

End Function

'Determines if the filename is a supported bitmap file
Public Function IsPic(A$) As Boolean
    Dim X$
    
    X$ = UCase$(Right$(A$, 4))
    If X$ = ".BMP" Or X$ = ".GIF" Or X$ = ".JPG" Then
      IsPic = True
    Else
      IsPic = False
    End If
End Function
'Gets the wave out volume from 0% to 100% (ignores balance control)
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 (sets balance to middle)
Public Sub SetVol(Level As Single)
    Dim lVol As lVolType, Vol As VolType, LV As Double, RV As Double
    
    LV = Level * 65535: If LV > 32767 Then LV = LV - 65536
    RV = Level * 65535: 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
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
    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
    J = 0
    While J < I
        Filename = Dir(SubFolderName(J))
        Do Until Filename = ""
            DoEvents
            Ext = UCase$(GetExtension(Filename))
            If InStr(ValExt, 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


Private Function vbGetBrowseDirectory(ThaForm As Long, Msg As String) As String

    Dim bi As BROWSEINFO
    Dim IDL As ITEMIDLIST
    
    Dim R As Long
    Dim pidl As Long
    Dim tmpPath As String
    Dim 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(tmpPath$) 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
Function GetFileName(ByVal Filename$) 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
Function GetExtension(ByVal Filename$) 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
Function GetBaseName(ByVal Filename$) 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
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 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)
Public Function MakeTitle(ByVal A$) As String
    Dim p As Integer, L As Integer, SS As Integer
    Dim J As Integer, T$
    
    p = Len(A$): L = p + 1: SS = 1
    For J = 1 To p
        T$ = Mid$(A$, J, 1)
        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
        If T$ = "\" Then SS = J + 1
    Next J
    
    T$ = Mid$(A$, SS, L - SS)
    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
  
    MakeTitle = LTrim$(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$ = RTrim$(Mid$(A$, v * W + 1, W))
End Function