How do i program in excel VBA to run an external program with the external program being able to output the data collected into a file? My external program, voltage.exe, when run normally (double click the program on the desktop screen) will output the data collected into a file data.txt. However when run with my code below, the file data.txt was not being created.
Sub Button1_Click() ' run logger
Dim path As String
path = ActiveWorkbook.path
path = path + "\Voltage Recording.exe"
retval = Shell(path, vbNormalFocus)
End Sub
your file is created in the current directory, that you can get its path by function: CurDir() you can change the current directory by calling SetCurrentDirectory function:
Declare Function SetCurrentDirectory Lib "kernel32" Alias "SetCurrentDirectoryA" (ByVal lpPathName As String) As Long
Sub Button8_Click()
MsgBox ("Old Dir = " & CurDir())
SetCurrentDirectory ActiveWorkbook.path
MsgBox ("Current Dir = " & CurDir())
Dim path As String
path = ActiveWorkbook.path
path = path + "\Voltage Recording.exe"
MsgBox (path)
retval = Shell(path, vbNormalFocus)
End Sub
Related
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
Actually I have coded the following macro based on FileCopy method.
'MyObject copy function:
Public Function OutputFile(ByVal SrcPath As String, ByVal TrgPath As String) As Boolean
If pDoesFileExist(SrcPath) Then '<= Internal private function to check if file exists
FileCopy SrcPath, TrgPath
OutputFile = True
Else
OutputFile = False
End If
End Function
Invoked from:
'Called subroutine from main program:
Sub OutputFiles(ByRef MyCollection As Collection, SourcePath As String, TargetPath As String)
Dim Obj As MyObject
With MyForm
.Show "Modeless"
For Each Obj In MyCollection
If Obj.OutputFile(SourcePath, TargetPath) Then
.TextBoxResult.Text = .TextBoxResult.Text & "File copied." & vbNewLine
Else
.TextBoxResult.Text = .TextBoxResult.Text & "File not copied!" & vbNewLine
End if
Next Obj
End With
End Sub
The macro works perfectly when I make it run from/to my local computer folders, regardless of the file size (from a few KB to 20MB more or less).
But when I make it run using a work-domain source path (which is obviously slower than my computer), the instruction line FileCopy "freezes" on large files. The program is still running in background and the files are getting copied succesfully, however MyForm will go stucked [No Response] until the end of the execution.
Debugging step-by-step works "fine", I just have to wait that FileCopy instruction returns (10 seconds aprox), then keep moving forward.
I would like to know if there is a possible way to force this "wait until FileCopy returns", or to grant an immunity to the rest of my code against these mini freezes?
I have a macro that compiles rows within tables across multiple files. All files are essentially copies of the "master" file. Each file is used by a different person.
The rows to copy are on "Table_Data" in "Tracker" sheet, with these names being stored in constant variables.
The macro first checks if the pre-defined list of individual files exist in the same folder and are not open.
Once that check is passed, the files are opened one by one, with all data in the table read into an array.
That array is looped through to copy rows, that fit certain requirements, into a compiled array.
Once that is done, the array is emptied, file #1 is closed and file #2 is opened to repeat the above step.
Once all required rows have been copied into the compiled array, the array is pasted in the master file.
As part of error checking, I want to check if the pre-defined list of files have the correct sheetname and the correct table name inside that sheet, BEFORE opening the file. If one of the files is not valid, I don't want the compiler to start.
I found snippets of code, but I haven't been able to make any of them give me a True/False on whether or not the sheet and table exist on the file while the file is closed.
Checking If A Sheet Exists In An External Closed Workbook
Excel VBA - Get name of table based on cell address
I have this, however, the file has to be opened, which slows down the macro.
To save time, I call it before copying the rows from each file and if the file is not valid, do not compile and show message stating which files are not valid.
Option Explicit
Function IsFileValid(ByVal strFileName As String) As Boolean
Dim wb As Workbook
Application.ScreenUpdating = False
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & strFileName, True, True)
On Error Resume Next
If Worksheets(wrkshtTracker).ListObjects(tableTracker).Range(1, 2) = strEmailHeader Then
IsFileValid = True
End If
wb.Close False
Set wb = Nothing
On Error GoTo 0
Application.ScreenUpdating = True
End Function
I want this check before opening the files.
Let's say our excel file looks like this
Logic:
Copy the excel file to user temp directory and rename it to say "Test.Zip"
Unzip the Zip files
We will keep our attention to 2 different folders. \xl\worksheets and \xl\tables. This is where the xml files are created.
\xl\worksheets If a sheet exists then an xml will be created with that name as shown below.
\xl\tables If a table exists then an xml will be created as shown below. However in this case, it is not necessary that the name of the table will be the same as the file name. However the name of the table will be inside the xml file as shown below
and this is the content of the 2nd xml file.
So simply check if the xml file exists for the sheet and for the table, check the contents of the file.
Code:
Option Explicit
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" _
(ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Const MAX_PATH As Long = 260
Dim zipFilePath As Variant
Dim tmpDir As Variant
Dim filePath As String
Dim oApp As Object
Dim StrFile As String
Sub Sample()
filePath = "C:\Users\routs\Desktop\sid.xlsx"
tmpDir = TempPath & Format(Now, "ddmmyyhhmmss")
zipFilePath = tmpDir & "\Test.Zip"
MsgBox DoesSheetExist("Sheet1")
MsgBox DoesTableExist("Table13")
End Sub
'~~> Function to check if a sheet exists
Private Function DoesSheetExist(wsName As String) As Boolean
MkDir tmpDir
FileCopy filePath, zipFilePath
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(tmpDir & "\").CopyHere oApp.Namespace(zipFilePath).items
If Dir(tmpDir & "\xl\worksheets", vbDirectory) <> "" Then
StrFile = Dir(tmpDir & "\xl\worksheets\*.xml")
Do While Len(StrFile) > 0
If UCase(Left(StrFile, (InStrRev(StrFile, ".", -1, vbTextCompare) - 1))) = UCase(wsName) Then
DoesSheetExist = True
Exit Do
End If
StrFile = Dir
Loop
End If
If Len(Dir(tmpDir, vbDirectory)) <> 0 Then
CreateObject("Scripting.FileSystemObject").DeleteFolder tmpDir
End If
End Function
'~~> Function to check if a table exists
Private Function DoesTableExist(tblName As String) As Boolean
Dim MyData As String, strData() As String
Dim stringToSearch As String
stringToSearch = "name=" & Chr(34) & tblName & Chr(34)
MkDir tmpDir
FileCopy filePath, zipFilePath
Set oApp = CreateObject("Shell.Application")
oApp.Namespace(tmpDir & "\").CopyHere oApp.Namespace(zipFilePath).items
If Dir(tmpDir & "\xl\tables", vbDirectory) <> "" Then
StrFile = Dir(tmpDir & "\xl\tables\*.xml")
Do While Len(StrFile) > 0
Open tmpDir & "\xl\tables\" & StrFile For Binary As #1
MyData = Space$(LOF(1))
Get #1, , MyData
Close #1
If InStr(1, MyData, stringToSearch, vbTextCompare) Then
DoesTableExist = True
Exit Do
End If
StrFile = Dir
Loop
End If
If Len(Dir(tmpDir, vbDirectory)) <> 0 Then
CreateObject("Scripting.FileSystemObject").DeleteFolder tmpDir
End If
End Function
'~~> Function to get user temp directory
Private Function TempPath() As String
TempPath = String$(MAX_PATH, Chr$(0))
GetTempPath MAX_PATH, TempPath
TempPath = Replace(TempPath, Chr$(0), "")
End Function
I wish to check whether a file exist in a folder on my computer. I have below, which can see if a specific file exists:
Function FileExists(sFile As String)
sPath = "M:\User\" & sFile & ".xlsm"
FileExists = Dir(sPath) <> ""
End Function
However, my files are named like: Filename - Version xx.xlsm and is updated regularly. Please note that there will only be one file in the folder, but the filename can vary.
How can I search in the folder using wildcard:
Filename - Version % % and then, if it find any file, open the file afterwards?
One option would be to Open the file inside of the FileExists function. However, I would not recommend doing this. The function should do exactly what the name implies and nothing more.
Another option is restructure your code a little bit:
Private Sub OpenFile()
Dim FileName As String
FileName = GetFile("Filename - Version*")
If FileName <> "" Then
'open FileName as needed
End If
End Sub
Private Function GetFile(sFile As String) As String
sPath = "M:\User\" & sFile & ".xlsm"
GetFile = Dir(sPath)
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.