I have a piece of code which can read most audio files (including wav, mp3, midi...), but it won't work if there are spaces in the path or File name.
so I have to revert to my other code which accepts it, but reads only wav files...
this is the code for reading all type of audio:
Option Explicit
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
Private sMusicFile As String
Dim Play
Public Sub Sound2(ByVal File$)
sMusicFile = File 'path has been included. Ex. "C:\3rdMan.mp3
Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
If Play <> 0 Then 'this triggers if can't play the file
'Play = mciSendString("'play " & sMusicFile & "'", 0&, 0, 0) 'i tried this aproach, but doesn't seem to work
End If
End Sub
Public Sub StopSound(Optional ByVal FullFile$)
Play = mciSendString("close " & sMusicFile, 0&, 0, 0)
End Sub
Any help much appreciated, (I don't want workaround with external player popup, nor which I can't stop from playing with VBA)
i found The work-around, that correct spaces in path name (and (edit) for file name (using copy of file with no spaces, ugly but works (name as would not be a good solution) :
After the first attempt to play the sound, if fails i change the current directory to the sound directory (temporarely):
If Play <> 0 Then
Dim path$, FileName0$
path = CurDir
If InStr(sMusicFile, ":") > 0 Then ChDrive (Left(sMusicFile, 1))
If InStr(sMusicFile, "\") > 0 Then
ChDir (Left(sMusicFile, InStrRev(sMusicFile, "\") - 1))
FileName0 = Mid(sMusicFile, InStrRev(sMusicFile, "\") + 1)
If InStr(FileName0, " ") > 0 Then
FileCopy FileName0, Replace(FileName0, " ", "")
sMusicFile = Left(sMusicFile, InStrRev(sMusicFile, "\")) & Replace(FileName0, " ", "")
Play = mciSendString("play " & Replace(FileName0, " ", ""), 0&, 0, 0)
Else
Play = mciSendString("play " & FileName0, 0&, 0, 0)
End If
Else
FileName0 = Replace(sMusicFile, " ", "")
If sMusicFile <> FileName0 Then
FileCopy sMusicFile, FileName0
sMusicFile = FileName0
End If
Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
End If
ChDrive (Left(path, 1))
ChDir (Left(path, InStrRev(path, "\") - 1))
End If
Note : for spaces in the name i got also a new method : Filecopy sMusicFile replace(sMusicFile," ","%") and then play this new file
Go old-school...think DOS.
For example:
"C:\Way Too Long\Long Directory\File.mp3"
becomes
"C:\WayToo~1\LongDi~1\File.mp3"
The trick is to get rid of spaces and keep directories and filenames under 8 characters. To do this, remove all spaces, then truncate after the first 6 characters and add a tilde (~) plus the number one.
I tried this method and it worked perfectly for me.
One thing to be cautious of is that if there is a chance of ambiguity in a shortened directory name (like "\Long File Path\" and "\Long File Paths\" and "\Long File Path 1436\") then you'll need to adjust the number after the tilde ("\LongFi~1\" and "\LongFi~2\" and "\LongFi~3\", in the order in which the directories were created).
Therefore, it is possible that a previous folder was called "FilePa~1" and was deleted while a similarly named "FilePa~2" was left. So your file path may not automatically be suffixed with a "~1". It might be "~2" or something higher, depending on how many similarly named directories or filenames there were.
I find it incredible that dos was released 35 years ago, and VBA programmers are still having to deal with this dinosaur of a problem with directories!
Try:
Public Sub Sound2(ByVal File$)
If InStr(1, File, " ") > 0 Then File = """" & File & """"
sMusicFile = File
...
This will wrap the path in quotes if there is a space, which is required for some API functions.
The following solution works without having to copy the file.
It incorporates your code together with code from osknows in Get full path with Unicode file name with the idea from Jared above...
Option Explicit
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" _
(ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
Private sMusicFile As String
Dim Play, a
Public Sub Sound2(ByVal File$)
sMusicFile = GetShortPath(File)
Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
If Play <> 0 Then 'this triggers if can't play the file
'Play = mciSendString("'play " & sMusicFile & "'", 0&, 0, 0) 'i tried this aproach, but doesn't seem to work
End If
End Sub
Public Sub StopSound(Optional ByVal FullFile$)
Play = mciSendString("close " & sMusicFile, 0&, 0, 0)
End Sub
Public Function GetShortPath(ByVal strFileName As String) As String
'KPD-Team 1999
'URL: [url]http://www.allapi.net/[/url]
'E-Mail: [email]KPDTeam#Allapi.net[/email]
Dim lngRes As Long, strPath As String
'Create a buffer
strPath = String$(165, 0)
'retrieve the short pathname
lngRes = GetShortPathName(strFileName, strPath, 164)
'remove all unnecessary chr$(0)'s
GetShortPath = Left$(strPath, lngRes)
End Function
The function converts long full filename to 8.3 short format.
Function get8_3FullFileName(ByVal sFullFileName As String) As String
Dim FSO As Object: Set FSO = CreateObject("Scripting.FileSystemObject")
get8_3FullFileName = FSO.GetFile(sFullFileName).ShortPath
End Function
Try it.
Just a modest contribution to improve the VBA code
First →
Here is the piece of code before the correction :
Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
If Play <> 0 Then 'this triggers if can't play the file
'Play = mciSendString("'play " & sMusicFile & "'", 0&, 0, 0) 'i tried this
aproach, but doesn't seem to work
End If
Second →
And here is the piece of code after the correction :
Play = mciSendString("play " & sMusicFile, 0&, 0, 0)
If Play <> vbNull Then 'this triggers if can't play the file
Play = mciSendString("play " & sMusicFile, 0&, 0, 0) 'i tried this aproach, and it works
End If
Finally → The full code
Option Explicit
Private Declare PtrSafe Function mciSendString Lib "winmm.dll" Alias _
"mciSendStringA" (ByVal lpstrCommand As String, ByVal _
lpstrReturnString As Any, ByVal uReturnLength As Long, ByVal _
hwndCallback As Long) As Long
Private musicFile$
Dim Play As Variant
Public Sub Sound2(ByVal File$)
On Error GoTo errHandler
musicFile = File 'path has been included. Ex. "C:\3rdMan.mp3
If Play <> vbNull Then 'this triggers if can't play the file
Play = mciSendString("play " & musicFile, 0&, 0, 0) 'i tried this aproach and it works
End If
Exit Sub
errHandler:
MsgBox "The following error has occurred :" & vbCrLf _
& "Error number: " & Err.Number & vbCrLf _
& "Type of error : " & Err.Description, vbCritical
End Sub
Related
I tried a number of ways to construct the string to call notepad++ with a filename.
I need to also utilize the '-n' parameter for notepad++ to open a file at a particular line. Simple cases work, however when concatenating strings for the path I have been getting runtime 424 errors.
This is in VBA in Excel.
Option Explicit
Sub GoToLine()
Dim strNotePadPath As String
strNotePadPath = "C:\Program Files\NotePad++\notepad++.exe "
Dim strSourceBasePath As String
strSourceBasePath = "C:\VBAExcelTest\TestSource"
Dim strSourcePathFinal As String
strSourcePathFinal = strSourceBasePath & Cells(Selection.Row, 1).Value
Dim strLineNumber As String
strLineNumber = " -n" & Cells(Selection.Row, 2).Value
Dim retval As Variant
'This works: retval = Shell("C:\Program Files\NotePad++\notepad++.exe C:\VBAExcelTest\TestSource\SourceA\FakeSourceA.txt -n1", 1)
'I get a runtime error 424 on the Call Shell line below
If Selection.Row.Count = 1 Then
Call Shell("""" & strNotePadPath & strSourcePathFinal & strLineNumber & """", vbNormalFocus)
End If
End Sub
Sometimes a token-replacement approach is easier to manage when dealing with escaped quotes etc:
Sub GoToLine()
Dim cmd As String, retval As Variant, rw As Range
Set rw = Selection.Cells(1).EntireRow
cmd = Tokens("""{1}"" ""{2}"" {3}", _
"C:\Program Files\NotePad++\notepad++.exe", _
"C:\Tester\tmp\" & rw.Cells(1).Value, _
"-n" & rw.Cells(2).Value)
Debug.Print cmd
Shell cmd, vbNormalFocus
End Sub
'replace tokens in the first argument, using the rest of the arguments
Function Tokens(txt As String, ParamArray args() As Variant) As String
Dim i As Long, t As Long
t = 0
For i = 0 To UBound(args)
t = t + 1
txt = Replace(txt, "{" & t & "}", args(i))
Next i
Tokens = txt
End Function
The problem has been narrowed down to one line. It is an issue between absolute and relative path.
This line works:
PlayWavFile "c:\TransmissionFile\AWNP.wav", False
I prefer something like this but it does not work:
PlayWavFile "AWNP.wav", False
I have the wave file in both the C drive and in the same folder as the program. So for the program folder to be portable, I would like to use the relative path. How do I do that? What is wrong?
Try this:
Dim CurrentFolder As String
CurrentFolder = ThisWorkbook.Path
PlayWavFile CurrentFolder & Application.PathSeparator & "AWNP.wav", False
Your question leaves a few open questions. However, taking a best guess approach, I think this is what you're aiming to do:
Option Explicit
' assuming this is the Lib declaration:
Public Declare Function sndPlaySound Lib "winmm.dll" _
Alias "sndPlaySoundA" (ByVal lpszSoundName As String, _
ByVal uFlags As Long) As Long
' and assuming this is the sub format you're using to call (as declared) sndPlaySound
Sub PlayWavFile(WavFileName As String, Wait As Boolean)
' Set path based on this workbook's folder location
Dim stFilePath$: stFilePath = ThisWorkbook.Path & "\" & WavFileName
' If file is missing, try root of C drive
If Dir(stFilePath) = "" Then
stFilePath = "C:\" & WavFileName
' Not here either: report and end
If Dir(stFilePath) = "" Then
MsgBox WavFileName & " not found"
Exit Sub
End If
End If
' Play the sound (with/without wait)
If Wait Then
sndPlaySound stFilePath, 0
Else
sndPlaySound stFilePath, 1
End If
End Sub
When pressing the macro, it comes up with a Compile error: Wrong number of arguments or invalid property assignment. I finally got it to slightly work for 64bit, but now am running into this issue.
Private Function getUser() As String
Dim strUser As String
'Create a buffer
strUser = String(100, Chr(0))
'Get the username
getUser strUser, 100
'strip the rest of the buffer
strUser = Left(strUser, InStr(strUser, Chr(0)) - 1)
getUser = strUser
End Function
Here's the other one with getUser in it.
On Error Resume Next
Set MyOL = GetObject(, "Outlook.Application")
If MyOL Is Nothing Then
Set MyOL = CreateObject("Outlook.Application")
End If
strUser = getUser
Application.DisplayAlerts = False
ThisWorkbook.SaveAs "C:\Documents and Settings\" & strUser & "\Local Settings\Temp\" & " " & staffname & " - OT Survey for " & ActiveSheet.name & ".xlsm"
Application.DisplayAlerts = True
Your code is caused by getUser strUser, 100.
It's recursively calling itself (i.e. it's within the function called getuser), and is trying to pass two arguments to the function while the function header doesn't ask for them Private Function getUser() As String.
Basically everything that #JohnColeman commented.
How to fix that I've no idea.
The code does resemble what I've posted below, which returns the system user name.
Put the first line at the top of the module and remove PtrSafe if not on 64 bit.
Private Declare PtrSafe Function api_GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Function getUser() As String
On Error Resume Next
Dim NBuffer As String
Dim Buffsize As Long
Dim Wok As Long
Buffsize = 256
NBuffer = Space$(Buffsize)
Wok = api_GetUserName(NBuffer, Buffsize)
getUser = Trim$(NBuffer)
On Error GoTo 0
End Function
Saying all that - your SaveAs,where you use the user name, is looking for the temp folder - would just ENVIRON("Temp") work there?
ThisWorkbook.SaveAs Environ("Temp") & "\ " & staffname & " - OT Survey for " & ActiveSheet.Name & ".xlsm"
I have a code where you input information in an excel list. I want to be able to create a folder - I am using the code below. The issue is that I want it to work for all my colleagues (not just me). Can someone please help find where I am getting an error? Note this is a partial code, the error is happening on the MkDir line. Thanks for your help in advance!
Dim Startupfolder As String
Startupfolder = Startup_Name.Value
MkDir Environ$("Userprofile") & "\nc Dropbox\investment oportunities\ & "Startupfolder"
The problem is where you put your quotes. Try this:
MkDir Environ$("Userprofile") & "\nc Dropbox\investment oportunities\" & Startupfolder
Startupfolder is variable, so you don't want that within quotes
More info
If your folder is put in a not yet existing folder, it will fail. It will also fail if it already exists.
Try this instead:
Sub MakeDir()
CreateFolder Environ$("Userprofile") & "\nc Dropbox"
CreateFolder Environ$("Userprofile") & "\nc Dropbox\investment oportunities"
CreateFolder Environ$("Userprofile") & "\nc Dropbox\investment oportunities\" & Startupfolder
End Sub
Sub CreateFolder(Folder)
If Len(Dir(Folder, vbDirectory)) = 0 Then
MkDir Folder
End If
End Sub
I would use an API Call like that
Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal lpPath As String) As Long
and then you could call it like that
MakeSureDirectoryPathExists Environ$("Userprofile") & _
"\nc Dropbox\investment oportunities\" & Startupfolder & "\"
For a documentation look here resp here. Important as pointed out in the comments
If the final component of the path is a directory, not a file name, the string must end with a backslash character.
Public Function MakeFolder(FolderPath As String)
' if 123 is a folder then the path shall have a backslash at the end"
' e.g. strFolderName = "d:\abcd\efh\123\\"
Dim OFL As Integer
Dim OFR As Integer
Dim trimmedFolderPath As String
OFL = InStr(1, FolderPath, "\")
OFR = Len(FolderPath) - InStr(1, StrReverse(FolderPath), "\") + 1
trimmedFolderPath = Left([FolderPath], OFL)
Do While OFL <= OFR
If Dir(trimmedFolderPath, vbDirectory) = "" Then
MkDir trimmedFolderPath
Else
OFL = InStr(OFL + 1, FolderPath, "\")
If OFL > 0 Then
trimmedFolderPath = Left([FolderPath], OFL - 1)
Else
Exit Function
End If
End If
Loop
End Function
I have a folder with 30 or so .gz zipped files and 1 .zip files. I can ue code to utilise Windows Explorer to unzip the 1 .zip file, but unfortunately, Windows explorer does not unzip .gz files. I have created code which utilises Winzip to open all these files, but unfortunately this opens up the path folder, every time it unzips, I end up with 30+ open folders, which I then close, one by one with further code - unnecessary. A process that takes near 10 minutes.
Scouring the net, I've found and adapted a Ron De Bruin code that utilises '7-zip' software , open source and freely available online, to unzip without opening up a new folder each time. It unzips all files effortlessly in about a minute, far better. The code is below (mainly comments so not as long as it first looks!). My only problem is that sometimes this unzips files, and sometimes this runs without unzipping any files. When it runs perfectly, it toggles the 'GetExitCodePorcess hProcess, ExitCode' line longer, there I'm assuming it is processes to get an ExitCode which allows it to unzip the file. When it isn't working, it only toggles once or twice and moves onto the next stage, therefore, I assume that it generated the wrong exit code.
Is the problem the PtrSafe Function? Or is it in my ShellStr, or anywhere else? Please help, as I want to avoid using the Winzip method. If anyone has any other alternatives, please suggest!
#If VBA7 Then
Private Declare PtrSafe Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#Else
Private Declare Function OpenProcess Lib "kernel32" _
(ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hProcess As Long, _
lpExitCode As Long) As Long
#End If
Public Const PROCESS_QUERY_INFORMATION = &H400
Public Const STILL_ACTIVE = &H103
Public Sub ShellAndWait(ByVal PathName As String, Optional WindowState)
Dim hProg As Long
Dim hProcess As Long, ExitCode As Long
'fill in the missing parameter and execute the program
If IsMissing(WindowState) Then WindowState = 1
hProg = Shell(PathName, WindowState)
'hProg is a process ID under Win32. To get the process handle:
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, hProg)
Do
'populate Exitcode variable
GetExitCodeProcess hProcess, ExitCode
DoEvents
Loop While ExitCode = STILL_ACTIVE
End Sub
'With this example you unzip a fixed zip file: FileNameZip = "C:\Users\Ron\Test.zip"
'Note this file must exist, this is the only thing that you must change before you test it
'The zip file will be unzipped in a new folder in: Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'The name of the folder that the code create in this folder is the Date/Time
'You can change this folder to this if you want to use a fixed folder:
'NameUnZipFolder = "C:\Users\Ron\TestFolder\"
'Read the comments in the code about the commands/Switches in the ShellStr
Public Sub B_UnZip_Zip_File_Fixed()
Dim PathZipProgram As String, FolderPath As String
Dim UnzipFile As Variant, ShellStr As String
FolderPath = _
ThisWorkbook.Path
If Right(FolderPath, 1) <> "\" Then
FolderPath = FolderPath & "\"
End If
'Path of the Zip program
PathZipProgram = "C:\program files\7-Zip\"
If Right(PathZipProgram, 1) <> "\" Then
PathZipProgram = PathZipProgram & "\"
End If
'Check if this is the path where 7z is installed.
If Dir(PathZipProgram & "7z.exe") = "" Then
MsgBox "Please find your copy of 7z.exe and try again"
Exit Sub
End If
UnzipFile = _
Dir(FolderPath & "*.gz")
While UnzipFile <> _
""
If InStr(1, UnzipFile, ".gz") > _
0 Then
ShellStr = PathZipProgram & "7z.exe e -aoa -r" _
& " " & Chr(34) & UnzipFile & Chr(34) _
& " -o" & Chr(34) & FolderPath & Chr(34) & " " & "*.*"
ShellAndWait ShellStr, vbHide
End If
UnzipFile = _
Dir
Wend
'Create path and name of the normal folder to unzip the files in
'In this example we use: Application.DefaultFilePath
'Normal if you have not change it this will be your Documents folder
'The name of the folder that the code create in this folder is the Date/Time
'NameUnZipFolder = Application.DefaultFilePath & "\" & Format(Now, "yyyy-mm-dd h-mm-ss")
'You can also use a fixed path like
'NameUnZipFolder = "C:\Users\Ron\TestFolder\"
'Name of the zip file that you want to unzip (.zip or .7z files)
'FileNameZip = "C:\Users\Ron\Test.zip"
'There are a few commands/Switches that you can change in the ShellStr
'We use x command now to keep the folder stucture, replace it with e if you want only the files
'-aoa Overwrite All existing files without prompt.
'-aos Skip extracting of existing files.
'-aou aUto rename extracting file (for example, name.txt will be renamed to name_1.txt).
'-aot auto rename existing file (for example, name.txt will be renamed to name_1.txt).
'Use -r if you also want to unzip the subfolders from the zip file
'You can add -ppassword if you want to unzip a zip file with password (only .7z files)
'Change "*.*" to for example "*.txt" if you only want to unzip the txt files
'Use "*.xl*" for all Excel files: xls, xlsx, xlsm, xlsb
'MsgBox "Look in " & NameUnZipFolder & " for extracted files"
End Sub
No, the exit code tells you the result of the external process that you spawned. For Windows 0 indicates success, non-zero indicates failure (or something else that meant the process wasn't successful)
So basically for some of .gz files 7zip can't complete successfully. You as the coder need to deal with this likely eventuality.
So your best bet is to print/log the 7zip command that it ran ShellStr and run that yourself manually in a command prompt/dos window to see the reason why.