Batch Convert TDM files to XLS - excel

MY GOAL: Batch convert all .TDM files in a folder to .XLS using an existing add-in by adapting this macro that only works 1 file at a time. (Also open to any VBA approach.)
Using an existing add-in, a single .TDM file is converted into a single .XLS workbook with multiple sheets.
I need to, instead of using a prompt to select a single .TDM file, automatically convert all .TDM files in a folder into new .XLS workbooks.
This is part of a multi-stage process. I tried various loops, mimicking other set-ups, and merging it with other code I found on various community boards.
FYI: .TDM files hold engineering data output produced by testing equipment.
Sub GetTDM_AddIn()
'Get TDM Excel Add-In
Dim obj As COMAddIn
Set obj = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
'obj.Connect = True
'Confirm only importing "Description" properties for Root
Call obj.Object.Config.RootProperties.DeselectAll
Call obj.Object.Config.RootProperties.Select("Description")
'Show the group count as property
Call obj.Object.Config.RootProperties.Select("Groups")
'Select all the available properties for Group
Call obj.Object.Config.GroupProperties.SelectAll
'Import custom properties
obj.Object.Config.RootProperties.SelectCustomProperties = True
obj.Object.Config.GroupProperties.SelectCustomProperties = True
obj.Object.Config.ChannelProperties.SelectCustomProperties = True
'Let the user choose which file to import
Dim fileName
fileName = Application.GetOpenFilename("TDM & TDMS (*.tdm;*.tdms),*.tdm;*.tdms")
If fileName = False Then
' User selected Cancel
Exit Sub
End If
'Import the selected file
Call obj.Object.ImportFile(fileName)
'Record down the current workbook
Dim Workbook As Object
Set Workbook = ActiveWorkbook
End Sub

