Search for specific strings of data from a binary .dat file, only extract text

问题

Sub ReadEntireFileAndPlaceOnWorksheet()
    Dim X As Long, Ys As Long, FileNum As Long, TotalFile As String, FileName As String, Result() As String, Lines() As String, rng As Range, i As Long, used As Range, lc As Long
    
         FileName = "C:\Users\MEA\Documents\ELCM2\DUMMY_FILE.dat"
        FileNum = FreeFile
         Open FileName For Binary As #FileNum
        TotalFile = Space(LOF(FileNum))
        Get #FileNum, , TotalFile
        Close #FileNum
        Lines = Split(TotalFile, vbNewLine)
         Ys = 1
         lc = Sheet3.Cells(1, Columns.Count).End(xlToLeft).Column
        For X = 1 To UBound(Lines)
            Ys = Ys + 1
            ReDim Preserve Result(1 To Ys)
            Result(Ys) = "'" & Lines(X - 1)
            Set used = Sheet1.Cells(Sheet1.Rows.Count, lc + 1).End(xlUp).Rows
            Set rng = used.Offset(1, 0)
            rng.Value = Result(Ys)
         Next
         
End Sub

I am trying to find some data in a .dat (binary file). The data should look like this:

MiHo14.dat
MDF     3.00    TGT 15.0
Time: 06:40:29 PM
Recording Duration: 00:05:02
Database: DB
Experiment: Min Air take
Workspace: MINAIR
Devices: ETKC:1,ETKC:2
Program Description: 0delivupd2
Module_delivupd2
WP: _AWD_5
RP: _AWD
§@
Minimum intake - + revs - Downward gear

The code I have currently extracts all data from .dat file and places in Excel file looks like this:

