' _,
' ___ _ _ _ ___(_)
'/ __| / \ | \| | _ | |
'\__ \/ \ \| \\ | _ \ |
'|___/_/ \_|_|\_|___/_|
'
'Play Music
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If
'//////////////////////////////////////////////////////////////
#If Win64 Then
Public Glb_TimerID As LongPtr
#Else
Public Glb_TimerID As Long
#End If
#If VBA7 Then
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare PtrSafe Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Declare PtrSafe Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameW" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
#Else
Private Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Private Declare Function mciGetErrorString Lib "winmm.dll" Alias "mciGetErrorStringA" (ByVal dwError As Long, ByVal lpstrBuffer As String, ByVal uLength As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameW" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
#End If
'//////////////////////////////////////////////////////////////////////////////////
Type PlayerPlaying
CodeName As String
ItemIndex As Long
ItemLength As Long
ItemName As String
ItemArtor As Long
List As Variant
ListCount As Long
ListIndex As Long
Loop As Long
IndexLoop As Long
Shuffle As Boolean
Prioritize As Boolean
Volume As Long
Speed As Double
LoopWait As Long
Position As Long
End Type
'//////////////////////////////////////////////////////////////////////////////////
Private PNP As PlayerPlaying, DoTime As Date
'//////////////////////////////////////////////////////////////////////////////////
Private Row As Long, Col As Long
Public Sub Player_End()
On Error Resume Next
If Glb_TimerID <> 0 Then KillTimer 0&, Glb_TimerID
Application.OnTime DoTime, "'" & ThisWorkbook.Name & "'!Player_DoTime", , False
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!CloseAllAudio", , False
Call CloseAllAudio
DoTime = 0: Row = 0: Col = 0
End
End Sub
Public Sub MakeFileAndPlay()
Static Tmp As String
Dim WS As Worksheet
Dim Arr(), K, I, Text As String
Dim RNG As Range, iStep As Long, LR As Long
Set WS = Worksheets("data")
If Row = 0 Then
Set RNG = Selection
If VBA.TypeName(RNG) <> "Range" Then Exit Sub
Row = RNG.Row: Col = RNG.Column
Else
Row = Row + 1
End If
Const StartColumn = "B"
Const StartRow = 5
LR = WS.Range(StartColumn & 1000).End(3).Row
If Row > LR Then GoTo Ends
If Col <> Columns(StartColumn).Column Or Row < StartRow Or LR < StartRow Then
Row = 0: Col = 0: Exit Sub
End If
WS.Range(StartColumn & StartRow).Resize(LR).Interior.Color = VBA.vbWhite
With WS.Range(StartColumn & Row)
Text = .Value
.Interior.Color = VBA.vbYellow
End With
If Text = "" Or Not VBA.IsNumeric(Text) Then GoTo Ends
If Tmp = "" Then
Tmp = PATH_SYS_TEMP & "\MCIPlay\"
CreateFolder Tmp
ConvertBase64ToFile Tmp & "cau_mo_dau.wma", Base64_File_cau_mo_dau_wma
ConvertBase64ToFile Tmp & "so_0.wma", Base64_File_so_0_wma
ConvertBase64ToFile Tmp & "so_1.wma", Base64_File_so_1_wma
ConvertBase64ToFile Tmp & "so_2.wma", Base64_File_so_2_wma
ConvertBase64ToFile Tmp & "so_3.wma", [g6].Value
ConvertBase64ToFile Tmp & "so_4.wma", Base64_File_so_4_wma
ConvertBase64ToFile Tmp & "so_5.wma", Base64_File_so_5_wma
ConvertBase64ToFile Tmp & "so_6.wma", Base64_File_so_6_wma
ConvertBase64ToFile Tmp & "so_7.wma", Base64_File_so_7_wma
ConvertBase64ToFile Tmp & "so_8.wma", Base64_File_so_8_wma
ConvertBase64ToFile Tmp & "so_9.wma", Base64_File_so_9_wma
ConvertBase64ToFile Tmp & "Vui_long_den_quay.wma", Base64_File_cau_ket_wma
End If
K = 1: ReDim Preserve Arr(1 To K)
Arr(1) = Tmp & "cau_mo_dau.wma"
For I = 1 To Len(Text)
K = K + 1: ReDim Preserve Arr(1 To K)
Arr(K) = Tmp & "so_" & VBA.Mid(Text, I, 1) & ".wma"
Next
K = K + 1: ReDim Preserve Arr(1 To K)
Arr(K) = Tmp & "Vui_long_den_quay.wma"
'------------------------------
Player_Intialize Arr, _
iLoop:=[C5].Value, _
Speed:=1.1, _
Volume:=100
Ends:
If iStep > LR Then Call Player_End
End Sub
'==============================================================
Private Function PATH_SYS_TEMP() As String
PATH_SYS_TEMP = VBA.IIf(VBA.Environ("tmp") <> "", VBA.Environ("tmp"), VBA.Environ("temp"))
End Function
Public Sub Player_Intialize( _
ByVal List As Variant, _
Optional iLoop As Long = 0, _
Optional WaitLoop As Long = 1, _
Optional bShuffle As Boolean = False, _
Optional Speed As Double = 1.1, _
Optional Volume As Byte = 100, _
Optional ByVal NewAliasName As String = "FileMusic")
If Not VBA.IsArray(List) Then Exit Sub
Dim I As Long, J As Long
On Error Resume Next
If Glb_TimerID <> 0 Then KillTimer 0&, Glb_TimerID
Application.OnTime DoTime, "'" & ThisWorkbook.Name & "'!Player_DoTime", , False
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!CloseAllAudio", , False
Call CloseAllAudio
Make:
PNP.List = List
PNP.Loop = iLoop
PNP.LoopWait = WaitLoop
PNP.Shuffle = bShuffle
PNP.CodeName = NewAliasName
PNP.Speed = VBA.IIf(Speed < 0.5, 0.5, VBA.IIf(Speed > 4, 4, Speed))
PNP.Volume = VBA.IIf(Volume < 0, 0, VBA.IIf(Volume > 100, 100, Volume))
Dim Item, L As Long, NewList()
For Each Item In PNP.List
If VBA.TypeName(Item) = "String" And Len(Item) > 5 Then
L = L + 1
ReDim Preserve NewList(1 To L)
NewList(L) = ShortPath(Item)
End If
Next
If L > 0 Then
PNP.IndexLoop = 0
PNP.ItemIndex = 0
PNP.ListCount = L
PNP.List = NewList
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!Player_ListPlayNext"
End If
End Sub
'//////////////////////////////////////////////////////////////////////////////////
Public Sub Player_ListPlayNext()
DoEvents
On Error Resume Next
If Not VBA.IsArray(PNP.List) Then Call Player_End: Exit Sub
Dim I As Long, Idx As Long, R As Long
DoTime = VBA.Now
If PNP.Shuffle Then
VBA.Randomize
Rnd: Idx = Int(PNP.ListCount * Rnd + 1)
If Idx = PNP.ItemIndex Then GoTo Rnd
Else
Idx = PNP.ItemIndex + 1
If Idx > PNP.ListCount Then
PNP.Speed = 1.5
Application.Wait VBA.Now + VBA.TimeSerial(0, 0, PNP.LoopWait)
Idx = 1: PNP.IndexLoop = PNP.IndexLoop + 1
If PNP.Loop = 0 Or PNP.IndexLoop > PNP.Loop Then DoTime = 0
End If
End If
If DoTime > 0 Then
PNP.ItemIndex = Idx
PNP.ItemName = PNP.List(Idx)
Call FileOpen
DoTime = (PNP.ItemLength - 1500)
DoTime = VBA.IIf(DoTime < 1000, 0, DoTime / 1000 / PNP.Speed)
DoTime = VBA.Now + VBA.TimeSerial(0, 0, DoTime)
Application.OnTime DoTime, "'" & ThisWorkbook.Name & "'!Player_DoTime"
Else
Application.OnTime VBA.Now + VBA.TimeSerial(0, 0, 2), "'" & ThisWorkbook.Name & "'!MakeFileAndPlay"
End If
End Sub
Public Sub FileOpen()
DoEvents
Dim lRet&, sError As String * 255
Call mciSendString("Close all", "", 0, 0)
Call mciSendString("Close " & PNP.CodeName, "", 0, 0)
lRet = mciSendString("open """ & PNP.ItemName & """ alias " & PNP.CodeName, "", 0, 0)
If PNP.Speed <= 0 Then PNP.Speed = 1
If PNP.Volume <= 0 Then PNP.Volume = 100
If lRet <> 0 Then mciGetErrorString lRet, sError, 255: Exit Sub
Call mciSendString("Play " & PNP.CodeName, "", 0, 0)
Call mciSendString("set " & PNP.CodeName & " Speed " & CStr(Int(PNP.Speed * 1000)), "", 0, 0)
Call mciSendString("setaudio " & PNP.CodeName & " volume to " & PNP.Volume * 10, "", 0, 0)
Call mciSendString("Play " & PNP.CodeName, "", 0, 0)
PNP.ItemLength = AudioGetLength()
End Sub
Public Sub Player_DoTime()
If Glb_TimerID <> 0 Then KillTimer 0&, Glb_TimerID
Glb_TimerID = SetTimer(0&, 0&, 300, AddressOf Player_CheckPlayNext)
End Sub
Public Sub Player_CheckPlayNext()
DoEvents
Dim T1 As Long
T1 = AudioGetCurPos()
If T1 = 0 Then If Glb_TimerID <> 0 Then KillTimer 0&, Glb_TimerID
If T1 >= PNP.ItemLength - 100 Then
If Glb_TimerID <> 0 Then KillTimer 0&, Glb_TimerID
Application.OnTime VBA.Now, "'" & ThisWorkbook.Name & "'!Player_ListPlayNext"
End If
End Sub
'//////////////////////////////////////////////////////////////////////////////////
Function AudioGetLength() As Long
Dim lRet&, S As String * 255: S = VBA.Space(255)
On Error Resume Next
lRet = mciSendString("status " & PNP.CodeName & " length", S, 255, 0)
If lRet = 0 Then AudioGetLength = CLng(S)
End Function
'//////////////////////////////////////////////////////////////////////////////////
Function AudioGetCurPos() As Long
DoEvents
Dim lRet&, S As String * 255: S = VBA.Space(255)
On Error Resume Next
lRet = mciSendString("status " & PNP.CodeName & " position wait", S, 255, 0)
If lRet = 0 Then AudioGetCurPos = CLng(S)
End Function
'//////////////////////////////////////////////////////////////////////////////////
Sub CloseAllAudio()
Call mciSendString("Close all", "", 0, 0)
On Error Resume Next
End Sub
'//////////////////////////////////////////////////////////////////////////////////
Sub ConvertBase64ToFile(strFilePath As String, strBase64 As String)
If VBA.Dir(strFilePath, vbSystem) <> "" Then Exit Sub
Const UseBinaryStreamType = 1
Const SaveWillCreateOrOverwrite = 2
Dim streamOutput, xmlDoc: Set streamOutput = CreateObject("ADODB.Stream")
#If Win64 Then
Set xmlDoc = CreateObject("MSXML2.DOMDocument.6.0")
#Else
Set xmlDoc = CreateObject("Microsoft.XMLDOM")
#End If
Dim xmlElem: Set xmlElem = xmlDoc.createElement("tmp")
xmlElem.DataType = "bin.base64"
xmlElem.Text = strBase64
streamOutput.Open
streamOutput.Type = UseBinaryStreamType
streamOutput.Write = xmlElem.nodeTypedValue
streamOutput.SaveToFile strFilePath, SaveWillCreateOrOverwrite
Set streamOutput = Nothing
Set xmlDoc = Nothing
Set xmlElem = Nothing
End Sub
Private Function CreateFolder(ByVal FolderPath As String, Optional ByRef FileSystem As Object) As Boolean
Dim FolderArray, Tmp$, I As Integer, UB As Integer, tFolder$
tFolder = FolderPath
If VBA.Right(tFolder, 1) = "\" Then tFolder = VBA.Left(tFolder, VBA.Len(tFolder) - 1)
If tFolder Like "\\*\*" Then tFolder = VBA.Strings.Replace(tFolder, "\", "@", 1, 3)
FolderArray = VBA.Split(tFolder, "\")
FolderArray(0) = VBA.Strings.Replace(FolderArray(0), "@", "\", 1, 3)
On Error GoTo Ends
If FileSystem Is Nothing Then
Set FileSystem = VBA.CreateObject("Scripting.FileSystemObject")
End If
UB = UBound(FolderArray)
With FileSystem
For I = 0 To UB
Tmp = Tmp & FolderArray(I) & "\"
If Not .FolderExists(Tmp) Then .CreateFolder (Tmp)
CreateFolder = (I = UB) And Len(FolderArray(I)) > 0 And FolderArray(I) <> " "
Next
End With
Ends:
End Function
'//////////////////////////////////////////////////////////////////////////////////
Function ShortPath(ByVal LongPath As String) As String
Dim ret&, Buff As String * 512
ret = GetShortPathName(StrConv(LongPath, 64), Buff, 512)
ShortPath = Left(StrConv(Buff, 128), ret)
End Function