Below is an Excel Macro (VBA Script) I wrote to do something very similar to what you want to do. It converts a directory of .tdms files to their equivalent .csv files. It requires the ExcelTDM Add In (NITDMEXCEL_2015-0-0.exe) which I obtained at http://www.ni.com/example/27944/en/. I tested the script in Excel 2013 running on a modest Windows 7 Pro machine converting 24 TDMS files with 120,000 rows each file. It completed the conversions without error in about 2 minutes 30 seconds which is about 7 seconds per file. Please forgive my hasty error handling and poor VBA form.
Sub ConvertTDMStoCSV()
'
' ConvertTDMS Macro
'
' Acts upon all .tdms files in a "source" directory,
' loading each one using the ExcelTDM Add In,
' deleting the first sheet and saving the
' remaining stream data as one .csv file
' in a "target" directory. Writes a list of
' the files converted in a new sheet.
'
' Tested to work with Excel 2013 on Windows 7
' with NITDMEXCEL_2015-0-0.exe obtained at
' http://www.ni.com/example/27944/en/
Dim sourceDir As String, targetDir As String, fn As String, fnBase As String
Dim fso As Object, n As Long, resp As Integer, strNow As String, newSheet As Object
Dim tdmsAddIn As COMAddIn, importedWorkbook As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set tdmsAddIn = Application.COMAddIns.Item("ExcelTDM.TDMAddin")
tdmsAddIn.Connect = True
Call tdmsAddIn.Object.Config.RootProperties.DeselectAll
Call tdmsAddIn.Object.Config.ChannelProperties.DeselectAll
tdmsAddIn.Object.Config.RootProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.GroupProperties.SelectCustomProperties = False
tdmsAddIn.Object.Config.ChannelProperties.SelectCustomProperties = False
'Choose TDMS Source Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Source Directory of TDMS Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
sourceDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(sourceDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, sourceDir
Exit Sub
End If
'Choose CSV Target Directory
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Choose Target Directory for CSV Files"
.AllowMultiSelect = False
.InitialFileName = ThisWorkbook.Path & "\"
.Show
On Error Resume Next
targetDir = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
If Dir(targetDir, vbDirectory) = "" Then
MsgBox "No such folder.", vbCritical, targetDir
Exit Sub
End If
fn = Dir(sourceDir & "\*.tdms")
If fn = "" Then
MsgBox "No source TDMS files found.", vbInformation
Exit Sub
End If
resp = MsgBox("Begin conversion of TDMS files?" & vbCrLf & sourceDir & vbCrLf & "to" & vbCrLf & targetDir, vbYesNo, "Confirmation")
If resp = vbNo Then
MsgBox "Execution cancelled by user."
Exit Sub
End If
Set newSheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
strNow = WorksheetFunction.Text(Now(), "m-d-yyyy h_mm_ss")
newSheet.Name = strNow
newSheet.Cells(1, 1).Value = "Files converted on " & strNow
newSheet.Cells(2, 1).Value = "TDMS Source Directory: " & sourceDir
newSheet.Cells(3, 1).Value = "CSV Target Directory: " & targetDir
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
n = 5
Do While fn <> ""
fnBase = fso.GetBaseName(fn)
On Error Resume Next
Call tdmsAddIn.Object.ImportFile(sourceDir & "\" & fn, True)
If Err Then
MsgBox Err.Description, vbCritical
Exit Sub
End If
Set importedWorkbook = ActiveWorkbook
Application.DisplayAlerts = False
importedWorkbook.Sheets(1).Delete
importedWorkbook.SaveAs Filename:=targetDir & "\" & fnBase & ".csv", FileFormat:=xlCSV
importedWorkbook.Close savechanges:=False
Application.DisplayAlerts = True
newSheet.Cells(n, 1).Value = fnBase
n = n + 1
fn = Dir
Loop
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Set fso = Nothing
Set newSheet = Nothing
Set importedWorkbook = Nothing
End Sub

Instead of trying to do this in VBA, I suggest that you use powershell to get all of the files and then call the Excel macro, for each file, using the Run method.
You'll also need to modify the macro to either (1) run on the current open file (solution below); or (2) take a filename as an argument (this changes the call to Run below)
The code is something like this (modify the call to get-childitem to fit your applicaton):
$excel = new-object -comobject excel.application
$files = get-childitem ... #etc, collect your files into an array
foreach ($file in $files)
{
$wb = $excel.workbooks.open($file.fullname)
$ws= $wb.worksheets.item(1)
$ws.Activate()
$excel.Run("GetTDM_AddIn")
$wb.save()
$wb.close()
}
$excel.quit()

I used this simple app to convert tdms files.
It supports multiple files and has command line support.
http://www.whiterocksoftware.com/2019/11/batch-convert-tdms-to-excel.html

Related

VBA overwrite file if already exists

I'd like to check if a file located in my_path exists, if it does overwrite it with a file declared "garcat" containing 1 single sheet. Creating a file for the 1st time works, however overwriting it gives me this error 1004: Method 'SaveAs' of object'_Workbook' failed
Sub FileCreate(ByVal TGName As String)
Dim garcat As Workbook
Dim file As String
file = my_path
If Dir(file) <> "" Then
SetAttr file, vbNormal
Kill file
MsgBox "The file already exists, it will be replaced"
End If
Application.SheetsInNewWorkbook = 1
Set garcat = Workbooks.Add
garcat.SaveAs FileName:=file
MsgBox "File Saved"
garcat.Sheets(1).name = "GARCAT " & TGName
garcat.Close (True)
End Sub
EDIT: I set Application.DisplayAlerts = False and Application.EnableEvents = False before saving the file and I still get the pop-up error message.
This works by just telling the file to save regardless of any other factors: "And no back-talk! If there's already a file there... Just overwrite it."
Sub FileCreate(ByVal TGName As String)
Dim garcat As Workbook
Dim chemin As String
file = my_path
Application.SheetsInNewWorkbook = 1
Set garcat = Workbooks.Add
Application.DisplayAlerts = False
garcat.SaveAs FileName:=file
Application.DisplayAlerts = True
MsgBox "File Saved"
garcat.Sheets(1).name = "GARCAT " & TGName
garcat.Close (True)

VBA code executes but only if I step thru it

I used some code from Close an opened PDF after opening it using FollowHyperlink to create the following code to open a pdf file and rename it. The code runs fine but only if I break execution at MsgBox "Break Here" and step into it with the F8 key. Any ideas on why it won't execute automatically?
Sub OpenPDF()
'Opens PDF Scaned file & saves it to another folder
'***ErrorHandler***
On Error Resume Next
'***Declare Objects****
Dim objectWMI As Object
Dim objectProcess As Object
Dim objectProcesses As Object
Dim Path As String
Dim MyDir As String
'***Opens a new workbook if there are no active workbooks***
'***There must be an active workbook for FollowHyperlink to function***
nowbs = Application.Workbooks.Count
If nowbs = 1 Then
Application.Workbooks.Add
Else
End If
'***Saves current Excel path
MyDir = CurDir
'***Sets path to Ricoh Scans
PDFDir = "S:\Ricoh Scans"
ChDir PDFDir
'***Gets filename for PDF scan
Path = Application.GetOpenFilename(filefilter:="PDF file (*.pdf), *.pdf")
'***Opens PDF file***
ActiveWorkbook.FollowHyperlink Path
'***Sets Excel as active application
AppActivate "Microsoft Excel"
'***Prompts for PO number****
MyPONum = InputBox("Enter PO Number", "PO Editor", "30500")
'***If user selects Cancel on inputbox then xl closes Acrobat and exits sub
If MyPONum = vbNullString Then
GoTo EndAll
Else
End If
'***Replaces scanned filename with inputbox filename
PathLen = Len(Path)
OldName = Mid(Path, 16, PathLen - 19)
NewName = "S:\Materials Management\Purchase Orders\PO " & MyPONum & ".pdf"
EndAll:
'***Set Objects***
Set objectWMI = GetObject("winmgmts://.")
Set objectProcesses = objectWMI.ExecQuery("SELECT * FROM Win32_Process WHERE Name = 'Acrobat.exe'") '< Change if you need be ** Was AcroRd32.exe**
'
'
'Code executes fine up to here but must Ctrl + Break at this line
'and F8 step thru balance of code or it will not work
'
'
MsgBox "Break Here"
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
Call objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub
Thanks to all for your input. I'm not a programmer and as I said I used code that had been posted elsewhere on this site. It was a timing issue and this edit works.
'***Terminate all Open PDFs***
For Each objectProcess In objectProcesses
objectProcess.Terminate
Next
'***Clean Up***
Set objectProcesses = Nothing
Set objectWMI = Nothing
'***************
Application.Wait (Now + TimeValue("00:00:02"))
'***Renames scanned file and moves it to Materials Management folder***
Name Path As NewName
'***Resets current directory
ChDir MyDir
End Sub

Subscript Out of Range Error because no ReDim?

Not sure why I am getting this error. Please assist in correcting and also, provide a good explanation for the reason. I have 3 subs (from 2 modules) that call each other sequentially. Is the reason for the error message because the file name from the first sub is declared as a variable in the third sub? See code below:
Module1:
Option Explicit
Sub PRM_1_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_1_New As Workbook ' This is BCRS-PTASKS Unassigned.csv
Set PRM_1_New = Workbooks("BCRS-PTASKS Unassigned.csv")
Dim SaveDir1 As String, prmAfn As String
SaveDir1 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir1, vbDirectory)) = 0 Then MkDir SaveDir1
prmAfn = SaveDir1 & "\PRM_1_TEMP"
Application.SendKeys ("~")
PRM_1_New.SaveAs Filename:=prmAfn, FileFormat:=xlOpenXMLWorkbook
PRM_1_New.Close False
Call PRM_2_Report_Save
Application.ScreenUpdating = True
End Sub
Sub PRM_2_Report_Save()
'
Application.ScreenUpdating = False
Dim PRM_2_New As Workbook ' This is Problem WGM & WGL xref with description.xls
Set PRM_2_New = Workbooks("Problem WGM & WGL xref with description.xls")
Dim SaveDir2 As String, prmBfn As String
SaveDir2 = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
If Len(Dir(SaveDir2, vbDirectory)) = 0 Then MkDir SaveDir2
prmBfn = SaveDir2 & "\PRM_2_TEMP"
Application.SendKeys ("~")
PRM_2_New.SaveAs Filename:=prmBfn, FileFormat:=xlOpenXMLWorkbook
PRM_2_New.Close False
Application.ScreenUpdating = True
Call Open_PRM_Files
End Sub
Module 2:
Option Explicit
Sub Open_PRM_Files()
'
Application.ScreenUpdating = False
Dim PRM_Dir As String
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
Application.ScreenUpdating = True
End Sub
This line from the sub in Module2 is where the debugger shows the error (which is also commented in the sub above):
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
The purpose of the code here is to save two imported reports into .xlsx format, close them, and then open the files in the saved format. I need this to occur in separate subs (save and open) for other workflow processes of this VBA Project not listed (or relevant) here.
EDIT: I should also mention that the first two subs execute and provide the intended results which is each file saved in the new directory and with the proper extension.
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx")
This line assumes that you already have an open workbook with that name. If Excel does not find an open workbook with that name then you will get a runtime error as you noticed.
I'm assuming that you are trying to open the workbooks here which you created in the first two subs:
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_1_TEMP
Workbooks.Open Filename:=PRM_Dir & "\" & PRM_2_TEMP
"& PRM_1_TEMP" is the name of a Workbook variable, and you're trying to concatenate it as a string name. Change this to a string matching the filename, and then move your declarations of workbooks to below the code that opens the workbooks. This way Excel opens the workbooks BEFORE trying to access them in the Workbooks collection, and you should not receive an error. I haven't tested this modification, but please let me know if it works for you.
Sub Open_PRM_Files()
Application.ScreenUpdating = False
Dim PRM_Dir As String
PRM_Dir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\PRM Temp Files"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_1_TEMP"
Workbooks.Open Filename:=PRM_Dir & "\" & "PRM_2_TEMP"
Dim PRM_1_TEMP As Workbook
Set PRM_1_TEMP = Workbooks("PRM_1_TEMP.xlsx") ' This is the line that get's the error
Dim PRM_2_TEMP As Workbook
Set PRM_2_TEMP = Workbooks("PRM_2_TEMP.xlsx")
Application.ScreenUpdating = True
End Sub

