Ошибка времени выполнения при экспорте файла TDMS в Excel с использованием надстройки tdmsAddIn.Connect в коде VBA - PullRequest
0 голосов
/ 29 ноября 2018

Я пытался экспортировать файлы NI TDMS в мою рабочую книгу и нашел код VBA, опубликованный Джеймсом Хамфри, который именно то, что я ищу.Проблема в том, что всякий раз, когда я пытаюсь запустить код, он выдает ошибку времени выполнения, которая в основном говорит о том, что только администратор может выполнить код.

Прилагается фрагмент ошибки и код, который я использовал из поста Джеймса Хамфри.

enter image description here

Поскольку я не являюсь администратором,У кого-нибудь есть решение этой проблемы?Спасибо.

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.
'
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
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...