www.pudn.com > mima.zip > modCommon.bas
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 (tnatsni@usa.net):
' - Snap2ViewPoint, AlwaysOnTop, GetRealEstate
'* zumzum@hotmail.com:
' - Volume API calling/variable conversion help
'
'Code found on the web and incorporated:
'* Ben Baird :
' - 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