www.pudn.com > m020_vbamp.zip > frmVBAmp.frm
VERSION 5.00
Object = "{C1A8AF28-1257-101B-8FB0-0020AF039CA3}#1.1#0"; "MCI32.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form frmVBAmp
Appearance = 0 'Flat
BackColor = &H80000004&
BorderStyle = 0 'None
Caption = "VB-Amp"
ClientHeight = 1560
ClientLeft = 1650
ClientTop = 1530
ClientWidth = 3660
ClipControls = 0 'False
ControlBox = 0 'False
FillColor = &H00FFFFFF&
Icon = "frmVBAmp.frx":0000
KeyPreview = -1 'True
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
OLEDropMode = 1 'Manual
ScaleHeight = 104
ScaleMode = 3 'Pixel
ScaleWidth = 244
ShowInTaskbar = 0 'False
Begin VB.PictureBox iSlider
AutoRedraw = -1 'True
BackColor = &H00C0C000&
BorderStyle = 0 'None
Height = 330
Index = 0
Left = 1035
ScaleHeight = 22
ScaleMode = 3 'Pixel
ScaleWidth = 24
TabIndex = 10
Top = 1125
Visible = 0 'False
Width = 360
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 75
Top = 1035
_ExtentX = 847
_ExtentY = 847
_Version = 327681
End
Begin VB.Timer Timer2
Interval = 1000
Left = 1425
Top = 45
End
Begin VB.ListBox AutoList
Height = 450
Left = 2640
TabIndex = 9
Top = 825
Visible = 0 'False
Width = 855
End
Begin VB.PictureBox Dig
AutoRedraw = -1 'True
BackColor = &H00000000&
BorderStyle = 0 'None
Height = 450
Index = 0
Left = 930
ScaleHeight = 30
ScaleMode = 3 'Pixel
ScaleWidth = 42
TabIndex = 8
Top = 510
Visible = 0 'False
Width = 630
End
Begin VB.PictureBox Img
AutoRedraw = -1 'True
BackColor = &H000000FF&
BorderStyle = 0 'None
Height = 330
Index = 0
Left = 645
ScaleHeight = 22
ScaleMode = 3 'Pixel
ScaleWidth = 22
TabIndex = 7
Top = 1125
Visible = 0 'False
Width = 330
End
Begin VB.PictureBox ResBmp
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &H80000005&
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 330
Left = 1845
ScaleHeight = 22
ScaleMode = 3 'Pixel
ScaleWidth = 22
TabIndex = 6
Top = 1095
Visible = 0 'False
Width = 330
End
Begin VB.PictureBox TmpBtn
AutoRedraw = -1 'True
BackColor = &H000080FF&
BorderStyle = 0 'None
Height = 330
Left = 1470
ScaleHeight = 22
ScaleMode = 3 'Pixel
ScaleWidth = 22
TabIndex = 5
Top = 1110
Visible = 0 'False
Width = 330
End
Begin MCI.MMControl MMControl
Height = 300
Index = 0
Left = 45
TabIndex = 0
Top = 45
Visible = 0 'False
Width = 780
_ExtentX = 1376
_ExtentY = 529
_Version = 327681
BorderStyle = 0
PrevEnabled = -1 'True
NextEnabled = -1 'True
PlayEnabled = -1 'True
PauseEnabled = -1 'True
StopEnabled = -1 'True
EjectEnabled = -1 'True
AutoEnable = 0 'False
PrevVisible = 0 'False
NextVisible = 0 'False
PauseVisible = 0 'False
BackVisible = 0 'False
StepVisible = 0 'False
RecordVisible = 0 'False
EjectVisible = 0 'False
Shareable = -1 'True
DeviceType = ""
FileName = ""
End
Begin VB.Timer Timer1
Interval = 100
Left = 915
Top = 45
End
Begin VB.ListBox PlPath
Appearance = 0 'Flat
BackColor = &H00FFFFFF&
BeginProperty Font
Name = "Small Fonts"
Size = 6.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000C000&
Height = 345
IntegralHeight = 0 'False
Left = 2625
TabIndex = 3
Top = 450
Visible = 0 'False
Width = 885
End
Begin VB.ListBox PlNames
Appearance = 0 'Flat
BackColor = &H00000000&
BeginProperty Font
Name = "Small Fonts"
Size = 6.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000C000&
Height = 360
Left = 2625
OLEDropMode = 1 'Manual
TabIndex = 2
Top = 60
Width = 870
End
Begin MCI.MMControl MMControl
Height = 300
Index = 1
Left = 45
TabIndex = 11
Top = 360
Visible = 0 'False
Width = 780
_ExtentX = 1376
_ExtentY = 529
_Version = 327681
BorderStyle = 0
PrevEnabled = -1 'True
NextEnabled = -1 'True
PlayEnabled = -1 'True
PauseEnabled = -1 'True
StopEnabled = -1 'True
EjectEnabled = -1 'True
AutoEnable = 0 'False
PrevVisible = 0 'False
NextVisible = 0 'False
PauseVisible = 0 'False
BackVisible = 0 'False
StepVisible = 0 'False
RecordVisible = 0 'False
EjectVisible = 0 'False
Shareable = -1 'True
DeviceType = ""
FileName = ""
End
Begin VB.Image iCover
Height = 450
Left = 1650
Stretch = -1 'True
Top = 525
Width = 525
End
Begin VB.Label Btn
BackColor = &H80000018&
BackStyle = 0 'Transparent
Height = 150
Index = 0
Left = 1380
TabIndex = 4
Top = 495
Visible = 0 'False
Width = 165
End
Begin VB.Shape Ind
BorderStyle = 0 'Transparent
FillColor = &H000000FF&
FillStyle = 0 'Solid
Height = 60
Index = 0
Left = 2250
Top = 360
Visible = 0 'False
Width = 240
End
Begin VB.Shape sBlip
BorderStyle = 0 'Transparent
FillColor = &H0000C000&
FillStyle = 0 'Solid
Height = 255
Left = 2385
Top = 75
Width = 45
End
Begin VB.Label Lbl
BackColor = &H00C0FFFF&
BackStyle = 0 'Transparent
Caption = "X"
BeginProperty Font
Name = "Small Fonts"
Size = 6.75
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H00000000&
Height = 180
Index = 0
Left = 2040
TabIndex = 1
ToolTipText = "Song Title"
Top = 105
UseMnemonic = 0 'False
Visible = 0 'False
Width = 210
End
End
Attribute VB_Name = "frmVBAmp"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'VB-Amp Professional (C)1999 Steve J. Gray
'=================== With contributions from various people
'
' This is the main code of the program. It loads the interface
' and responds to button presses. It controls playback, manages
' the playlist, and loads/saves preference settings.
' It loads in the tray icon and opens/closes the preferences and
' cover windows as required. It calls code in the "common" module
' for things like checking files, manipulating filenames, and
' doing low-level API calls.
DefInt A-Z
Public Prg As String, Sect As String
Public DragFlag As Boolean
Public SlideFlag As Integer '**changed!
Public TwipX As Integer, TwipY As Integer
Public IX As Integer, IY As Integer
Public TX As Integer, TY As Integer
Public FX As Integer, FY As Integer
Public TNum As Integer, SongLen As Long, Dev$
Public SongName As String, SongPath As String, SongTitle As String
Public AddName As String, AddPath As String, AddTitle As String
Public DefPath As String, Info As String
Public Intro As Boolean, STP As Boolean, Shuffle As Boolean, Repeat As Boolean
Public Playing As Boolean, Paused As Boolean
Public TimeFlag As Boolean, Elapsed As Long, Remain As Long, TimeDisp As Long
Public RptA As Long, RptB As Long
Public LastCover$, MinH As Integer, MaxH As Integer
Public NewP As Single, Mute As Boolean
Public HFlag As Integer, Small As Integer
Public CoolFlag As Integer
Public SkinLink1 As String, SkinLink2 As String
Public InFlag As Boolean, DowS As String
Public MemFlag As Integer, LastIndex As Integer
Public PlayUnit As Integer 'current playback unit (0 or 1)
Dim FSize(2) As Coord
Dim PolyPt() As Coord, PolyNum() As Long
Dim Kbd(50) As String * 1
Dim cx(50) As Integer, cy(50) As Integer
Dim Di(5) As DEx, Sli(4) As DEx
'
'The Main initialization routines
Private Sub Form_Load()
TwipX = Screen.TwipsPerPixelX
TwipY = Screen.TwipsPerPixelY
'Load objects
For A = 1 To 50: Load Btn(A): Btn(A).Caption = "": Next
For A = 1 To 20: Load Lbl(A): Lbl(A).Caption = "": Next
For A = 1 To 16: Load Ind(A): Next
For A = 1 To 1: Load Img(A): Next
For A = 1 To 5: Load Dig(A): Next
For A = 1 To 4: Load iSlider(A): Next
Prg = "vbamppro": Sect = "config"
Lbl(1).Alignment = 1 'right justify time
'get option settings
OptDefPath = GetSetting$(Prg, Sect, "Path", "")
OptAlwaysOnTop = Val(GetSetting$(Prg, Sect, "WinOnTop", 0))
OptSnap = Val(GetSetting$(Prg, Sect, "WinSnap", 0))
OptSavePos = Val(GetSetting$(Prg, Sect, "WinSavePos", 0))
OptAuto = Val(GetSetting$(Prg, Sect, "Auto", 0))
OptSnooze = Val(GetSetting$(Prg, Sect, "Snooze", 0))
OptSnoozeMd = Val(GetSetting$(Prg, Sect, "SnoozeMode", 0))
OptSnoozeAt = GetSetting$(Prg, Sect, "SnoozeTime", "23:59")
OptMinOnSnz = Val(GetSetting$(Prg, Sect, "SnoozeHide", 0))
OptExitMd = Val(GetSetting$(Prg, Sect, "ExitMode", 0))
OptStartMd = Val(GetSetting$(Prg, Sect, "StartMd", 0))
OptStartMin = Val(GetSetting$(Prg, Sect, "StartMin", 0))
OptStartMute = Val(GetSetting$(Prg, Sect, "StartMute", 0))
OptStartPlaylist = GetSetting$(Prg, Sect, "StartPlaylist", "")
OptStartFreq = GetSetting$(Prg, Sect, "StartFreq", "87.5")
OptSkinName = GetSetting$(Prg, Sect, "Skin", "")
OptSkinPath = GetSetting$(Prg, Sect, "SkinPath", "")
OptTimeFmt = Val(GetSetting$(Prg, Sect, "TimeFmt", ""))
OptVisPLPath = GetSetting$(Prg, Sect, "VisPLPath", "")
OptClrPl = Val(GetSetting$(Prg, Sect, "ClearPLFirst", ""))
OptAutoPlay = Val(GetSetting$(Prg, Sect, "AutoPlay", ""))
OptValExt = GetSetting$(Prg, Sect, "ValidExt", "")
OptPBOverlap = Val(GetSetting$(Prg, Sect, "PBOverlap", OptPBOverlap))
X = Val(GetSetting$(Prg, Sect, "X", Me.Left))
Y = Val(GetSetting$(Prg, Sect, "Y", Me.Top))
Me.Move X, Y
If Exists(OptSkinName) = False Then OptSkinName = "": MsgBox "Previously selected skin not found (" & OptSkinName & ")! Using default"
If OptSkinName = "" Then OptSkinName = App.Path + "\default.skin"
F$ = OptSkinName
PlayUnit = 0
TNum = 1
Stereo = True
Playing = False
Paused = False
Intro = False
STP = False
Repeat = False
Call ClearInf
Call LoadSkin(ByVal F$)
Call LoadAutoList
Call MakeDayStr
If OptStartMin = 1 Then Me.Visible = False
Load frmIcon 'system tray icon/menu
'Handle file(s) from command-line
If Command$ <> "" Then
AddPath = Command$
AddName = "Commandline"
AddTitle = MakeTitle$(AddPath)
Call PlAddFile
TNum = 1: Call PlayIt
Else
If OptStartMd = 1 Then GoSub LoadLast
End If
Timer1.Enabled = True
Exit Sub
LoadLast:
'Load playlist and set last track
On Error Resume Next
F$ = App.Path + "\playlist.m3u"
If Exists(F$) = True Then
PlRead (F$)
TNum = Val(GetSetting$(Prg, Sect, "LastTrack", "0"))
If OptAutoPlay = 1 Then Call PlayIt
End If
LastCover$ = GetSetting$(Prg, Sect, "LastCover", "")
If LastCover$ <> "" Then LoadCover (LastCover$)
Return
PLErr:
End Sub
'Clean up and save settings before exiting program
Private Sub Form_Unload(Cancel As Integer)
MMControl(PlayUnit).Command = "close"
'save settings
SaveSetting Prg, Sect, "Skin", OptSkinName
SaveSetting Prg, Sect, "SkinPath", OptSkinPath
SaveSetting Prg, Sect, "WinOnTop", Str$(OptAlwaysOnTop)
SaveSetting Prg, Sect, "WinSnap", Str$(OptSnap)
SaveSetting Prg, Sect, "WinSavePos", Str$(OptSavePos)
SaveSetting Prg, Sect, "Auto", Str$(OptAuto)
SaveSetting Prg, Sect, "Snooze", Str$(OptSnooze)
SaveSetting Prg, Sect, "SnoozeMode", Str$(OptSnoozeMd)
SaveSetting Prg, Sect, "SnoozeTime", OptSnoozeAt
SaveSetting Prg, Sect, "SnoozeHide", Str$(OptMinOnSnz)
SaveSetting Prg, Sect, "ExitMode", Str$(OptExitMd)
SaveSetting Prg, Sect, "StartMd", Str$(OptStartMd)
SaveSetting Prg, Sect, "StartMin", Str$(OptStartMin)
SaveSetting Prg, Sect, "StartMute", Str$(OptStartMute)
SaveSetting Prg, Sect, "StartPlaylist", OptStartPlaylist
SaveSetting Prg, Sect, "TimeFmt", Str$(OptTimeFmt)
SaveSetting Prg, Sect, "VisPLPath", OptVisPLPath
SaveSetting Prg, Sect, "ClearPlFirst", OptClrPl
SaveSetting Prg, Sect, "AutoPlay", OptAutoPlay
SaveSetting Prg, Sect, "ValidExt", OptValExt
SaveSetting Prg, Sect, "PBOverlap", OptPBOverlap
If OptSavePos = 1 Then
SaveSetting Prg, Sect, "X", Me.Left
SaveSetting Prg, Sect, "Y", Me.Top
End If
Call SaveAutoList
'Save playlist and current track
SaveSetting Prg, Sect, "LastCover", LastCover$
SaveSetting Prg, Sect, "LastTrack", Str$(TNum)
WritePL (App.Path + "\playlist.m3u")
Unload frmIcon
End
End Sub
'Called when the form is clicked to activate it
Private Sub Form_Activate()
TwipX = Screen.TwipsPerPixelX
TwipY = Screen.TwipsPerPixelY
Call AlwaysOnTop(Me, OptAlwaysOnTop)
End Sub
'Called when other windows move to uncover part of our window
Private Sub Form_Paint()
Call SetDD(1, Elapsed \ 1000)
Call SetDD(2, TNum)
Call SetDD(3, 0)
Call SetDD(4, Val(Lbl(10).Caption))
Call SetDD(5, Val(Lbl(11).Caption))
Lbl(3).Caption = Left$(Time$, 5)
End Sub
'Main function dispatcher. Index corresponds to button number
Private Sub DoIt(Index As Integer)
Select Case Index
Case 1: Unload Me 'Power button
Case 2: Me.Visible = False 'Minimize (hide) window
Case 3: Call ToggleLarge 'Toggle Large Mode (window size 2)
Case 4: Call ToggleSmall 'Toggle Small Mode (window size 3)
Case 5: Call ShowPrefs 'About / Preferences
Case 6: Call SelectSkin 'Select Skin
Case 7: Call VolDn
Case 8: Call VolUp
Case 9: Call VolMute
Case 10: Call StopIt 'Stop
Case 11: Call PauseIt 'Pause
Case 12: Call PlayIt 'Play
Case 13: Call Eject 'Eject
Case 14: Call PrevTrack 'Previous Track
Case 15: Call NextTrack 'Next Track
Case 16: Call ShowInfo 'Info
Case 17: Call DelTrack 'Delete Track
Case 18: Call PlMoveEntry(1) 'Move Track Down
Case 19: Call PlMoveEntry(-1) 'Move Track Up
Case 20: Call PlClear 'Clear Playlist
Case 21: Call PlLoad 'Load Playlist
Case 22: Call PlSave 'Save Platlist
Case 23: Call GetOneFile: Call PlAddFile 'Add File
Case 24: Call AddFromDir 'Add Directory
Case 25: Call ToggleIntro 'Intro
Case 26: Call ToggleSTP 'Toggle STP mode
Case 27: Call ToggleRpt 'Toggle repeat mode
Case 28: Call ToggleShuf 'Toggle shuffle mode
Case 29: Call ShowMixer 'run std windows mixer
Case 30: Call SetA 'Set AB repeat Start point
Case 31: Call SetB 'Set AB repeat End point
Case 32: Call Reverse 'reverse playback position 10 seconds
Case 33: Call Forward 'advance playback position 10 seconds
Case 34: Call ToggleCover 'Toggle cover bitmap window
Case 35: Call ShowVisSelect 'Show Visual Playlist Selector window
Case 36: Call PlayPause 'Toggle play/pause
Case 49: Call LoadSkin(ByVal SkinLink1) 'load linked skin#1
Case 50: Call LoadSkin(ByVal SkinLink2) 'load linked skin#2
End Select
End Sub
'When Cover bitmap is clicked
Private Sub iCover_DblClick()
Call SelectCover
End Sub
'Add files to playlist when files dropped to playlist object
Private Sub PlNames_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Data.GetFormat(vbCFFiles) Then
Dim vFn As Variant
For Each vFn In Data.Files
AddName = vFn: AddPath = AddName: AddTitle = MakeTitle$(AddName)
Call PlAddFile
Next vFn
End If
End Sub
'Provide drag and drop feedback to source
Private Sub PlNames_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
'0=do not allow drop, 1=inform source that data will be copied
If Data.GetFormat(vbCFFiles) Then Effect = 1 Else Effect = 0
End Sub
'Add files to playlist when files dropped to form
Private Sub Form_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)
If Data.GetFormat(vbCFFiles) Then
Dim vFn As Variant
For Each vFn In Data.Files
AddName = vFn: AddPath = AddName: AddTitle = MakeTitle$(AddName)
Call PlAddFile
Next vFn
End If
End Sub
'Provide drag and drop feedback to source
Private Sub Form_OLEDragOver(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single, State As Integer)
If Data.GetFormat(vbCFFiles) Then Effect = 1 Else Effect = 0
End Sub
'Called from tray icon
Public Sub Quit()
Unload Me
End Sub
'Display alternate-bitmap/outline when mouse moves over button
Private Sub Btn_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If (Index <> LastIndex) Then
If CoolFlag = 1 Then
Btn(LastIndex).BorderStyle = 0
Btn(Index).BorderStyle = 1
ElseIf CoolFlag = 2 Then
Call ButtonDown(Index)
End If
LastIndex = Index
End If
InActCnt = 1
End Sub
'Button pressed
Private Sub Btn_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ButtonDown(Index)
End Sub
'Button released
Private Sub Btn_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ButtonUp(Index)
End Sub
'Button released (event goes to Temp Button bitmap)
Private Sub TmpBtn_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
Call ButtonUp(LastIndex)
End Sub
'Remove the tmpbtn to reveal original "up" image
Private Sub ButtonUp(Index)
TmpBtn.Visible = False: DoEvents
Btn(Index).BorderStyle = 0
Call DoIt(Index)
End Sub
'Display alternate button image by copying region to tmpbtn then
'moving to proper location and making it visible
Sub ButtonDown(Index)
X = Btn(Index).Left
Y = Btn(Index).Top
W = Btn(Index).Width
H = Btn(Index).Height
X2 = cx(Index): Y2 = cy(Index)
TmpBtn.Visible = False
TmpBtn.Move X, Y, W, H 'Place temp button image over area
TmpBtn.PaintPicture ResBmp.Picture, 0, 0, W, H, X2, Y2, W, H
TmpBtn.ToolTipText = Btn(Index).ToolTipText
TmpBtn.Visible = True
End Sub
'The form is being clicked in area where no buttons/labels etc are
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim IX2 As Integer, IY2 As Integer
Dim hMenu As Long, hSubMenu As Long, R As Integer
Dim menRect As RECT
If Button And 1 Then
' Setup form for Dragging
If DragFlag = False Then
IX = X * TwipX: IY = Y * TwipY
FX = Me.Left: FY = Me.Top
DragFlag = True
End If
ElseIf Button And 2 Then
' Display menu from frmIcon form
menRect.Left = 0: menRect.Top = 0
menRect.Right = Screen.Width
menRect.Bottom = Screen.Height
IX2 = Left / TwipX + X
IY2 = Top / TwipY + Y
hMenu = GetMenu(frmIcon.hWnd)
hSubMenu = GetSubMenu(hMenu, 0) 'choose submenu that coresponds to image icon
R = TrackPopupMenu(hSubMenu, 2, IX2, IY2, 0, frmIcon.hWnd, menRect)
End If
End Sub
'Move the form to follow the mouse
Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If DragFlag = True Then
Me.Move FX + ((X * TwipX) - IX), FY + ((Y * TwipY) - IY)
FX = Me.Left: FY = Me.Top
Else
If LastIndex <> 0 Then
Btn(LastIndex).BorderStyle = 0
LastIndex = 0
TmpBtn.Visible = False
End If
End If
End Sub
'The form is finished moving. Snap to viewport if enabled
Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
DragFlag = False
If OptSnap Then Call Snap2ViewPoint(Me)
End Sub
'Main keypress handler
Private Sub Form_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case 96 'debug- make button and label background non-transparent
For J = 1 To 50: Btn(J).BackStyle = 1: Next
For J = 1 To 20: Lbl(J).BackStyle = 1: Next: KeyAscii = 0
Case 126 'debug- set button border
For J = 1 To 50: Btn(J).BorderStyle = 1: Next: KeyAscii = 0
Case 27 'debug- make buton and label transparent again
For J = 1 To 50: Btn(J).BackStyle = 0: Btn(J).BorderStyle = 0: Next
For J = 1 To 20: Lbl(J).BackStyle = 0: Next: KeyAscii = 0
Case Else
If InFlag = False Then
Ky$ = UCase$(Chr$(KeyAscii))
For J = 1 To 40
If Ky$ = Kbd(J) Then Call DoIt(J): Exit For
Next
KeyAscii = 0
End If
End Select
End Sub
'Handle clicking labels
Private Sub Lbl_Click(Index As Integer)
Select Case Index
Case 1: TimeFlag = Not TimeFlag 'Elapsed/remaining Time
Case 2: Call ShowInfo 'Track title
End Select
End Sub
'Toggle Large View Mode
Private Sub ToggleLarge()
HFlag = 1 - HFlag
If Small = 0 Then Me.Width = FSize(HFlag).X: Me.Height = FSize(HFlag).Y
End Sub
'Toggle Small View Mode
Private Sub ToggleSmall()
Small = 1 - Small
n = HFlag: If Small = 1 Then n = 2
Me.Width = FSize(n).X
Me.Height = FSize(n).Y
End Sub
'Eject Playlist, Get new file/playlist then play
Private Sub Eject()
Call GetOneFile
If AddName <> "" Then
Call PlClear
Call PlAddFile
TNum = 1
Call PlayIt
End If
Exit Sub
End Sub
'Stop playback
Sub StopIt()
MMControl(PlayUnit).From = 0
MMControl(PlayUnit).Command = "seek"
MMControl(PlayUnit).Command = "stop"
iSlider(1).Visible = False
Lbl(1).Caption = ":"
Paused = False: Playing = False
Call ShowLights
End Sub
'Toggle Playback (Pause/resume)
Sub PauseIt()
If Ind(2).Visible = True Then Exit Sub
If Paused = True Then
MMControl(PlayUnit).Command = "play"
Else
MMControl(PlayUnit).Command = "stop"
End If
Paused = Not Paused
Call ShowLights
End Sub
Sub PlayPause()
If Playing = False Then Call PlayIt Else Call PauseIt
End Sub
'Skip backwards 10 seconds
Sub Reverse()
p! = Elapsed - 10000: Call PlayFrom(p!)
End Sub
'Skip forward 10 seconds
Sub Forward()
p! = Elapsed + 10000: Call PlayFrom(p!)
End Sub
'Play Next Track
Sub NextTrack()
TNum = TNum + 1: Call PlayIt
End Sub
'Play the Previous track
Sub PrevTrack()
TNum = TNum - 1: Call PlayIt
End Sub
' This starts to play the selected track (TNUM)
Sub PlayIt()
'Check if track number is valid
If PlNames.ListCount = 0 Then Exit Sub
If TNum < 1 Then TNum = PlNames.ListCount
If TNum > PlNames.ListCount Then TNum = 1
Timer1.Enabled = False
If MMControl(1 - PlayUnit).Mode = mciModePlay Then
If MMControl(1 - PlayUnit).Position < OptPBOverlap Then
MMControl(1 - PlayUnit).Wait = True
MMControl(1 - PlayUnit) = "stop"
MsgBox "!@#!@!#"
End If
End If
MMControl(PlayUnit).Command = "close"
SongPath = PlPath.List(TNum - 1)
'Clear file details
Lbl(10).Caption = "": Lbl(11).Caption = "": Lbl(12).Caption = ""
'Reset AB repeat points
RptA = 0: RptB = 0
'Check for file
If Exists(SongPath) = False Then
F$ = "[FILE NOT FOUND]" 'TODO: Auto delete here?
X$ = PlNames.List(TNum - 1)
If InStr(X$, F$) = 0 Then PlNames.List(TNum - 1) = X$ + " " + F$
PlPath.List(TNum - 1) = ""
Dev$ = "": Exit Sub
Else
Info = "Filename= " & SongPath 'Default info
End If
X$ = UCase$(Right$(SongPath, 5)): p = InStr(X$, ".")
FileType$ = Mid$(X$, p + 1): PicDelay = 0
Dev$ = "ActiveMovie" 'default MCI device
Select Case FileType$
Case "MP2", "MP3", "MPA": Call GetMP3Info
Case "MOD", "MTM", "FAR", "669", "OKT", "STM", "S3M", "NST", "WOW", "XM": Dev$ = "M4W_MCI"
Case "FLI", "FLC": Dev$ = "Animation"
Case "AWA", "AWM": Dev$ = "Animation1"
Case "MMM": Dev$ = "MMMovie"
Case "CDA": Dev$ = "cdaudio": CDTrack = Val(Right$(SongPath, 6)) '**** TEST
Case "BMP", "GIF", "JPG": GoSub DoBitmap
Case "TXT", "DOC", "BAT", "COM", "EXE", "LNK": Dev$ = "Delay": Exit Sub
End Select
'Reset elapsed slider
Call SetSlider(1, 0): If Sli(1).W + Sli(1).H > 0 Then iSlider(1).Visible = True
'Set Titles
Lbl(2).Caption = PlNames.List(TNum - 1)
Lbl(4).Caption = Str$(TNum)
Call SetDD(2, TNum)
'Play the file
MMControl(PlayUnit).DeviceType = Dev$ 'select MCI driver
MMControl(PlayUnit).TimeFormat = 0
Select Case Dev$
Case "cdaudio" 'this is test code! needs work...
MMControl(PlayUnit).Filename = ""
MMControl(PlayUnit).Command = "open"
If MMControl(PlayUnit).Error > 0 Then GoSub MCIError: Exit Sub
MMControl(PlayUnit).Track = CDTrack
PFrom! = MMControl(PlayUnit).TrackPosition
SongLen = MMControl(PlayUnit).TrackLength
MMControl(PlayUnit).From = PFrom!
MMControl(PlayUnit).To = PFrom! + SongLen - 1
MMControl(PlayUnit).Command = "play"
Case "Delay"
Case Else
MMControl(PlayUnit).Filename = SongPath
MMControl(PlayUnit).Wait = True
MMControl(PlayUnit).Command = "open"
If MMControl(PlayUnit).Error > 0 Then GoSub MCIError: Exit Sub
MMControl(PlayUnit).From = 0
SongLen = MMControl(PlayUnit).TrackLength
MMControl(PlayUnit).Command = "play"
End Select
'Set the display indicators
Paused = False: Playing = True
Call ShowLights
'Highlight the track in the playlist
PlNames.ListIndex = TNum - 1
'Calculate the total track length
pos = SongLen / 1000
Min = Int(pos / 60): Sec = Int(pos - Min * 60)
X$ = Format$(Min, "") + ":" + Format$(Sec, "00")
Lbl(13).Caption = X$ 'Call SetDD(1, pos)
If Dev$ = "M4W_MCI" Then GoSub ClearM4WBeta
Timer1.Enabled = True
Exit Sub
'Handle bitmap files
DoBitmap:
Dev$ = "Delay": SongLen = 5000: Elapsed = 0
Call LoadCover(SongPath)
PlNames.ListIndex = TNum - 1
Timer1.Enabled = True
Return
'This is a sneaky routine that automatically closes the Mod4Win BETA
'about box that pop up when each track is started... :-)
ClearM4WBeta:
On Error GoTo CM4WErr
While MMControl(PlayUnit).Position < 1: Wend
AppActivate "MOD": DoEvents
SendKeys " "
Return
CM4WErr: Resume Next
'Display MCI error message
MCIError:
E = MMControl(PlayUnit).Error
M$ = MMControl(PlayUnit).ErrorMessage: M2$ = ""
Select Case E
Case 263: M2$ = Dev$ & " MCI driver is NOT installed." & Chr$(13) & "See VB-Amp documentation!"
Case Else: M2$ = "Unhandled VB-Amp error"
End Select
MsgBox M$ & Chr$(13) & Chr$(13) & M2$
Dev$ = ""
Return
End Sub
'Play track from specified position
Sub PlayFrom(ByVal SPos As Long)
If SPos < 0 Then SPos = 0
If SPos > SongLen Then SPos = SongLen - 1000
MMControl(PlayUnit).Command = "stop"
MMControl(PlayUnit).From = SPos
MMControl(PlayUnit).Command = "Play"
End Sub
'Toggle Album Cover Display
Private Sub ToggleCover()
If frmAlbum.Visible = True Then
frmAlbum.Visible = False
Else
frmAlbum.Visible = True
End If
End Sub
'Toggle Intro Mode
Private Sub ToggleIntro()
Intro = Not Intro: Call ShowLights
End Sub
'Toggle Single Track Play Mode
Private Sub ToggleSTP()
STP = Not STP: Call ShowLights
End Sub
'Toggle Shuffle Mode
Private Sub ToggleShuf()
Shuffle = Not Shuffle: Call ShowLights
End Sub
'Toggle Repeat Mode
Private Sub ToggleRpt()
Repeat = Not Repeat: Call ShowLights
End Sub
'Set AB-Repeat A-point (or both if B button not visible!)
Private Sub SetA()
If Btn(31).Visible = False Then
'No B button so combine functions here!
If RptA > 0 Then
If RptB = 0 Then Call SetB Else RptA = 0: RptB = 0
Else
GoSub SetRA
End If
Else
'RptB exists so only perform RpA.
GoSub SetRA
End If
Call ShowLights
Exit Sub
SetRA: RptA = Elapsed: RptB = 0: Return
End Sub
'Set AB-Repeat B-point
Private Sub SetB()
RptB = Elapsed: Call ShowLights
End Sub
'Increase volume by 5%
Private Sub VolUp()
Call VolChange(5)
End Sub
'Decrease volume by 5%
Private Sub VolDn()
Call VolChange(-5)
End Sub
'Mute the volume
Private Sub VolMute()
Static LastVolLevel As Integer
If Mute = True Then
Pct = LastVolLevel: Mute = False
Call VolChange(Pct)
Else
LastVolLevel = Int(GetVol() * 100)
Call VolChange(-100): Mute = True
End If
End Sub
'Change volume level
Private Sub VolChange(ByVal Chg As Integer)
Dim Pct As Single
If Mute = True Then Call VolMute
Pct = GetVol() + Chg / 100
If Pct < 0 Then Pct = 0
If Pct > 1 Then Pct = 1
Call SetSlider(2, Pct) 'move slider
Call DoSlider(2, Pct) 'set volume and label
End Sub
'Add Media or Playlist file or directory to the playlist
Private Sub PlAddFile()
If AddName <> "" Then
Ext$ = UCase$(GetExtension(AddPath))
If Ext$ = "M3U" Or Ext$ = "PLS" Then
'Add playlist
Call PlRead(AddPath)
Else
If (GetAttr(AddPath) And vbDirectory) = vbDirectory Then ' it represents a directory.
'Add directory
Call AddDir(AddPath, Me, PlNames, PlPath, Pref.ValExt.Text)
Else
'Add media file
If IsPic(AddPath) Then AddTitle = AddTitle + " (picture)"
PlNames.AddItem AddTitle
PlPath.AddItem AddPath
If TNum = 0 Then TNum = 1
End If
End If
End If
Call SetPLTot
End Sub
'Delete Playlist Button
Private Sub DelTrack()
Call PlDelete(PlNames.ListIndex)
End Sub
'Delete Playlist entry
Private Sub PlDelete(ByVal n)
If n >= 0 And n < PlNames.ListCount Then
PlNames.RemoveItem (n)
PlPath.RemoveItem (n)
If n > PlNames.ListCount - 1 Then n = PlNames.ListCount - 1
PlNames.ListIndex = n
End If
Call SetPLTot
End Sub
'Clear Playlist
Sub PlClear()
PlNames.Clear: PlPath.Clear: TNum = 1
iCover.Picture = Nothing
frmAlbum.Cover.Picture = Nothing
Lbl(14).Caption = "untitled"
Call SetPLTot
End Sub
'Move Playlist entry up or down
Sub PlMoveEntry(D)
n = PlNames.ListIndex
If (n + D) >= 0 And (n + D) < PlNames.ListCount Then
T1$ = PlNames.List(n): T2$ = PlPath.List(n)
PlNames.List(n) = PlNames.List(n + D)
PlPath.List(n) = PlPath.List(n + D)
PlNames.List(n + D) = T1$
PlPath.List(n + D) = T2$
PlNames.ListIndex = n + D
End If
End Sub
Private Sub SetPLTot()
Lbl(16).Caption = Str$(PlNames.ListCount)
End Sub
'Display Load dialog
Private Sub GetOneFile()
Static LastFilter
If LastFilter = 0 Then LastFilter = 1
AddName = ""
On Error GoTo ErrHandler
CommonDialog1.CancelError = True
CommonDialog1.InitDir = OptDefPath
CommonDialog1.DialogTitle = "Open Media file"
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.Filter = "MPEG Audio Files|*.MP?|ActiveMovie Files|*.MP?;*.MPEG;*.DAT;*.WAV;*.AU;*.MID;*.RMI;*.AIF?;*.MOV;*.QT;*.AVI;*.M1V;*.RA;*.RAM;*.RM;*.RMM|Music Modules|*.MOD;*.MTM;*FAR;*.669;*.OKT;*.STM;*.S3M;*.NST;*.WOW;*.XM|Bitmaps|*.BMP;*.GIF;*.JPG|Playlists|*.M3U;*.PLS|All Files|*.*"
CommonDialog1.FilterIndex = LastFilter
CommonDialog1.Filename = ""
CommonDialog1.ShowOpen
LastFilter = CommonDialog1.FilterIndex
AddName = CommonDialog1.FileTitle
AddTitle = MakeTitle$(AddName)
AddPath = CommonDialog1.Filename
OptDefPath = Left$(AddPath, Len(AddPath) - Len(AddName))
SaveSetting Prg, Sect, "Path", OptDefPath
ErrHandler:
Exit Sub
End Sub
'Playlist - Double-click
Private Sub PlNames_DblClick()
TNum = PlNames.ListIndex + 1
Call PlayIt
End Sub
'Playlist - keypress handler
Private Sub PlNames_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 46 Then Call PlDelete(PlNames.ListIndex)
End Sub
' Timer routine to update position slider and check for end
' of song, do repeat etc
Private Sub Timer1_Timer()
Static LastPos, LastTime$
Dim pos As Single
DoEvents
If Playing = False Or SongLen = 0 Then Exit Sub
If Dev$ = "Delay" Then
If Not Paused Then Elapsed = Elapsed + Timer1.Interval
Else
Elapsed = MMControl(PlayUnit).Position
End If
Remain = SongLen - Elapsed
If TimeFlag Then TimeDisp = Remain Else TimeDisp = Elapsed
'Frame = Elapsed / 25
pos = TimeDisp \ 1000
Min = pos \ 60: Sec = Int(pos - Min * 60)
X$ = Format$(Min, "") + ":" + Format$(Sec, "00")
If TimeFlag Then X$ = "-" & X$
If X$ <> LastTime$ Then
Lbl(1).Caption = X$: Call SetDD(1, pos)
LastTime$ = X$
End If
'sBlip.Left = 12 + (Frame Mod 78)
'only update if user not adjusting position!
If SlideFlag <> 1 And iSlider(1).Visible = True Then
pos = Elapsed / SongLen: Call SetSlider(1, pos)
End If
If Intro = True Then
'Check if 10 seconds elapsed
If Elapsed > 10000 Then GoSub GoNext
End If
If RptB > 0 Then
'Check if past B position
If Elapsed >= RptB Then Call PlayFrom(RptA)
End If
'Check if song is finished or past overlap
If Elapsed >= SongLen - OptPBOverlap Then GoSub GoNext
Exit Sub
' If Repeat=True, Play same track
' If STP=True, Go to next track but don't play
GoNext:
If OptPBOverlap > 0 Then PlayUnit = 1 - PlayUnit 'switch playback control
If Repeat = False Then
If Shuffle = True Then
TNum = Rnd(Timer) * PlNames.ListCount + 1
Else
TNum = TNum + 1
End If
End If
Call PlayIt
If STP = True Then Call StopIt
Return
End Sub
'Timer 2 used for Auto On/Off events and Realtime Clock display/date
'and volume level checking
Private Sub Timer2_Timer()
Dim volume As Long, Pct As Single
'Check Auto On/Off and Snooze
If Right$(Time$, 2) = "00" Then
GoSub CheckZero
Else
If OptAuto = 1 Then
If OptSnooze = 1 Then
If SnoozeTm < 0 Then GoSub SetSnoozeLbl
Else
Lbl(5).Caption = ""
End If
Else
Lbl(5).Caption = ""
End If
End If
'Check Volume
Pct = GetVol()
Call SetSlider(2, Pct) 'move slider
Exit Sub
CheckZero:
FJ$ = "hh:mm "
If OptTimeFmt = 0 Then FJ$ = "hh:mm AMPM"
Lbl(3).Caption = Format$(Time, FJ$)
Call SetDD(3, 0)
If Time$ = "00:00:00" Then Call MakeDayStr
If OptAuto = 1 Then
If OptSnooze = 1 Then GoSub CheckSnooze
GoSub CheckOO
End If
Return
SetSnoozeLbl:
SnoozeTm = Abs(SnoozeTm)
If OptSnooze = 1 Then
If OptSnoozeMd = 0 Then
Lbl(5).Caption = Format$(SnoozeTm, "00")
Else
Lbl(5).Caption = OptSnoozeAt
End If
End If
Return
CheckSnooze:
If OptSnoozeMd = 0 Then
SnoozeTm = SnoozeTm - 1
Lbl(5).Caption = Format$(SnoozeTm, "00")
If SnoozeTm < 1 Then GoSub DoAutoOff: OptSnooze = 0
Else
Lbl(5).Caption = OptSnoozeAt
If Left$(Time$, 5) = OptSnoozeAt Then GoSub DoAutoOff
End If
Return
CheckOO:
J = AutoList.ListCount - 1: T2$ = Left$(Time$, 5)
For I = 0 To J
A$ = AutoList.List(I): D$ = Left$(A$, 1)
Select Case D$
Case "E": GoSub CheckTime
Case "D": If InStr("MTWRF", DowS$) > 0 Then GoSub CheckTime
Case "N": If InStr("US", DowS$) > 0 Then GoSub CheckTime
Case Else: If D$ = DowS$ Then GoSub CheckTime
End Select
Next I
Return
CheckTime:
p = Val(Mid$(A$, 15, 2))
If T2$ = Mid$(A$, 3, 5) Then GoSub DoAutoOn
If T2$ = Mid$(A$, 9, 5) Then GoSub DoAutoOff
Return
DoAutoOn:
Return
DoAutoOff:
If OptMinOnSnz = 1 Then Me.Visible = False
Return
End Sub
'Digital display routine. Copy bitmaps from resource image.
Sub SetDD(ByVal F, ByVal vn As Variant)
'f=Format index, vn=number
'zflag determines if initial zero's are shown (0=no, 1=yes, -1=first only no)
If Dig(F).Visible = False Then Exit Sub
X = 0: ZFlag = 0
N2 = Di(F).F
Select Case N2
Case 0 'time
Min = vn \ 60: Sec = vn - Min * 60
Z$ = Format$(Min, "00") + ":" + Format$(Sec, "00")
ZFlag = -1
Case 1 To 6 'number of digits
Z$ = Format$(vn, Left$("000000", N2))
Case 7 'frequency
Z$ = Format$(vn, "000.0")
Case 8 'time
FJ$ = "hh:mm ": ZFlag = 1
If OptTimeFmt = 0 Then FJ$ = "hh:mm AMPM": ZFlag = 0
ZZ$ = Format$(Time, FJ$)
AM$ = Mid$(ZZ$, 7, 2): Z$ = Left$(ZZ$, 5)
Lbl(9).Caption = AM$
Case 9 'full time
Z$ = Format$(vn, "hh:mm:ss")
End Select
X2 = Di(F).X: Y2 = Di(F).Y
W = Di(F).W: H = Di(F).H: W2 = Di(F).W2
For J = 1 To Len(Z$)
XQ$ = Mid$(Z$, J, 1): W3 = W
If XQ$ = "0" And ZFlag < 1 Then XQ$ = " "
Select Case XQ$
Case "0" To "9": p = Val(XQ$): ZFlag = 1
Case ".": p = 11: W3 = W2
Case ":": p = 12: W3 = W2
Case Else: p = 10
End Select
If ZFlag = -1 Then ZFlag = 1
'**** Blit Digit to destination
Dig(F).PaintPicture ResBmp.Picture, X, 0, W3, H, X2 + p * W, Y2, W3, H
X = X + W3
Next J
End Sub
'Read the Auto On/Off list
Private Sub LoadAutoList()
F$ = App.Path + "\autolist.txt"
If Exists(F$) = False Then Exit Sub
FIO4 = FreeFile
Open F$ For Input As FIO4
While Not EOF(FIO4)
Line Input #FIO4, A$
If RTrim$(A$) <> "" Then AutoList.AddItem A$
Wend
Close FIO4
End Sub
'Save the Auto On/Off entries to file
Private Sub SaveAutoList()
F$ = App.Path + "\autolist.txt"
FIO5 = FreeFile
Open F$ For Output As FIO5
For I = 0 To AutoList.ListCount - 1
Print #FIO5, AutoList.List(I)
Next
Close FIO5
End Sub
'Get MP3 Info and ID Tag from file
Sub GetMP3Info()
Dim InBuf As String * 256
Dim D1 As Byte
If SongPath <> "" Then If Exists(SongPath) = True Then GoSub GetID
Exit Sub
GetID:
Close
FIO% = FreeFile
Open SongPath For Binary As FIO%
n& = LOF(1): If n& < 256 Then Close FIO%: Return
'Read first MP3 frame header and set info text labels
Get #1, 3, D1
A$ = LTable$(D1, 4, 7, 4, "144 16 32 48 56 64 80 96 112 128 160 192 224 256 320 ")
Lbl(10).Caption = A$: Call SetDD(4, Val(A$))
A$ = LTable$(D1, 2, 3, 3, "44 48 32 ?? ")
Lbl(11).Caption = A$: Call SetDD(5, Val(A$))
Get #1, 4, D1
Lbl(12).Caption = LTable$(D1, 6, 7, 8, "stereo jstereo dualch mono ")
'Now look for ID tag
Get #1, (n& - 256), InBuf: Close FIO%
A$ = "": Cr$ = Chr$(13)
p = InStr(1, InBuf, "tag", 1)
If p = 0 Then
A$ = "No ID Tag in file!"
Else
A$ = A$ & Cr$ & "Title: " & Mid$(InBuf, p + 3, 30)
A$ = A$ & Cr$ & "Artist: " & Mid$(InBuf, p + 33, 30)
A$ = A$ & Cr$ & "Album: " & Mid$(InBuf, p + 63, 30)
A$ = A$ & Cr$ & "Year: " & Mid$(InBuf, p + 93, 4)
A$ = A$ & Cr$ & "Comment: " & Mid$(InBuf, p + 97, 30)
End If
Info = A$: A$ = ""
Return
End Sub
'Display Track Info window
Private Sub ShowInfo()
MsgBox Info, vbInformation, "Track Info"
End Sub
'Clear Track info
Sub ClearInf()
Lbl(1).Caption = ":": Lbl(4).Caption = ""
Lbl(10).Caption = "": Lbl(11).Caption = ""
Lbl(12).Caption = "": Lbl(13).Caption = ""
sBlip.Visible = False: iSlider(1).Visible = False
End Sub
'Display Playlist Load dialog box then load playlist
Sub PlLoad()
On Error GoTo ErrHandler2
CommonDialog1.CancelError = True
CommonDialog1.InitDir = OptDefPath
CommonDialog1.DialogTitle = "Load Playlist"
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.Filter = "MP3 Playlists (*.M3U)|*.M3U|Playlists (*.PLS)|*.PLS"
CommonDialog1.FilterIndex = 1
CommonDialog1.Filename = ""
CommonDialog1.ShowOpen
F$ = CommonDialog1.Filename
OptDefPath = GetPath$(F$)
SaveSetting Prg, Sect, "Path", OptDefPath
If OptClrPl = 1 Then Call PlClear
PlRead (F$)
If OptAutoPlay = 1 Then TNum = 1: Call PlayIt
ErrHandler2:
Exit Sub
End Sub
Public Sub PlRead(F$)
On Error GoTo PLReadErr
FF$ = GetBaseName$(F$) 'path+filename without extension
Path$ = ValidateDir(GetPath$(F$)) 'Get path of playlist as base for entries
Lbl(14).Caption = MakeTitle$(F$)
Call LoadCover(FF$)
n = PlPath.ListCount
FIO% = FreeFile
Open F$ For Input As FIO%
Select Case UCase$(GetExtension(F$))
Case "M3U": GoSub LoadM3U
Case "PLS": GoSub LoadPLS
End Select
PLReadErr:
Close FIO%
Exit Sub
LoadM3U:
While Not EOF(FIO%)
Line Input #FIO%, AA$: A$ = LTrim$(AA$)
If n < 32766 Then GoSub AddIt
Wend
Return
LoadPLS:
While Not EOF(FIO%)
Line Input #FIO%, AA$: AA$ = LTrim$(A$)
If n < 32766 And Left$(AA$, 4) = "File" Then
I = InStr(AA$, "=")
If I > 0 Then A$ = Mid$(AA$, I + 1): GoSub AddIt
End If
Wend
Return
AddIt:
FilePath$ = ValidateDir(GetPath(A$))
Filename$ = GetFileName$(A$)
X$ = MakeTitle(Filename$)
If IsPic(B$) Then X$ = X$ + " (picture)"
PlNames.AddItem X$
If Mid$(FilePath$, 2, 1) = ":" Then
'The path is the "full path"
XX$ = FilePath$ + Filename$
ElseIf Left$(FilePath$, 1) = "\" Then
'Root without drive
XX$ = Left$(Path$, 2) + FilePath$ + Filename$
Else
'The path is relative, so add the playlist path
XX$ = Path$ + FilePath$ + Filename$
End If
PlPath.AddItem XX$
n = n + 1
Return
End Sub
'Display the Save Playlist Dialog box then save playlist
Private Sub PlSave()
On Error GoTo ErrHandler4
CommonDialog1.CancelError = True
CommonDialog1.InitDir = OptDefPath
CommonDialog1.DialogTitle = "Save Playlist"
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.Filter = "MP3 Playlists (*.M3U)|*.M3U"
CommonDialog1.FilterIndex = 1
CommonDialog1.Filename = ""
CommonDialog1.ShowSave
F$ = CommonDialog1.Filename
OptDefPath = GetPath$(F$)
SaveSetting Prg, Sect, "Path", OptDefPath
Call WritePL(F$)
Lbl(14).Caption = MakeTitle$(F$)
ErrHandler4:
Exit Sub
End Sub
'Write the playlist to a file
Sub WritePL(F$)
On Error GoTo ErrHandler5
P1$ = GetPath$(F$): L% = Len(P1$)
Open F$ For Output As 1
For J = 1 To PlPath.ListCount
A$ = PlPath.List(J - 1)
If A$ <> "" Then If InStr(A$, "**") = 0 Then GoSub WriteIt
Next
Close 1: Exit Sub
WriteIt:
If Left$(A$, L) = P1$ Then
'same dir as playlist, so convert to relative
Print #1, Mid$(A$, L% + 1)
Else
'different directory, so just use it
Print #1, A$
End If
Return
ErrHandler5:
Close
MsgBox "Unable to write Playlist! Is the file read-only?"
Exit Sub
End Sub
'Slider is clicked
Private Sub iSlider_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If SlideFlag = 0 Then
If Sli(Index).H = 0 Then
IX = X: FX = iSlider(Index).Left: TX = Screen.TwipsPerPixelX
Else
IY = Y: FY = iSlider(Index).Top: TY = Screen.TwipsPerPixelY
End If
SlideFlag = Index
End If
End Sub
'Slider is being moved
Private Sub iSlider_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
If SlideFlag > 0 Then
If Sli(Index).H = 0 Then
Min = Sli(Index).X: Max = Sli(Index).W + Min 'Horizontal slider
pos = FX + (X - IX)
If pos < Min Then pos = Min
If pos > Max Then pos = Max
FX = pos
NewP = (pos - Min) / (Max - Min)
Else
Min = Sli(Index).Y: Max = Sli(Index).H + Min 'vertical slider
pos = FY + (Y - IY)
If pos < Min Then pos = Min
If pos > Max Then pos = Max
FY = pos
NewP = 1 - ((pos - Min) / (Max - Min))
End If
Call SetSlider(Index, NewP)
Call DoSlider(Index, NewP)
End If
End Sub
'Slider is released. Call appropriate routine with new position
Private Sub iSlider_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
Select Case Index
Case 1 'change playback position
p! = Int(NewP * SongLen): Call PlayFrom(p!)
Case 2 'volume:no change since it's changed as slider moves
End Select
SlideFlag = 0
End Sub
'Set specified slider to position (percentage 0.00 to 1.00)
Private Sub SetSlider(SliNum, PctPos As Single)
If iSlider(SliNum).Visible = False Then Exit Sub
Select Case SliNum
Case 1 To 3: GoSub SetSPos
Case 4: GoSub SetInd
End Select
iSlider(SliNum).Refresh
Exit Sub
SetSPos:
If Sli(SliNum).H = 0 Then
'Horizontal slider
n = Sli(SliNum).X + Int(PctPos * Sli(SliNum).W)
If n <> Sli(SliNum).F Then iSlider(SliNum).Left = n: Sli(SliNum).F = n
Else
'Vertical Slider
n = Sli(SliNum).Y + Sli(SliNum).H - Int(PctPos * Sli(SliNum).H)
If n <> Sli(SliNum).F Then iSlider(SliNum).Top = n: Sli(SliNum).F = n
End If
Return
SetInd:
If Sli(SliNum).H = 0 Then
'Horizontal slider
n = Int(PctPos * Sli(SliNum).W)
If n <> Sli(SliNum).F Then iSlider(SliNum).Width = n: Sli(SliNum).F = n
Else
'Vertical Slider
n = Sli(SliNum).H - Int(PctPos * Sli(SliNum).H)
If n <> Sli(SliNum).F Then iSlider(SliNum).Height = n: Sli(SliNum).F = n
End If
Return
End Sub
Private Sub DoSlider(SliNum, PctPos As Single)
Select Case SliNum
Case 1 'playback position only changes when released
Case 2
Call SetVol(PctPos) 'Volume changes as slider moves
Lbl(18).Caption = Int(PctPos * 100) & "%"
Call SetSlider(4, PctPos)
Case 3 'balance
Case 4 'volume indicator
End Select
End Sub
'Display Folder Browse dialog then add files from selected path to playlist
Sub AddFromDir()
A$ = GetBrowseDir(Me, "Select Directory containing Media Files:")
If A$ <> "" Then Call AddDir(A$, Me, PlNames, PlPath, Pref.ValExt.Text)
End Sub
'Load a bitmap album cover file
Sub LoadCover(A$)
Static LastCover$
If A$ = LastCover$ Then Exit Sub 'don't reload cover!
C$ = ""
If InStr(A$, ".") = 0 Then
'filename without extension, so try different types
Ext$ = ".BMP": GoSub TestIt
Ext$ = ".GIF": GoSub TestIt
Ext$ = ".JPG": GoSub TestIt
Else
C$ = A$ 'full filename, so just use it
End If
If Exists(C$) = True Then
iCover.Picture = LoadPicture(C$)
If iCover.Visible = False Then
frmAlbum.Cover = LoadPicture(C$)
frmAlbum.Visible = True
End If
LastCover = C$
Else
iCover.Picture = Nothing
frmAlbum.Cover = Nothing
frmAlbum.Visible = False
LastCover = ""
End If
Exit Sub
TestIt:
If Exists(A$ + Ext$) = True Then C$ = A$ + Ext$
Return
End Sub
'Display Preferences window
Sub ShowPrefs()
If Pref.Visible = False Then
Call AlwaysOnTop(Me, False)
Pref.Show 1
End If
End Sub
'Run standard windows sound-mixer program
Sub ShowMixer()
Shell "sndvol32.exe", vbNormalFocus
End Sub
'Show Visual Playlist selector
Sub ShowVisSelect()
Call AlwaysOnTop(Me, False)
Load frmVisLoader
End Sub
'Display Select Cover dialog
Sub SelectCover()
On Error GoTo ErrHandler1
CommonDialog1.CancelError = True
CommonDialog1.DialogTitle = "Select Cover"
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.InitDir = ""
CommonDialog1.Filter = "Bitmap|*.gif;*.bmp;*.jpg"
CommonDialog1.FilterIndex = 1
CommonDialog1.ShowOpen
F$ = CommonDialog1.Filename
Call LoadCover(F$)
ErrHandler1:
End Sub
'Display Load skin dialog box
Sub SelectSkin()
On Error GoTo ErrHandler1
Path$ = OptSkinPath: If Path$ = "" Then Path$ = App.Path
CommonDialog1.CancelError = True
CommonDialog1.DialogTitle = "Select Skin"
CommonDialog1.Flags = cdlOFNHideReadOnly
CommonDialog1.InitDir = Path$
CommonDialog1.Filter = "Skin control file (*.skin)|*.skin"
CommonDialog1.FilterIndex = 1
CommonDialog1.ShowOpen
F$ = CommonDialog1.Filename
Call LoadSkin(ByVal F$)
ErrHandler1:
End Sub
'Load the skin file
Private Sub LoadSkin(ByVal F$)
Dim NumPoints As Integer, NumPoly As Integer, Dum As Integer
Dim K As Single, Multi As Boolean, SkinErr As Boolean
Static LastPath$
Multi = False: SkinErr = False
SetWindowRgn Me.hWnd, 0, True 'clear previous region
p$ = ValidateDir$(OptSkinPath)
If p$ = "" Then
If LastPath$ <> "" Then p$ = LastPath$ Else p$ = App.Path
End If
If InStr(F$, ":") = 0 Then
PP$ = p$ & F$
Else
PP$ = F$
End If
If Exists(PP$) = False Then
'Check in same directory as application
PP$ = ValidateDir$(App.Path) & GetFileName$(F$)
If Exists(PP$) = False Then
MsgBox "Skin not found!" & Chr$(13) & "SkinName=" & F$ & Chr$(13) & "SkinPath=" & OptSkinPath
Exit Sub
End If
End If
OptSkinName = PP$
Path$ = GetPath$(PP$): LastPath$ = Path$
FIO = FreeFile
Open PP$ For Input As FIO
Input #FIO, A$: If A$ <> "VB-Amp Skin" Then Close FIO: MsgBox "Invallid Skin!": Exit Sub
Line Input #FIO, A$: SkinInfo = A$
'Hide all the elements (move indicators off screen)
For J = 1 To 50: Btn(J).Visible = False: Next
For J = 1 To 20: Lbl(J).Visible = False: Next
For J = 1 To 1: Btn(J).Visible = False: Next
For J = 1 To 1: Img(J).Visible = False: Next
For J = 1 To 16: Ind(J).Visible = False: Ind(J).Move -10, -10, 5, 5: Next
For J = 1 To 5: Dig(J).Visible = False: Next
For J = 1 To 4: iSlider(J).Visible = False: Sli(J).W = 0: Sli(J).H = 0: Next
PlNames.Visible = False
iCover.Visible = False
NumPoints = 0: C = 0
'Read the form size values
For J = 0 To 2
Input #FIO, X, Y
FSize(J).X = X * TwipX: FSize(J).Y = Y * TwipY
Next
Me.Width = FSize(0).X
Me.Height = FSize(0).Y
'Read the skin options
Input #FIO, B1$, B2$
Input #FIO, CoolFlag, ScnPos, Dum, Dum, Dum, Dum, Dum, Dum
'Set the window position
W = Screen.Width: H = Screen.Height
W2 = Me.Width: H2 = Me.Height
Select Case ScnPos '0=no change
Case 1: Me.Move 0, 0 'top left
Case 2: Me.Move W - W2, 0 'top right
Case 3: Me.Move W - W2, H - H2 'bottom right
Case 4: Me.Move 0, H - H2 'bottom left
Case 5: Me.Move (W - W2) / 2, (H - H2) / 2 'centred
End Select
'Make sure form is entirely on screen (if possible)
X = Me.Left: If X + W2 > W Then X = W - W2: If X < 0 Then X = 0
Y = Me.Top: If Y + H2 > H Then Y = H - H2: If Y < 0 Then Y = 0
Me.Move X, Y
'Load the background and down-button pictures
F$ = Path$ + B1$: If Exists(F$) = True Then Me.Picture = LoadPicture(F$) Else MsgBox "Main bitmap not found: " & F$
F$ = Path$ + B2$
If F$ <> "" Then
If Exists(F$) = True Then ResBmp.Picture = LoadPicture(F$) Else MsgBox "Resource bitmap not found: " & F$
End If
'Read the rest of the skin file
Do While Not EOF(FIO)
Input #FIO, Z$
ZZ$ = Left$(Z$, 1): n = Val(Mid$(Z$, 2))
Select Case ZZ$
Case "B": GoSub SetBtn
Case "L": GoSub SetLbl
Case "I": GoSub SetInd
Case "S": GoSub SetSlider
Case "D": GoSub SetDig
Case "C": GoSub SetPic
Case "X": GoSub SetExtra
Case "N": NumPoints = n: ReDim PolyPt(NumPoints + 1) As Coord
Case "M": GoSub MultiRegion
Case "P"
If C < NumPoints Then
Input #FIO, Y
PolyPt(C).X = n: PolyPt(C).Y = Y: C = C + 1
End If
Case ";": GoSub Comment
Case "/": GoSub SkinComment
Case "E": Exit Do
End Select
Loop
Close FIO
'This makes sure there are the right number of points for the
'region(s) then calls the API to create it.
If (NumPoints > 0) And (C = NumPoints) Then
If Multi = False Then
PolyPt(C).X = PolyPt(0).X
PolyPt(C).Y = PolyPt(0).Y
SetWindowRgn Me.hWnd, CreatePolygonRgn(PolyPt(0), NumPoints, 0), True
Else
SetWindowRgn Me.hWnd, CreatePolyPolygonRgn(PolyPt(0), PolyNum(0), NumPoly, 1), True
End If
End If
Small = 0: HFlag = 0 'reset the form to normal size
Call Form_Paint 're-draw the digital displays
Call ShowLights 're-draw the status indicators
DoEvents
If SkinErr = True Then
MsgBox "Error in skin file!" & Chr$(13) & "The skin file contains references to the following elements that do not exist!:" & Chr$(13) & SkE$
End If
Exit Sub
MultiRegion:
NumPoints = n
ReDim PolyPt(NumPoints + 1) As Coord 'set aside total points
Input #FIO, NumPoly
ReDim PolyNum(NumPoly) As Long 'set size of array containing number of points in each region
For J = 0 To NumPoly - 1: Input #FIO, PolyNum(J): Next 'read sizes of each region
Multi = True
Return
SetBtn:
Input #FIO, X, Y, W, H, X2, Y2, Z$, TT$
If n = 0 Then Return
If n = 49 Then Input #FIO, SkinLink1
If n = 50 Then Input #FIO, SkinLink2
If n > 50 Then SkinErr = True: Return
If W < 1 Or H < 1 Then Return
Btn(n).Move X, Y, W, H
Btn(n).ToolTipText = TT$
Btn(n).Tag = Str$(X2) + "," + Str$(Y2)
Btn(n).Visible = True
Kbd(n) = Z$
If X2 + Y2 = 0 Then
cx(n) = X: cy(n) = Y
Else
cx(n) = X2: cy(n) = Y2
End If
Return
MkColor:
CV& = (Fb * 65536) + (Fg * 256&) + (Fr)
BV& = (Bb * 65536) + (Bg * 256&) + (Br)
Return
SetLbl:
Input #FIO, X, Y, W, H, Fr, Fg, Fb, Pt, F$, TT$
If n = 0 Then Return
If W < 1 Or H < 1 Then Return
If n > 20 Then GoSub SkinErr: Return
GoSub MkColor
Lbl(n).Move X, Y, W, H
Lbl(n).ToolTipText = SetTip$(TT$)
Lbl(n).ForeColor = CV&
Lbl(n).FontName = F$
Lbl(n).FontSize = Pt
Lbl(n).FontBold = False
Lbl(n).Visible = True
Return
SetDig:
Input #FIO, X, Y, X2, Y2, W, H, W2, S, F, TT$
If n = 0 Then Return
If n > 5 Then GoSub SkinErr: Return
Select Case F
Case 0: WW = W * 4 + W2
Case Else: WW = W * F
End Select
If n = 3 Then WW = W * 4 + W2
'Save additional parameters
Di(n).X = X2: Di(n).Y = Y2
Di(n).W = W: Di(n).H = H
Di(n).W2 = W2
Di(n).S = S: Di(n).F = F
'Set the elements
Dig(n).Move X, Y, WW, H
Dig(n).ToolTipText = TT$
Dig(n).Visible = True
Return
SetSlider:
Input #FIO, X, Y, W, H, X2, Y2, W2, H2, TT$
If n = 0 Then Return
If n > 4 Then GoSub SkinErr: Return
With Sli(n)
.X = X
.Y = Y
.W = W
.H = H
.X2 = X2
.Y2 = Y2
.W2 = W2
.H2 = H2
.F = 0 ' used as flag for last position
End With
iSlider(n).ToolTipText = SetTip$(TT$)
iSlider(n).Width = W2
iSlider(n).Height = H2
iSlider(n).Move X, Y, W2, H2
iSlider(n).Visible = True: DoEvents
iSlider(n).PaintPicture ResBmp.Picture, 0, 0, W2, H2, X2, Y2, W2, H2
Return
SetInd:
Input #FIO, X, Y, W, H, Fr, Fg, Fb, Sh, TT$
If n = 0 Then Return
If W < 1 Or H < 1 Then Return
If n > 16 Then GoSub SkinErr: Return
GoSub MkColor
Ind(n).Move X, Y, W, H
Ind(n).FillColor = CV&
Ind(n).Shape = Sh
'Ind(n).Visible = True 'don't display yet (let ShowLights routine do it)
Return
SetExtra:
Input #FIO, X, Y, W, H, Fr, Fg, Fb, Br, Bg, Bb, Pt, F$, TT$
If n = 0 Then Return
If n > 1 Then GoSub SkinErr: Return
If W < 1 Or H < 1 Then Return
GoSub MkColor
PlNames.Move X, Y, W, H
PlNames.ToolTipText = SetTip$(TT$)
PlNames.ForeColor = CV&
PlNames.BackColor = BV&
PlNames.FontName = F$
PlNames.FontBold = False
PlNames.FontSize = Pt
PlNames.Visible = True
Return
SetPic:
Input #FIO, X, Y, W, H, TT$
If n = 0 Or n > 1 Then Return
If W < 1 Or H < 1 Then Return
iCover.Move X, Y, W, H
iCover.ToolTipText = SetTip$(TT$)
iCover.Visible = True
Return
Comment:
Line Input #FIO, TT$
Return
SkinComment:
Line Input #FIO, TT$
SkinInfo = SkinInfo & Chr$(13) & TT$
Return
SkinErr:
SkE$ = SkE$ & " " & Z$: SkinErr = True: Return
End Sub
'Set status lights
Sub ShowLights()
Ind(1).Visible = Stereo
Ind(2).Visible = Not Playing
Ind(3).Visible = Paused
Ind(4).Visible = Playing
Ind(5).Visible = Intro: Ind(11).Visible = Not Intro
Ind(6).Visible = STP: Ind(12).Visible = Not STP
Ind(7).Visible = Repeat: Ind(13).Visible = Not Repeat
Ind(8).Visible = (RptB > 0): Ind(14).Visible = (RptB = 0)
Ind(9).Visible = Random: Ind(15).Visible = Not Random
Ind(10).Visible = Shuffle: Ind(16).Visible = Not Shuffle
End Sub
'Set Date/Day variables
Public Sub MakeDayStr()
DOW = WeekDay(Now): DD = Day(Now): MM = Month(Now): YY = Year(Now)
TD$ = Format$(YY, "00") + Format$(MM, "00") + Format$(DD, "00")
DWS$ = RTrim$(Mid$("Sunday Monday Tuesday WednesdayThursday Friday Saturday ", DOW * 9 - 8, 9))
MMS$ = Mid$("January February March April May June July August SeptemberOctober November December ", MM * 9 - 8, 9)
Today$ = DWS$ + " " + RTrim$(MMS$) + " " + Str$(DD) + "," + Str$(YY)
Lbl(6).Caption = Today$
Lbl(7).Caption = Left$(DWS$, 3)
DowS$ = Mid$("UMTWRFS", DOW, 1)
End Sub
'Set ToolTip to string unless first character is "~"
Private Function SetTip$(Tip$)
SetTip$ = ""
If Left$(Tip$, 1) <> "~" Then SetTip$ = Tip$
End Function