How can I open multiple Excel files and execute a contained macro on each?

I'm looking to open multiple Excel files and run the same macro (contained in each) on each file.
For example, I'd like to automatically open every file in h:\dbs and execute the CmdUpdate_Click macro within each file.
How might I go about this?
Try something like this. I expect you can research how to open the Visual Basic Editor and figure out where to paste this.
'Declare variables
Dim FolderObj, FSO, FileObj As Object
Dim FolderDialog As FileDialog
'Create and run dialog box object
Set FolderDialog = Application.FileDialog(msoFileDialogFolderPicker)
With FolderDialog
.ButtonName = "Select"
.AllowMultiSelect = False
.InitialFileName = "B:\BIM Projects\"
.InitialView = msoFileDialogViewDetails
'Check if user canceled dialog box
'Exit if yes
If .Show = -1 Then
MsgBox "No Folder Selected"
Exit Sub
End If
End With
'Check if user canceled dialog box
'Exit if yes
'Create a File System Object to be the folder that was selected
Set FSO = CreateObject("scripting.filesystemobject")
Set FolderObj = FSO.getfolder(FolderLocation)
'For each obj in the selected folder
For Each FileObj In FolderObj.Files
'Test if the file extension contains "xl" and make sure it's an Excel file before opening
If InStr(1, Right(FileObj.Name, Len(FileObj.Name) - InStr(1, FileObj.Name, ".")), "xl") = 1 Then
'Prevent the workbook from displaying
ActiveWindow.Visible = False
'Open the Workbook
Workbooks.Open (FolderObj & "\" & FileObj.Name)
'Run the Macro
Application.Run "'" & FolderObj & "\" & FileObj.Name & "'!CmdUpdate_Click"
'Save the Workbook
Workbooks(FileObj.Name).Save
'Close the Workbook
Workbooks(FileObj.Name.Close
End If
'Turn this back on
ActiveWindow.Visible = True
Next
I will caution you that this is based on some code I wrote for Word, so there are no guarantees it will work and I don't have time to test it. It will, however, give you a very good start if it doesn't.
Edit to Add: You may

How to recursively check all subfolders for existing Excel files and extract all VBA code

I'm looking for a way how to combine PowerShell script with VBscript to extract all VBA/win32 code from a lot of excel files in complicated folder structure.
I need to recursively check all subfolders for existing Excel files (PSH) and extract all code VBA/win32/dialogs (VBS) to text files on the same folder level for each Excel sheet.
I have found VBscript which can extract VBA code from excel sheets see link and code below. Now I'd like to combine it to one PowerShell script.
Could you please kindly help me?
http://www.pretentiousname.com/excel_extractvba/index.html
CODE:
option explicit
Const vbext_ct_ClassModule = 2
Const vbext_ct_Document = 100
Const vbext_ct_MSForm = 3
Const vbext_ct_StdModule = 1
Main
Sub Main
Dim xl
Dim fs
Dim WBook
Dim VBComp
Dim Sfx
Dim ExportFolder
If Wscript.Arguments.Count <> 1 Then
MsgBox "As the only argument, give the FULL path to an XLS file to extract all the VBA from it."
Else
Set xl = CreateObject("Excel.Application")
Set fs = CreateObject("Scripting.FileSystemObject")
xl.Visible = true
Set WBook = xl.Workbooks.Open(Trim(wScript.Arguments(0)))
ExportFolder = WBook.Path & "\" & fs.GetBaseName(WBook.Name)
fs.CreateFolder(ExportFolder)
For Each VBComp In WBook.VBProject.VBComponents
Select Case VBComp.Type
Case vbext_ct_ClassModule, vbext_ct_Document
Sfx = ".cls"
Case vbext_ct_MSForm
Sfx = ".frm"
Case vbext_ct_StdModule
Sfx = ".bas"
Case Else
Sfx = ""
End Select
If Sfx <> "" Then
On Error Resume Next
Err.Clear
VBComp.Export ExportFolder & "\" & VBComp.Name & Sfx
If Err.Number <> 0 Then
MsgBox "Failed to export " & ExportFolder & "\" & VBComp.Name & Sfx
End If
On Error Goto 0
End If
Next
xl.Quit
End If
End Sub
Recursion in PowerShell is as simple as this:
Get-ChildItem 'C:\base\folder' -Include '*.xls*' -Recurse | % {
& cscript.exe //NoLogo 'C:\path\to\your.vbs' $_.FullName
}
However, rather than running a VBScript for each file I would recommend translating your VBScript code to PowerShell. It doesn't require much effort, and it will also improve overall performance of your code.

Resources