Option Compare Database Option Explicit 'Emitir un sonido por el altavoz del equipo. 'This code was originally written by Dev Ashish. 'It is not to be altered or distributed, 'except as part of an application. 'You are free to use it in any application, 'provided the copyright notice is left unchanged. ' 'Code courtesy of Dev Ashish Public Const pcsSYNC = 0 ' wait until sound is finished playing Public Const pcsASYNC = 1 ' don't wait for finish Public Const pcsNODEFAULT = 2 ' play no default sound if sound doesn't exist Public Const pcsLOOP = 8 ' play sound in an infinite loop (until next apiPlaySound) Public Const pcsNOSTOP = 16 ' don't interrupt a playing sound 'Sound APIs Private Declare Function apiPlaySound Lib "Winmm.dll" Alias "sndPlaySoundA" _ (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long 'AVI APIs Private Declare Function apimciSendString 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 apimciGetErrorString Lib "Winmm.dll" _ Alias "mciGetErrorStringA" (ByVal dwError As Long, _ ByVal lpstrBuffer As String, ByVal uLength As Long) As Long Function mc_WavPlay() 'Emitir un sonido por el altavoz del equipo. Dim a As Long Dim strWav As String strWav = GetDBLocation & "Start.wav" a = fPlayStuff(strWav) End Function Function fPlayStuff(ByVal strFilename As String, Optional intPlayMode As Integer) As Long 'MUST pass a filename _with_ extension, Supports Wav, AVI, MID type files Dim lngRet As Long Dim strTemp As String Select Case LCase(fGetFileExt(strFilename)) Case "wav": If Not IsMissing(intPlayMode) Then lngRet = apiPlaySound(strFilename, intPlayMode) Else MsgBox "Must specify play mode." Exit Function End If Case "avi", "mid": strTemp = String$(256, 0) lngRet = apimciSendString("play " & strFilename, strTemp, 255, 0) End Select fPlayStuff = lngRet End Function Function fStopStuff(ByVal strFilename As String) 'Stops a multimedia playback Dim lngRet As Long Dim strTemp As String Select Case LCase(fGetFileExt(strFilename)) Case "Wav": lngRet = apiPlaySound(0, pcsASYNC) Case "avi", "mid": strTemp = String$(256, 0) lngRet = apimciSendString("stop " & strFilename, strTemp, 255, 0) End Select fStopStuff = lngRet End Function Private Function fGetFileExt(ByVal strFullPath As String) As String Dim intPos As Integer, intLen As Integer intLen = Len(strFullPath) If intLen Then For intPos = intLen To 1 Step -1 'Find the last \ If Mid$(strFullPath, intPos, 1) = "." Then fGetFileExt = Mid$(strFullPath, intPos + 1) Exit Function End If Next intPos End If End Function Function fGetError(ByVal lngErrNum As Long) As String ' Translate the error code to a string Dim lngX As Long Dim strErr As String strErr = String$(256, 0) lngX = apimciGetErrorString(lngErrNum, strErr, 255) strErr = Left$(strErr, Len(strErr) - 1) fGetError = strErr End Function Function fatest() Dim a As Long a = fStopStuff("C:\winnt\clock.avi") End Function Function WavDone() Dim a As Long Dim strWav As String strWav = GetDBLocation & "Done.wav" a = fPlayStuff(strWav) End Function Function GetDBLocation() As String 'Conocer la ruta predeterminada donde están los archivos de sonico. GetDBLocation = "C:\Archivos de programa\Clan McPegasus\Sonidos\" End Function