MiHo14.dat
MDF     3.00    TGT 15.0
Time: 06:40:29 PM
Recording Duration: 00:05:02
Database: DB
Experiment: Min Air take
Workspace: MINAIR
Devices: ETKC:1,ETKC:2
Program Description: 0delivupd2
Module_delivupd2
WP: _AWD_5
RP: _AWD
§@
Minimum intake - + revs - Downward gear 
Bã|ŽA…@@,s~?
B{À¿…@@@Ý‚Iá 
Á<
"@²n¢”N@ÇÿÈÿj
Ð=“SØ•N@ÇÿÈÿj   
à¨. —N@ÇÿÈÿj
 8²œg˜N@ÇÿÈÿj
0NI,¯™N@ÈÿÈÿj
Ðä$öšN@ÈÿÈÿj
@Q›=œN@ÈÿÈÿj
ÐŸe…N@ÇÿÈÿj
 GàÍžN@ÇÿÈÿj"
etc....

I need to know how to use instr function to extract the information by identifying lines that include ":", the other challenge is there is a final line in the data that is a user comment this user comment can basically be any text, I need to be able to extract it without extracting the whole file because as you can see there is a lot of symbols (gibberish) that comes with it.

回答1:

I don't think you want to copy all the HD/PR/TX blocks to get the output you are looking for.

Examining at your file, one difference I can see between valid and invalid data (from your perspective) is that the invalid data either does not end with CR-LF combination, or contains a null character. If that characteristic is consistent throughout your files, you may be able to use it to advantage:

Below is the code I used, and the results. You can modify the variables for your own routine and see if it works consistently.

Option Explicit
Sub ProcessDAT()
    Const sFN As String = "D:\Users\Ron\Desktop\DUMMY_FILE.dat"
    Const sEND As String = vbCrLf
    Dim S As String, COL As Collection, V As Variant, I As Long
    Dim R As Range

Open sFN For Binary Access Read As #1
S = Space(LOF(1))
    Get #1, , S
Close #1

V = Split(S, sEND)
Set COL = New Collection
For I = 0 To UBound(V)
    If InStr(V(I), Chr(0)) = 0 Then COL.Add V(I)
Next I

ReDim V(1 To COL.Count, 1 To 1)
For I = 1 To UBound(V)
    V(I, 1) = COL(I)
Next I

Set R = Range("a1").Resize(UBound(V))
R = V  
End Sub

Results

Time: 11:47:42 AM
Recording Duration: 00:01:09
Database: Testproject
Experiment: Measurement_Dummy
Workspace: Workspace
Devices: ETKC:1
Program Description: LPOOPL14
WP: LPOOPL14d2_1
RP: LPOOPL14d2
§@
Dummy test data

回答2:

That code won't compile because you haven't looped your for loop.

Sub ReadEntireFileAndPlaceOnWorksheet()
    Dim X As Long, Y As Long, FileNum As Long, sFile As String, FileName As String, Result() As String, Lines() As String, rng As Range, i As Long, used As Range, MyFolder As String

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Show
        MyFolder = .SelectedItems(1)
    End With
    FileName = Dir(MyFolder & "\*.*")
    Do Until FileName = ""
        sFile = ReadFile(MyFolder & "\" & FileName)
        Lines = Split(sFile, vbLf)
        Y = 1
        For X = 1 To UBound(Lines)
            If InStr(1, Lines(X), ":", vbTextCompare) <> 0 Then
                ReDim Preserve Result(Y) '<-- Changed to a 1D array, I don't know why you had a 2D
                Result(Y) = "'" & Lines(X - 1)
                Y = Y + 1 '<-- increases to resize the array as it goes
            End If
        Next '<-- Added that in
        Set used = Sheet1.Cells(1, Sheet1.Columns.Count).End(xlToLeft).Columns
        Set rng = used.Offset(0, 1)
        rng.Resize(UBound(Result)).Formula = WorksheetFunction.Transpose(WorksheetFunction.Transpose(Result))
        FileName = Dir()
    Loop
End Sub


Function ReadFile(ByVal strFile As String) As String
On Error GoTo Error_Handler
    Dim FileNumber  As Integer
    Dim sFile       As String 'Variable contain file content
    FileNumber = FreeFile
    Open strFile For Binary Access Read As FileNumber
    sFile = Space(LOF(FileNumber))
    Get #FileNumber, , sFile
    Close FileNumber

    ReadFile = sFile

Error_Handler_Exit:
    On Error Resume Next
    Exit Function

Error_Handler:
    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
            "Error Number: " & Err.Number & vbCrLf & _
            "Error Source: ReadFile" & vbCrLf & _
            "Error Description: " & Err.Description, _
            vbCritical, "An Error has Occured!"
    Resume Error_Handler_Exit
End Function

Changed your array to 1 dimension

Lastly, if you indent your code properly it makes it a lot easier to read and help you.

Credit here for the file reading: http://www.devhut.net/2012/05/14/vba-read-file-into-memory/

回答3:

Option Explicit
Sub ProcessDAT()
    Const sFN As String = "C:\Users\Mohamed samatar.DSSE-EMEA\Documents\EQVL\Test\WHVP113_140827_TTinsug_TTbana_292Data_WOT_TakeOff_Launch_LaunchPlus_PUoff_REF_1.dat"
    Const sEND As String = vbCrLf
    Dim S As String, COL As Collection, V As Variant, I As Long
    Dim R As Range
    Dim MLocation  As Long
    Dim PRLocation As Long
    Dim Mstuff As String
    Dim MSize As Long
    Dim MSize1 As Integer
      
Open sFN For Binary Access Read As #1
    Get #1, &H49, MLocation

    MSize = MLocation + 2
   
    Get #1, MSize, MSize1
    'MsgBox Hex(MSize1)
    
   
    Mstuff = String$(MSize1, " ")
    Get #1, MLocation, Mstuff
Close #1

V = Split(Mstuff, sEND)
Set COL = New Collection
For I = 0 To UBound(V)
    If InStr(V(I), Chr(0)) = 0 Then COL.Add V(I)
Next I

ReDim V(1 To COL.Count, 1 To 1)
For I = 1 To UBound(V)
    V(I, 1) = COL(I)
Next I

Set R = Range("a1").Resize(UBound(V))
R = V
End Sub

I used the Integer as it is a 2 byte data type and now it works, can you just comment if this is what you were referring to as the solution?!

来源：https://stackoverflow.com/questions/28491683/search-for-specific-strings-of-data-from-a-binary-dat-file-only-extract-text

标签

string

vba

binary

extract