Hi all
The below script currently only works on 1 file at a time and I require it to run through all files in a folder location.
I need
In addition I need it to print the results on the next available row so that it does not overwrite previous data.
It also needs to return the file name in column A.
I can not seem to do this successfully at he moment.
I need it to start with the first file in a folder extract the data as specified in the script.
Print this to the final sheet on the next available row.
In addition it needs to add the file name in the first column
close the file and then move onto the next file in the folder location
The below script currently only works on 1 file at a time and I require it to run through all files in a folder location.
I need
In addition I need it to print the results on the next available row so that it does not overwrite previous data.
It also needs to return the file name in column A.
I can not seem to do this successfully at he moment.
I need it to start with the first file in a folder extract the data as specified in the script.
Print this to the final sheet on the next available row.
In addition it needs to add the file name in the first column
close the file and then move onto the next file in the folder location
Code:
Option Explicit
Option Base 1
Public Const DATASHEET As String = "MDFDATA"
Public Const TABLECONVERSIONSHEET As String = "TABLECONVERSION"
Public Const OPTIONSSHEET As String = "OPTIONS"
Public Const FinalSheet As String = "Final Sheet"
Public lByte_Order As Long 'byte order
Public lData_Groups As Long 'number of data groups
Public lChannel_Groups As Long 'number of channel groups
Public lChannels As Long 'number of channels
Public lTable_offset As Long 'row offset for the conversion table sheet
'==================================================================================================
' PARSE_MDF
' Main function
' Returns True if successful
'==================================================================================================
Function PARSE_MDF() As Boolean
Dim sFile_Name As String 'MDF file name
Dim lFile_Number As Long 'file number
Dim lData_Groups_Counter As Long 'data groups counter
Dim lChannel_Groups_Counter As Long 'channel groups counter
Dim lChannels_Counter As Long 'channels counter
Dim lRecords As Long 'number of records in data block
Dim lRecord_Length As Long 'length of record in data block
Dim lData_Group_Address As Long 'data group address
Dim lData_Address As Long 'data address
Dim lChannel_Group_Address As Long 'Channel group address
Dim lChannel_Address As Long 'Channel address
Dim byCol As Byte 'column counter for output
Dim wsData_Sheet As Worksheet 'main worksheet
Dim wsTable_Conversion_Sheet As Worksheet
Dim rFirst_Signal As Range 'first signal in channel group
Dim rLast_Signal As Range 'last signal in channel group
Dim rSignals As Range 'range of signal names for a channel group
Application.EnableEvents = False
lTable_offset = 0
Set wsTable_Conversion_Sheet = Workbooks(ActiveWorkbook.Name).Worksheets(TABLECONVERSIONSHEET)
Set wsData_Sheet = Workbooks(ActiveWorkbook.Name).Worksheets(DATASHEET)
'get file name
sFile_Name = Application.GetOpenFilename(",*.*")
'file selected
If sFile_Name <> "False" Then
'clear old data
wsData_Sheet.Columns.Clear
wsTable_Conversion_Sheet.Columns.ClearContents
'set headers
wsData_Sheet.Cells(1, 1).Value = "Signal name"
wsData_Sheet.Cells(2, 1).Value = "Data type"
wsData_Sheet.Cells(3, 1).Value = "Lsb"
wsData_Sheet.Cells(4, 1).Value = "Offset"
wsData_Sheet.Cells(5, 1).Value = "Bit length"
wsData_Sheet.Cells(6, 1).Value = "Formula ID"
wsData_Sheet.Cells(7, 1).Value = "Formula"
wsData_Sheet.Cells(8, 1).Value = "First Bit position"
wsData_Sheet.Cells(9, 1).Value = "Table length"
wsData_Sheet.Cells(10, 1).Value = "Start Row"
'offset columns because of headers
byCol = 2
'get file number
lFile_Number = FreeFile
'open file
Open sFile_Name For Binary Access Read Shared As #lFile_Number
'check file integrity
If IDBLOCK(lFile_Number) Then
'check data exists
If HDBLOCK(lFile_Number, lData_Group_Address) Then
'main iteration for data groups
For lData_Groups_Counter = 1 To lData_Groups
'check channel group exists
If DGBLOCK(lFile_Number, lData_Group_Address, lChannel_Group_Address, lData_Address) Then
'channel group iteration
For lChannel_Groups_Counter = 1 To lChannel_Groups
'get channel group data
Call CGBLOCK(lFile_Number, lChannel_Group_Address, lChannel_Address, lRecord_Length, lRecords)
'set the first signal range in this channel group
Set rFirst_Signal = wsData_Sheet.Cells(1, byCol)
'channels iteration
For lChannels_Counter = 1 To lChannels
'get channel data for each channel
Call CNBLOCK(lFile_Number, lChannel_Address, wsData_Sheet, byCol)
'excel fudge
If byCol <> 255 Then
byCol = byCol + 1
End If
Next 'lChannels_Counter
'set the last signal range in this channel group
Set rLast_Signal = wsData_Sheet.Cells(1, byCol - 1)
'format divider columns
wsData_Sheet.Columns(byCol).ColumnWidth = 5
wsData_Sheet.Columns(byCol).Interior.ColorIndex = 0
wsData_Sheet.Columns(byCol).Interior.Pattern = xlLightUp
wsData_Sheet.Columns(byCol).Interior.PatternColorIndex = xlAutomatic
'excel fudge
If byCol <> 255 Then
'for space between channels
byCol = byCol + 1
End If
Next 'lChannel_Groups_Counter
'get range of signals to get data for
Set rSignals = wsData_Sheet.Range(rFirst_Signal, rLast_Signal)
'get signal data
'no channel data in this data group
Else
PARSE_MDF = False
End If
Next 'lData_Groups_Counter
'no data in MDF file
Else
PARSE_MDF = False
End If
'not a MDF file
Else
PARSE_MDF = False
End If
'close file
Close #lFile_Number
'tidy up sheet
wsData_Sheet.Rows.EntireRow.AutoFit
wsData_Sheet.Columns.EntireColumn.AutoFit
wsData_Sheet.Rows("2:15").EntireRow.Delete
wsData_Sheet.Columns("A:A").EntireColumn.Delete
wsData_Sheet.Cells.HorizontalAlignment = xlCenter
'function ends normally
PARSE_MDF = True
'no file was selected
Else
PARSE_MDF = False
End If
Application.EnableEvents = True
End Function
'==================================================================================================
' IDBLOCK
' Gets and checks data from IDBLOCK
' Returns True if successful
'==================================================================================================
Function IDBLOCK(lFile_Number As Long) As Boolean
Dim sTemp As String
Dim byTemp As Byte
'get file ID
sTemp = Space(3)
Get lFile_Number, &H1, sTemp
'MsgBox "File ID: " + sTemp
If sTemp = "MDF" Then
'get byte order
Get lFile_Number, &H19, byTemp
lByte_Order = byTemp
Get lFile_Number, &H1A, byTemp
lByte_Order = lByte_Order + (byTemp * (2 ^ 8))
'MsgBox "lByte_Order: " + Hex(lByte_Order)
If lByte_Order <> 0 Then
IDBLOCK = False
Else
IDBLOCK = True
End If
Else
IDBLOCK = False
End If
End Function
'==================================================================================================
' HDBLOCK
' Gets and checks data from HDBLOCK
' Returns True if successful
'==================================================================================================
Function HDBLOCK(lFile_Number As Long, lData_Group_Address As Long) As Boolean
Dim byTemp As Byte
Get lFile_Number, &H51, byTemp
lData_Groups = byTemp
Get lFile_Number, &H52, byTemp
lData_Groups = lData_Groups + (byTemp * (2 ^ 8))
'MsgBox "lData_Groups: " + CStr(lData_Groups)
Get lFile_Number, &H45, lData_Group_Address
'MsgBox "lData_Group_Address: " + Hex(lData_Group_Address)
If lData_Groups <> 0 And lData_Group_Address <> 0 Then
HDBLOCK = True
Else
HDBLOCK = False
End If
End Function
'==================================================================================================
' DGBLOCK
' Gets and checks data from DGBLOCK
' Returns True if successful
'==================================================================================================
Function DGBLOCK(lFile_Number As Long, lData_Group_Address As Long, lChannel_Group_Address As Long, lData_Address As Long) As Boolean
Dim lTemp As Long
Dim byTemp As Byte
Get lFile_Number, lData_Group_Address + &H5, lTemp
'MsgBox "Next lData_Group_Address: " + Hex(lTemp)
Get lFile_Number, lData_Group_Address + &H9, lChannel_Group_Address
'MsgBox "lChannel_Group_Address: " + Hex(lChannel_Group_Address)
Get lFile_Number, lData_Group_Address + &H11, lData_Address
'MsgBox "lData_Address: " + Hex(lData_Address)
Get lFile_Number, lData_Group_Address + &H15, byTemp
lChannel_Groups = byTemp
Get lFile_Number, lData_Group_Address + &H16, byTemp
lChannel_Groups = lChannel_Groups + (byTemp * (2 ^ 8))
'MsgBox "lChannel_Groups: " + CStr(lChannel_Groups)
lData_Group_Address = lTemp
If lChannel_Groups <> 0 And lChannel_Group_Address <> 0 Then
DGBLOCK = True
Else
DGBLOCK = False
End If
End Function
'==================================================================================================
' CGBLOCK
' Gets and checks data from CGBLOCK
' Returns True if successful
'==================================================================================================
Function CGBLOCK(lFile_Number As Long, lChannel_Group_Address As Long, lChannel_Address As Long, lRecord_Length As Long, lRecords As Long) As Boolean
Dim byTemp As Byte
Get lFile_Number, lChannel_Group_Address + &H9, lChannel_Address
'MsgBox "lChannel_Address: " + Hex(lChannel_Address)
Get lFile_Number, lChannel_Group_Address + &H13, byTemp
lChannels = byTemp
Get lFile_Number, lChannel_Group_Address + &H14, byTemp
lChannels = lChannels + (byTemp * (2 ^ 8))
'MsgBox "lChannels: " + CStr(lChannels)
Get lFile_Number, lChannel_Group_Address + &H15, byTemp
lRecord_Length = byTemp
Get lFile_Number, lChannel_Group_Address + &H16, byTemp
lRecord_Length = lRecord_Length + (byTemp * (2 ^ 8))
'MsgBox "lRecord_Length: " + CStr(lRecord_Length)
Get lFile_Number, lChannel_Group_Address + &H17, lRecords
'MsgBox "lRecords: " + CStr(lRecords)
End Function
'==================================================================================================
' CNBLOCK
' Gets and checks data from CNBLOCK
' Returns True if successful
'==================================================================================================
Function CNBLOCK(lFile_Number As Long, lChannel_Address As Long, wsData_Sheet As Worksheet, byCol As Byte) As Boolean
Dim sSignal_Name As String
Dim lNext_Channel_Address As Long
Dim lConversion_Address As Long
Dim lFirst_Data As Long
Dim lBit_Length As Long
Dim lData_Type As Long
Dim byTemp As Byte
Get lFile_Number, lChannel_Address + &H5, lNext_Channel_Address
'MsgBox "lNext_Channel_Address: " + Hex(lNext_Channel_Address)
Get lFile_Number, lChannel_Address + &H9, lConversion_Address
'MsgBox "lConversion_Address: " + Hex(lConversion_Address)
'signal name
sSignal_Name = Space(32)
Get lFile_Number, lChannel_Address + &H1B, sSignal_Name
If InStr(1, sSignal_Name, "\") <> 0 Then
sSignal_Name = Mid(sSignal_Name, 1, InStr(1, sSignal_Name, "\") - 1)
End If
wsData_Sheet.Cells(1, byCol).Value = sSignal_Name
'first bit data location
Get lFile_Number, lChannel_Address + &HBB, byTemp
lFirst_Data = byTemp
Get lFile_Number, lChannel_Address + &HBC, byTemp
lFirst_Data = lFirst_Data + (byTemp * (2 ^ 8))
wsData_Sheet.Cells(8, byCol).Value = lFirst_Data
'bit length
Get lFile_Number, lChannel_Address + &HBD, byTemp
lBit_Length = byTemp
Get lFile_Number, lChannel_Address + &HBE, byTemp
lBit_Length = lBit_Length + (byTemp * (2 ^ 8))
wsData_Sheet.Cells(5, byCol).Value = lBit_Length
'data type
Get lFile_Number, lChannel_Address + &HBF, byTemp
lData_Type = byTemp
Get lFile_Number, lChannel_Address + &HC0, byTemp
lData_Type = lData_Type + (byTemp * (2 ^ 8))
wsData_Sheet.Cells(2, byCol).Value = lData_Type
Call CCBLOCK(lFile_Number, lConversion_Address, wsData_Sheet, byCol)
lChannel_Address = lNext_Channel_Address
End Function
'==================================================================================================
' CNBLOCK
' Gets and checks data from CNBLOCK
' Returns True if successful
'==================================================================================================
Function CCBLOCK(lFile_Number As Long, lConversion_Address As Long, wsData_Sheet As Worksheet, byCol As Byte) As Boolean
Dim fdOffset As Double
Dim fdLSB As Double
Dim fdTemp As Double
Dim byTemp As Byte
Dim lBlock_Length As Long
Dim lFormula_ID As Long
Dim lTable_Length As Long
Dim lCounter As Long
Dim lText_Address As Long
Dim lText_Block_Length As Long
Dim sTemp As String
Dim wsTable_Conversion_Sheet As Worksheet
Set wsTable_Conversion_Sheet = Workbooks(ActiveWorkbook.Name).Worksheets(TABLECONVERSIONSHEET)
sTemp = Space(2)
Get lFile_Number, lConversion_Address + &H1, sTemp
'MsgBox "Block Identification: " + sTemp
If sTemp = "CC" Then
Get lFile_Number, lConversion_Address + &H3, byTemp
lBlock_Length = byTemp
Get lFile_Number, lConversion_Address + &H4, byTemp
lBlock_Length = lBlock_Length + (byTemp * (2 ^ 8))
'MsgBox "lBlock_Length: " + CStr(lBlock_Length)
Get lFile_Number, lConversion_Address + &H2B, byTemp
lFormula_ID = byTemp
Get lFile_Number, lConversion_Address + &H2C, byTemp
lFormula_ID = lFormula_ID + (byTemp * (2 ^ 8))
wsData_Sheet.Cells(6, byCol).Value = lFormula_ID
'Vector formula style
If lFormula_ID = 10 Then
sTemp = Space(lBlock_Length - &H2F)
Get lFile_Number, lConversion_Address + &H2F, sTemp
wsData_Sheet.Cells(7, byCol).Value = sTemp
'Vector table style
ElseIf lFormula_ID = 12 Then
Get lFile_Number, lConversion_Address + &H2D, byTemp
lTable_Length = byTemp
Get lFile_Number, lConversion_Address + &H2E, byTemp
lTable_Length = lTable_Length + (byTemp * (2 ^ 8))
wsData_Sheet.Cells(9, byCol).Value = lTable_Length
If lTable_offset = 0 Then
wsData_Sheet.Cells(10, byCol).Value = 1
Else
wsData_Sheet.Cells(10, byCol).Value = lTable_offset + 1
End If
For lCounter = 1 To lTable_Length
Get lFile_Number, lConversion_Address + &H2F + (&H14 * (lCounter - 1)), fdTemp
wsTable_Conversion_Sheet.Cells(lCounter + lTable_offset, 1).Value = fdTemp
Get lFile_Number, lConversion_Address + &H37 + (&H14 * (lCounter - 1)), fdTemp
wsTable_Conversion_Sheet.Cells(lCounter + lTable_offset, 2).Value = fdTemp
Get lFile_Number, lConversion_Address + &H3F + (&H14 * (lCounter - 1)), lText_Address
Get lFile_Number, lText_Address + &H3, byTemp
lText_Block_Length = byTemp
Get lFile_Number, lText_Address + &H4, byTemp
lText_Block_Length = lText_Block_Length + (byTemp * (2 ^ 8))
sTemp = Space(lText_Block_Length - 4)
Get lFile_Number, lText_Address + &H5, sTemp
wsTable_Conversion_Sheet.Cells(lCounter + lTable_offset, 3).Value = sTemp
Next
lTable_offset = lTable_offset + lCounter
'ETAS text style
ElseIf lFormula_ID = 65535 Then
'normal LSB, offset style
Else
'get offset
Get lFile_Number, lConversion_Address + &H2F, fdOffset
wsData_Sheet.Cells(4, byCol).Value = fdOffset
'get lsb
Get lFile_Number, lConversion_Address + &H37, fdLSB
wsData_Sheet.Cells(3, byCol).Value = fdLSB
End If
CCBLOCK = True
Else
CCBLOCK = False
End If
End Function
'==================================================================================================
' FORMULA_CONVERSION
'
' Returns the output of the formula
'==================================================================================================
Function FORMULA_CONVERSION(lArgument As Variant, sFormula As String) As Double
Dim fdLSB As Double
Dim fdOffset As Double
Dim fdExponant As Double
Dim sTemp As String
FORMULA_CONVERSION = 0
'formula in the form n1*x+n2
If IsNumeric(Left(sFormula, 1)) Then
If InStr(1, sFormula, "*") <> 0 Then
fdLSB = CDbl(Mid(sFormula, 1, InStr(1, sFormula, "*") - 1))
If InStr(1, sFormula, "+") <> 0 Then
fdOffset = CDbl(Right(sFormula, Len(sFormula) - InStr(1, sFormula, "+")))
FORMULA_CONVERSION = (fdLSB * lArgument) + fdOffset
ElseIf InStr(1, sFormula, "-") <> 0 Then
fdOffset = CDbl(Right(sFormula, Len(sFormula) - InStr(1, sFormula, "-")))
FORMULA_CONVERSION = (fdLSB * lArgument) - fdOffset
End If
End If
'formula in the form (x-n2)/(2^n1)
ElseIf Left(sFormula, 1) = "(" Then
If InStr(1, sFormula, ")") <> 0 Then
fdOffset = CDbl(Mid(sFormula, 3, InStr(1, sFormula, ")") - 3))
If InStr(1, sFormula, "^") <> 0 Then
fdExponant = CDbl(Mid(sFormula, InStr(1, sFormula, "^") + 1, Len(sFormula) - InStr(1, sFormula, "^")))
FORMULA_CONVERSION = (lArgument + fdOffset) / (2 ^ fdExponant)
End If
End If
End If
End Function
Function Copy()
Application.ScreenUpdating = False
Dim copySheet As Worksheet
Dim pasteSheet As Worksheet
Set copySheet = Worksheets("MDFDATA")
Set pasteSheet = Worksheets("Final Sheet")
copySheet.Range("A:O").Copy
pasteSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Function
Last edited by a moderator:
