none
Excel 2003 VBA: How to read and write 16bit and 32 bit integer variables in binary file?

    Question

  • hello,

    does anyone know how to write adn read 16 bit and 32 bit integer in a binary file?


    I am just wondering how VBA can handle different variables.

    Below the example code can only read and write "Variant" variables.


    Option Explicit

    'Purpose     :  Saves/writes a block of data to a file
    'Inputs      :  vData                   The data to store in the file. Can be an
    '                                       array or any simple data type.
    '               sFileName               The path and file name where the data is to be stored
    '               [bAppendToFile]         If True will append the data to the existing file
    'Outputs     :  Returns True if succeeded in saving data
    'Notes       :  Saves data type (text and binary).


    Function FileWriteBinary(vData As Variant, sFileName As String, Optional bAppendToFile As Boolean = True) As Boolean
        Dim iFileNum As Integer, lWritePos As Long
       
        On Error GoTo ErrFailed
        If bAppendToFile = False Then
            If Len(Dir$(sFileName)) > 0 And Len(sFileName) > 0 Then
                'Delete the existing file
                VBA.Kill sFileName
            End If
        End If
       
        iFileNum = FreeFile
        Open sFileName For Binary Access Write As #iFileNum
       
        If bAppendToFile = False Then
            'Write to first byte
            lWritePos = 1
        Else
            'Write to last byte + 1
            lWritePos = LOF(iFileNum) + 1
        End If
       
        Put #iFileNum, lWritePos, vData
        Close iFileNum
       
        FileWriteBinary = True
        Exit Function

    ErrFailed:
        FileWriteBinary = False
        Close iFileNum
        Debug.Print Err.Description
    End Function


    'Purpose     :  Reads the contents of a binary file
    'Inputs      :  sFileName               The path and file name where the data is stored
    'Outputs     :  Returns an array containing all the data stored in the file.
    '               e.g. ArrayResults(1 to lNumDataBlocks)
    '               Where lNumDataBlocks is the number of data blocks stored in file.
    '               If the file was created using FileWriteBinary, this will be the number
    '               of times data was appended to the file.


    Function FileReadBinary(sFileName As String) As Variant
        Dim iFileNum As Integer, lFileLen As Long
        Dim vThisBlock As Variant, lThisBlock As Long, vFileData As Variant
       
        On Error GoTo ErrFailed
       
        If Len(Dir$(sFileName)) > 0 And Len(sFileName) > 0 Then
            iFileNum = FreeFile
            Open sFileName For Binary Access Read As #iFileNum
           
            lFileLen = LOF(iFileNum)
           
            Do
                lThisBlock = lThisBlock + 1
                Get #iFileNum, , vThisBlock
                If IsEmpty(vThisBlock) = False Then
                    If lThisBlock = 1 Then
                        ReDim vFileData(1 To 1)
                    Else
                        ReDim Preserve vFileData(1 To lThisBlock)
                    End If
                    vFileData(lThisBlock) = vThisBlock
                End If
            Loop While EOF(iFileNum) = False
            Close iFileNum
           
            FileReadBinary = vFileData
        End If

        Exit Function
       
    ErrFailed:
        Close iFileNum
        Debug.Print Err.Description
    End Function



    I want to use VBA to read Perkin Elmer's binary *.sp spectra file, but I have no idea of the format details of the *.sp except that I know that
     the following Matlab function can be usesd for  Perkin Elmer binary *.sp Spectral file data importing.

    There are different variable types supported in Matlab, but in VBA, how to read similar binary file correctly?
    I tried to use a subrontine like this, but don't know how to skip the file header and go to desired data directly and how to read desired variables in desired format. e.g. integers in 16 bits and 32 bits respectively, 64 bits double precision variables, string connected by several 8 bit "uchar" characters, which are all well supported by Matlab or C++.

    """""""""""""""""""""""""""""""
    """" here is the matlab function
    "''''''''''''''''''''''''''''''''''''''''''''''''''
    function [data, xAxis, misc] = spload(filename)
    % Reads in spectra from PerkinElmer block structured files.
    % This version supports 'Spectrum' SP files.
    % Note that earlier 'Data Manager' formats are not supported.
    %
    % [data, xAxis, misc] = spload(filename):
    %   data:  1D array of doubles
    %   xAxis: vector for abscissa (e.g. Wavenumbers).
    %   misc: miscellanous information in name,value pairs

    % Copyright (C)2007 PerkinElmer Life and Analytical Sciences
    % Stephen Westlake, Seer Green
    %
    % History
    % 2007-04-24 SW     Initial version

    % Block IDs
    DSet2DC1DIBlock               =  120;
    HistoryRecordBlock            =  121;
    InstrHdrHistoryRecordBlock    =  122;
    InstrumentHeaderBlock         =  123;
    IRInstrumentHeaderBlock       =  124;
    UVInstrumentHeaderBlock       =  125;
    FLInstrumentHeaderBlock       =  126;
    % Data member IDs
    DataSetDataTypeMember              =  -29839;
    DataSetAbscissaRangeMember         =  -29838;
    DataSetOrdinateRangeMember         =  -29837;
    DataSetIntervalMember              =  -29836;
    DataSetNumPointsMember             =  -29835;
    DataSetSamplingMethodMember        =  -29834;
    DataSetXAxisLabelMember            =  -29833;
    DataSetYAxisLabelMember            =  -29832;
    DataSetXAxisUnitTypeMember         =  -29831;
    DataSetYAxisUnitTypeMember         =  -29830;
    DataSetFileTypeMember              =  -29829;
    DataSetDataMember                  =  -29828;
    DataSetNameMember                  =  -29827;
    DataSetChecksumMember              =  -29826;
    DataSetHistoryRecordMember         =  -29825;
    DataSetInvalidRegionMember         =  -29824;
    DataSetAliasMember                 =  -29823;
    DataSetVXIRAccyHdrMember           =  -29822;
    DataSetVXIRQualHdrMember           =  -29821;
    DataSetEventMarkersMember          =  -29820;
    % Type code IDs
    ShortType               = 29999;
    UShortType              = 29998;
    IntType                 = 29997;
    UIntType                = 29996;
    LongType                = 29995;
    BoolType                = 29988;
    CharType                = 29987;
    CvCoOrdPointType        = 29986;
    StdFontType             = 29985;
    CvCoOrdDimensionType    = 29984;
    CvCoOrdRectangleType    = 29983;
    RGBColorType            = 29982;
    CvCoOrdRangeType        = 29981;
    DoubleType              = 29980;
    CvCoOrdType             = 29979;
    ULongType               = 29978;
    PeakType                = 29977;
    CoOrdType               = 29976;
    RangeType               = 29975;
    CvCoOrdArrayType        = 29974;
    EnumType                = 29973;
    LogFontType             = 29972;


    fid = fopen(filename,'r');
    if fid == -1
        error('Cannot open the file.');
        return
    end

    % Fixed file header of signature and description
    signature = setstr(fread(fid, 4, 'uchar')');
    if ~strcmp(signature, 'PEPE')
       
        error('This is not a PerkinElmer block structured file.');
        return
    end
    description = setstr(fread(fid, 40, 'uchar')');

    % Initialize a variable so we can tell if we have read it.
    xLen = int32(0);

    % The rest of the file is a list of blocks
    while ~feof(fid)
        blockID = fread(fid,1,'int16');
        blockSize = fread(fid,1,'int32');
       
        % feof does not go true until after the read has failed.
        if feof(fid)
            break
        end
       
        switch blockID
            case DSet2DC1DIBlock
            % Wrapper block.  Read nothing.

            case DataSetAbscissaRangeMember
                innerCode = fread(fid, 1, 'int16');
                %_ASSERTE(CvCoOrdRangeType == nInnerCode);
                x0 = fread(fid, 1, 'double');
                xEnd = fread(fid, 1, 'double');
                   
            case DataSetIntervalMember
                innerCode = fread(fid, 1, 'int16');
                xDelta = fread(fid, 1, 'double');

            case DataSetNumPointsMember
                innerCode = fread(fid, 1, 'int16');
                xLen = fread(fid, 1, 'int32');

            case DataSetXAxisLabelMember
                innerCode = fread(fid, 1, 'int16');
                len = fread(fid, 1, 'int16');
                xLabel = setstr(fread(fid, len, 'uchar')');

            case DataSetYAxisLabelMember
                innerCode = fread(fid, 1, 'int16');
                len = fread(fid, 1, 'int16');
                yLabel = setstr(fread(fid, len, 'uchar')');
               
            case DataSetAliasMember
                innerCode = fread(fid, 1, 'int16');
                len = fread(fid, 1, 'int16');
                alias = setstr(fread(fid, len, 'uchar')');
             
            case DataSetNameMember
                innerCode = fread(fid, 1, 'int16');
                len = fread(fid, 1, 'int16');
                originalName = setstr(fread(fid, len, 'uchar')');
             
            case DataSetDataMember
                innerCode = fread(fid, 1, 'int16');
                len = fread(fid, 1, 'int32');
                % innerCode should be CvCoOrdArrayType
                % len should be xLen * 8
                if xLen == 0
                    xLen = len / 8;
                end
                data = fread(fid, xLen, 'double');
     
            otherwise               % unknown block, just seek past it
                fseek(fid, blockSize, 'cof');
        end
    end
    fclose(fid);

    if xLen == 0
        error('The file does not contain spectral data.');
        return
    end

    % Expand the axes specifications into vectors
    xAxis = x0 : xDelta : xEnd;

    % Return the other details as name,value pairs
    misc(1,:) = {'xLabel', xLabel};
    misc(2,:) = {'yLabel', yLabel};
    misc(3,:) = {'alias', alias};
    misc(4,:) = {'original name', originalName};

     

    Monday, September 14, 2009 8:34 AM

Answers

  • The Problem was closed.

    The variable types supported by Matlab and VBA are just similar.
    Below the code is very rough and poorly organized but it does works:


    'Demonstration routine
    Sub spload()
    '[data, xAxis, misc] =
    ' Reads in spectra from PerkinElmer block structured files.
    ' This version supports 'Spectrum' SP files.
    ' Note that earlier 'Data Manager' formats are not supported.
    '
    ' [data, xAxis, misc] = spload(filename):
    '   data:  1D array of doubles
    '   xAxis: vector for abscissa (e.g. Wavenumbers).
    '   misc: miscellanous information in name,value pairs

    ' Copyright (C)2009, All rights released
    ' Kevin z. Chen
    '
    '
    ' History
    ' 2009-9-19     Initial version revised from Matlab Codes by Stephen Westlake and Seer Green
    ' from PerkinElmer Life and Analytical Sciences

    ' Block IDs
    Dim sFilename As String

    Dim iFileNum As Integer, lFileLen As Long
    Dim vThisBlock As Variant, lThisBlock As Long, vFileData As Variant

    ' convert variable types between VBA get and Matlab fread
    Dim uchar As Byte
    Dim unchar(0 To 43) As String

    Dim int16 As Integer
    Dim int32 As Long
    Dim double_ As Double
    Dim wavenumber(0 To 3550) As Double
    Dim absorbance(0 To 3550) As Double
    Dim WavenumberIndex As Integer
    Dim AbsorbanceIndex As Integer


    Dim DSet2DC1DIBlock As Integer
    Dim HistoryRecordBlock  As Integer
    Dim InstrHdrHistoryRecordBlock  As Integer
    Dim InstrumentHeaderBlock   As Integer
    Dim IRInstrumentHeaderBlock As Integer
    Dim UVInstrumentHeaderBlock As Integer
    Dim FLInstrumentHeaderBlock As Integer
           
    Dim DataSetDataTypeMember   As Integer
    Dim DataSetAbscissaRangeMember  As Integer
    Dim DataSetOrdinateRangeMember  As Integer
    Dim DataSetIntervalMember   As Integer
    Dim DataSetNumPointsMember  As Integer
    Dim DataSetSamplingMethodMember As Integer
    Dim DataSetXAxisLabelMember As Integer
    Dim DataSetYAxisLabelMember As Integer
    Dim DataSetXAxisUnitTypeMember  As Integer
    Dim DataSetYAxisUnitTypeMember  As Integer
    Dim DataSetFileTypeMember   As Integer
    Dim DataSetDataMember   As Integer
    Dim DataSetNameMember   As Integer
    Dim DataSetChecksumMember   As Integer
    Dim DataSetHistoryRecordMember  As Integer
    Dim DataSetInvalidRegionMember  As Integer
    Dim DataSetAliasMember  As Integer
    Dim DataSetVXIRAccyHdrMember    As Integer
    Dim DataSetVXIRQualHdrMember    As Integer
    Dim DataSetEventMarkersMember   As Integer
           
    Dim ShortType   As Integer
    Dim UShortType  As Integer
    Dim IntType As Integer
    Dim UIntType    As Integer
    Dim LongType    As Integer
    Dim BoolType    As Integer
    Dim CharType    As Integer
    Dim CvCoOrdPointType    As Integer
    Dim StdFontType As Integer
    Dim CvCoOrdDimensionType    As Integer
    Dim CvCoOrdRectangleType    As Integer
    Dim RGBColorType    As Integer
    Dim CvCoOrdRangeType    As Integer
    Dim DoubleType  As Integer
    Dim CvCoOrdType As Integer
    Dim ULongType   As Integer
    Dim PeakType    As Integer
    Dim CoOrdType   As Integer
    Dim RangeType   As Integer
    Dim CvCoOrdArrayType    As Integer
    Dim EnumType    As Integer
    Dim LogFontType As Integer

    DSet2DC1DIBlock = 120
    HistoryRecordBlock = 121
    InstrHdrHistoryRecordBlock = 122
    InstrumentHeaderBlock = 123
    IRInstrumentHeaderBlock = 124
    UVInstrumentHeaderBlock = 125
    FLInstrumentHeaderBlock = 126
    ' Data member IDs
    DataSetDataTypeMember = -29839
    DataSetAbscissaRangeMember = -29838
    DataSetOrdinateRangeMember = -29837
    DataSetIntervalMember = -29836
    DataSetNumPointsMember = -29835
    DataSetSamplingMethodMember = -29834
    DataSetXAxisLabelMember = -29833
    DataSetYAxisLabelMember = -29832
    DataSetXAxisUnitTypeMember = -29831
    DataSetYAxisUnitTypeMember = -29830
    DataSetFileTypeMember = -29829
    DataSetDataMember = -29828
    DataSetNameMember = -29827
    DataSetChecksumMember = -29826
    DataSetHistoryRecordMember = -29825
    DataSetInvalidRegionMember = -29824
    DataSetAliasMember = -29823
    DataSetVXIRAccyHdrMember = -29822
    DataSetVXIRQualHdrMember = -29821
    DataSetEventMarkersMember = -29820
    'Type code IDs
    ShortType = 29999
    UShortType = 29998
    IntType = 29997
    UIntType = 29996
    LongType = 29995
    BoolType = 29988
    CharType = 29987
    CvCoOrdPointType = 29986
    StdFontType = 29985
    CvCoOrdDimensionType = 29984
    CvCoOrdRectangleType = 29983
    RGBColorType = 29982
    CvCoOrdRangeType = 29981
    DoubleType = 29980
    CvCoOrdType = 29979
    ULongType = 29978
    PeakType = 29977
    CoOrdType = 29976
    RangeType = 29975
    CvCoOrdArrayType = 29974
    EnumType = 29973
    LogFontType = 29972

    Dim innerCode As Integer
    Dim x0 As Double
    Dim xEnd As Double
    Dim xDelta As Double
    Dim xLen As Long
    Dim xLabel() As Byte
    Dim length As Integer
    Dim length32 As Long
    Dim yLabel() As Byte
    Dim alias() As Byte
    Dim OriginalName() As Byte
    Dim data() As Double
    'Dim xLength As Integer
    Dim offset() As Byte

    Dim ucharIndex As Integer
    Dim uncharIndex As Integer
    Dim description As String
    Dim i, j, k, m, n, p As Integer
    Dim BlockID As Integer
    Dim BlockSize As Long
    'Dim 'position As Long
    Dim iCountLoop As Long
    Dim text As String


    'position = 1

    iCountLoop = 0

    sFilename = "D:\CalibratedSpectra\17.27.sp"  ' It can be any other *.sp file directory for testing
    'debug.print sFilename
       
        On Error GoTo ErrFailed
       
        If Len(Dir$(sFilename)) > 0 And Len(sFilename) > 0 Then
            iFileNum = FreeFile
            Open sFilename For Binary Access Read As #iFileNum
           
            'lFileLen = LOF(iFileNum)
            WavenumberIndex = 0
            AbsorbanceIndex = 0
           
            For ucharIndex = 0 To 43
             Get #iFileNum, , uchar
                      'position = 'position + 1
                      'debug.print "Current Pointer:" & 'position
                      'debug.print "standard Pointer:" & Seek(iFileNum)
             unchar(ucharIndex) = uchar
            
            Next ucharIndex
           
            ' determine the fomart
                If Chr(unchar(0)) & Chr(unchar(1)) & Chr(unchar(2)) & Chr(unchar(3)) <> "PEPE" Then
               
                MsgBox "The file " & sFilename & " is not desired Perkin Elmer *.sp binary spectral file."
                Exit Sub
               
                End If

    'debug.print "The first 4 characters are: " & Chr(unchar(0)) & Chr(unchar(1)) & Chr(unchar(2)) & Chr(unchar(3))

    description = ""
    For ucharIndex = 4 To 43
    description = description & Chr(unchar(ucharIndex))
    Next ucharIndex

    'debug.print "The description of the file is: " & description


    'xLen = int32(0)
           
            Do
            iCountLoop = iCountLoop + 1
            If Seek(iFileNum) <= 50 Then
            'debug.print " Enter the Do-while Loop"
            Else
           
            'debug.print "------------ End of One Select Case block ---------------------------------"
            'debug.print "                     "
            'debug.print "      "
           
            End If
    '            lThisBlock = lThisBlock + 1
            Get #iFileNum, , int16
            'position = 'position + 2
             BlockID = int16
            
             If Seek(iFileNum) <= 52 Then
            'debug.print "Current Pointer:" & 'position
            'debug.print "standard Pointer:" & Seek(iFileNum)
             End If
            'debug.print "BlockID is: " & BlockID
            
           
            Get #iFileNum, , int32
            'position = 'position + 4
          
            BlockSize = int32
            
            If Seek(iFileNum) <= 56 Then
            'debug.print "Current Pointer:" & 'position
            'debug.print "standard Pointer:" & Seek(iFileNum)
            End If
            'debug.print "Block size is: " & BlockSize
           
           
            If EOF(iFileNum) = True Then
            Exit Do
            End If
           
               Select Case BlockID
                                Case DSet2DC1DIBlock
                                '% Wrapper block.  Read nothing.
                                   'debug.print " -----------------Case DSet2DC1DIBlock; Read Nothing-----------------"
                                   'debug.print "standard Pointer:" & Seek(iFileNum)
                                Case DataSetAbscissaRangeMember
                                 'debug.print " -----------------Case DataSetAbscissaRangeMember-----------------"
                                    Get #iFileNum, , innerCode
                                    'position = 'position + 2
                                    'debug.print "Current Pointer:" & 'position
                                    'debug.print "standard Pointer:" & Seek(iFileNum)
                                    '%_ASSERTE(CvCoOrdRangeType == nInnerCode)
                                    Get #iFileNum, , x0
                                    'position = 'position + 8
                                    'debug.print "Current Pointer:" & 'position
                                    'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , xEnd
                                    'position = 'position + 8
                                    'debug.print "Current Pointer:" & 'position
                                    'debug.print "standard Pointer:" & Seek(iFileNum)
                                  
                                    'debug.print "innerCode is: " & innerCode
                                    'debug.print "x0 is: " & x0
                                    'debug.print "xEnd is: " & xEnd
                                       
                                Case DataSetIntervalMember
                                   'debug.print " -----------------Case DataSetIntervalMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , xDelta
                                       'position = 'position + 8
                                       'debug.print "Current Pointer:" & 'position
                                       'debug.print "standard Pointer:" & Seek(iFileNum)
                                   
                                    'debug.print "innerCode is: " & innerCode
                                    'debug.print "xDelta is: " & xDelta
                                                                   
                       
                                Case DataSetNumPointsMember
                                   'debug.print " -----------------Case DataSetNumPointsMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , xLen
                                        'position = 'position + 4
                                        'debug.print "Current Pointer:" & 'position
                                        'debug.print "standard Pointer:" & Seek(iFileNum)
                                   
                                    'debug.print "innerCode is: " & innerCode
                                    'debug.print "xDelta is: " & xLen
                                                                   
                                Case DataSetXAxisLabelMember
                                   'debug.print " -----------------Case DataSetXAxisLabelMember-----------------"
                                    Get #iFileNum, , innerCode
                                        'position = 'position + 2
                                        'debug.print "Current Pointer:" & 'position
                                        'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                          'position = 'position + 2
                                          'debug.print "Current Pointer:" & 'position
                                          'debug.print "standard Pointer:" & Seek(iFileNum)
                                    ReDim xLabel(0 To length - 1) As Byte 'String
                                   
                                   
                                      Get #iFileNum, , xLabel
                                      'position = 'position + length
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                   
                                    text = ""
                                    For i = 0 To length - 1
                                     text = text & Chr(xLabel(i))
                                    Next i
                                    'debug.print "x Axis Label is: " & text
                                   
                                   
                                Case DataSetYAxisLabelMember
                                 'debug.print " -----------------Case DataSetYAxisLabelMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                  ReDim yLabel(0 To length - 1) As Byte 'String
                                 
                                  
                                     Get #iFileNum, , yLabel
                                       'position = 'position + length
                                       'debug.print "Current Pointer:" & 'position
                                       'debug.print "standard Pointer:" & Seek(iFileNum)
                                 
                              
                                  text = ""
                                  For j = 0 To length - 1
                                  text = text & Chr(yLabel(j))
                                  Next j
                                  'debug.print "y Axis Label is :" & text
                                   
                                Case DataSetAliasMember
                                 'debug.print " -----------------Case DataSetAliasMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    ReDim alias(0 To length - 1) As Byte 'String
                                   
                                   ' For k = 0 To length - 1
                                    Get #iFileNum, , alias
                                      'position = 'position + length
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    'Next k
                                   
                                Case DataSetNameMember
                                 'debug.print " -----------------Case DataSetNameMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    ReDim OriginalName(0 To length - 1) As Byte
                                   
                                      Get #iFileNum, , OriginalName
                                        'position = 'position + length
                                       
                                        text = ""
                                    For m = 0 To length - 1
                                    text = text & Chr(OriginalName(m))
                                    Next m
                                         'debug.print "Original fileName (including folder path) is: " & text
                                        
                                Case DataSetDataMember
                                'debug.print " -----------------Case DataSetDataMember -----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length32
                                      'position = 'position + 4
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    '% innerCode should be CvCoOrdArrayType
                                    '% length should be xLen * 8
                                    If xLen = 0 Then
                                        xLen = length / 8
                                    End If
                                    ReDim data(0 To xLen - 1) As Double
                                    Dim size As Long
                                    size = xLen
                                    'For n = 0 To xLen - 1
                                     Get #iFileNum, , data
                                     'debug.print "The dimension of data array is: " & UBound(data)
                                    'ActiveWorkbook.Sheets(1).Range("a1") = data(200)
                                     ''debug.print "****************worksheet data input finished!!"
                                       'position = 'position + length
                                       'debug.print "Current Pointer:" & 'position
                                       'debug.print "standard Pointer:" & Seek(iFileNum)
                                    'Next n
                                   
                                Case Else
                                'debug.print " +++++++++++++++++Case Else+++++++++++++++++++++++"
                               
                                      Seek #iFileNum, Seek(iFileNum) + BlockSize 'position + BlockSize
                                      'position = 'position + BlockSize
                              
                                   'debug.print "Current Pointer:" & 'position
                                   'debug.print "standard Pointer:" & Seek(iFileNum)
                                   'debug.print "'position + BlockSize is: " & ('position + BlockSize)
                                  
                End Select
                        
                If iCountLoop >= 3000 Then
                Exit Sub
                End If
            Loop While EOF(iFileNum) = False
            Close iFileNum
           
        Else
            Exit Sub
       
        End If

     

    If xLen = 0 Then
       MsgBox "The file does not contain spectral data."
        Exit Sub
    End If
    'debug.print "------------ " & sFilename & " data importing finished.------------"
    'debug.print "Now display the data"
    ''debug.print "--------------------      -----------     -----------    ------------"
    Dim index As Integer

    'Exit Sub
    'ActiveWorkbook.Sheets(1).cell("a1") = data(200)

    For index = 1 To size
    ''debug.print "data(" & index & ") is: " & data(index)
    'debug.print data(index - 1)
    ActiveWorkbook.Sheets(1).Range("a" & index).Value = data(index - 1)
    Next index
    'MsgBox "Finished!"
    'debug.print "Size of data Array: " & size
    'debug.print "Final value of Index: " & index
    'ActiveWorkbook.Sheets(1).Range("a" & index).Value = data(index - 1)
    'debug.print "--------------------   The End of This Run. " '
    ''debug.print CDbl(data(200))
    ' Expand the axes specifications into vectors
    'wavenumber= x0: xDelta: xEnd

    ' Return the other details as name,value pairs
    'misc(1,:) = {'xLabel', xLabel}
    'misc(2,:) = {'yLabel', yLabel}
    'misc(3,:) = {'alias', alias}
    'misc(4,:) = {'original name', originalName}


    ErrFailed:
        Close iFileNum
        'debug.print Err.description

    End Sub

    • Marked as answer by cooooldog Friday, September 25, 2009 1:28 AM
    Thursday, September 17, 2009 11:04 AM

All replies

  • The Problem was closed.

    The variable types supported by Matlab and VBA are just similar.
    Below the code is very rough and poorly organized but it does works:


    'Demonstration routine
    Sub spload()
    '[data, xAxis, misc] =
    ' Reads in spectra from PerkinElmer block structured files.
    ' This version supports 'Spectrum' SP files.
    ' Note that earlier 'Data Manager' formats are not supported.
    '
    ' [data, xAxis, misc] = spload(filename):
    '   data:  1D array of doubles
    '   xAxis: vector for abscissa (e.g. Wavenumbers).
    '   misc: miscellanous information in name,value pairs

    ' Copyright (C)2009, All rights released
    ' Kevin z. Chen
    '
    '
    ' History
    ' 2009-9-19     Initial version revised from Matlab Codes by Stephen Westlake and Seer Green
    ' from PerkinElmer Life and Analytical Sciences

    ' Block IDs
    Dim sFilename As String

    Dim iFileNum As Integer, lFileLen As Long
    Dim vThisBlock As Variant, lThisBlock As Long, vFileData As Variant

    ' convert variable types between VBA get and Matlab fread
    Dim uchar As Byte
    Dim unchar(0 To 43) As String

    Dim int16 As Integer
    Dim int32 As Long
    Dim double_ As Double
    Dim wavenumber(0 To 3550) As Double
    Dim absorbance(0 To 3550) As Double
    Dim WavenumberIndex As Integer
    Dim AbsorbanceIndex As Integer


    Dim DSet2DC1DIBlock As Integer
    Dim HistoryRecordBlock  As Integer
    Dim InstrHdrHistoryRecordBlock  As Integer
    Dim InstrumentHeaderBlock   As Integer
    Dim IRInstrumentHeaderBlock As Integer
    Dim UVInstrumentHeaderBlock As Integer
    Dim FLInstrumentHeaderBlock As Integer
           
    Dim DataSetDataTypeMember   As Integer
    Dim DataSetAbscissaRangeMember  As Integer
    Dim DataSetOrdinateRangeMember  As Integer
    Dim DataSetIntervalMember   As Integer
    Dim DataSetNumPointsMember  As Integer
    Dim DataSetSamplingMethodMember As Integer
    Dim DataSetXAxisLabelMember As Integer
    Dim DataSetYAxisLabelMember As Integer
    Dim DataSetXAxisUnitTypeMember  As Integer
    Dim DataSetYAxisUnitTypeMember  As Integer
    Dim DataSetFileTypeMember   As Integer
    Dim DataSetDataMember   As Integer
    Dim DataSetNameMember   As Integer
    Dim DataSetChecksumMember   As Integer
    Dim DataSetHistoryRecordMember  As Integer
    Dim DataSetInvalidRegionMember  As Integer
    Dim DataSetAliasMember  As Integer
    Dim DataSetVXIRAccyHdrMember    As Integer
    Dim DataSetVXIRQualHdrMember    As Integer
    Dim DataSetEventMarkersMember   As Integer
           
    Dim ShortType   As Integer
    Dim UShortType  As Integer
    Dim IntType As Integer
    Dim UIntType    As Integer
    Dim LongType    As Integer
    Dim BoolType    As Integer
    Dim CharType    As Integer
    Dim CvCoOrdPointType    As Integer
    Dim StdFontType As Integer
    Dim CvCoOrdDimensionType    As Integer
    Dim CvCoOrdRectangleType    As Integer
    Dim RGBColorType    As Integer
    Dim CvCoOrdRangeType    As Integer
    Dim DoubleType  As Integer
    Dim CvCoOrdType As Integer
    Dim ULongType   As Integer
    Dim PeakType    As Integer
    Dim CoOrdType   As Integer
    Dim RangeType   As Integer
    Dim CvCoOrdArrayType    As Integer
    Dim EnumType    As Integer
    Dim LogFontType As Integer

    DSet2DC1DIBlock = 120
    HistoryRecordBlock = 121
    InstrHdrHistoryRecordBlock = 122
    InstrumentHeaderBlock = 123
    IRInstrumentHeaderBlock = 124
    UVInstrumentHeaderBlock = 125
    FLInstrumentHeaderBlock = 126
    ' Data member IDs
    DataSetDataTypeMember = -29839
    DataSetAbscissaRangeMember = -29838
    DataSetOrdinateRangeMember = -29837
    DataSetIntervalMember = -29836
    DataSetNumPointsMember = -29835
    DataSetSamplingMethodMember = -29834
    DataSetXAxisLabelMember = -29833
    DataSetYAxisLabelMember = -29832
    DataSetXAxisUnitTypeMember = -29831
    DataSetYAxisUnitTypeMember = -29830
    DataSetFileTypeMember = -29829
    DataSetDataMember = -29828
    DataSetNameMember = -29827
    DataSetChecksumMember = -29826
    DataSetHistoryRecordMember = -29825
    DataSetInvalidRegionMember = -29824
    DataSetAliasMember = -29823
    DataSetVXIRAccyHdrMember = -29822
    DataSetVXIRQualHdrMember = -29821
    DataSetEventMarkersMember = -29820
    'Type code IDs
    ShortType = 29999
    UShortType = 29998
    IntType = 29997
    UIntType = 29996
    LongType = 29995
    BoolType = 29988
    CharType = 29987
    CvCoOrdPointType = 29986
    StdFontType = 29985
    CvCoOrdDimensionType = 29984
    CvCoOrdRectangleType = 29983
    RGBColorType = 29982
    CvCoOrdRangeType = 29981
    DoubleType = 29980
    CvCoOrdType = 29979
    ULongType = 29978
    PeakType = 29977
    CoOrdType = 29976
    RangeType = 29975
    CvCoOrdArrayType = 29974
    EnumType = 29973
    LogFontType = 29972

    Dim innerCode As Integer
    Dim x0 As Double
    Dim xEnd As Double
    Dim xDelta As Double
    Dim xLen As Long
    Dim xLabel() As Byte
    Dim length As Integer
    Dim length32 As Long
    Dim yLabel() As Byte
    Dim alias() As Byte
    Dim OriginalName() As Byte
    Dim data() As Double
    'Dim xLength As Integer
    Dim offset() As Byte

    Dim ucharIndex As Integer
    Dim uncharIndex As Integer
    Dim description As String
    Dim i, j, k, m, n, p As Integer
    Dim BlockID As Integer
    Dim BlockSize As Long
    'Dim 'position As Long
    Dim iCountLoop As Long
    Dim text As String


    'position = 1

    iCountLoop = 0

    sFilename = "D:\CalibratedSpectra\17.27.sp"  ' It can be any other *.sp file directory for testing
    'debug.print sFilename
       
        On Error GoTo ErrFailed
       
        If Len(Dir$(sFilename)) > 0 And Len(sFilename) > 0 Then
            iFileNum = FreeFile
            Open sFilename For Binary Access Read As #iFileNum
           
            'lFileLen = LOF(iFileNum)
            WavenumberIndex = 0
            AbsorbanceIndex = 0
           
            For ucharIndex = 0 To 43
             Get #iFileNum, , uchar
                      'position = 'position + 1
                      'debug.print "Current Pointer:" & 'position
                      'debug.print "standard Pointer:" & Seek(iFileNum)
             unchar(ucharIndex) = uchar
            
            Next ucharIndex
           
            ' determine the fomart
                If Chr(unchar(0)) & Chr(unchar(1)) & Chr(unchar(2)) & Chr(unchar(3)) <> "PEPE" Then
               
                MsgBox "The file " & sFilename & " is not desired Perkin Elmer *.sp binary spectral file."
                Exit Sub
               
                End If

    'debug.print "The first 4 characters are: " & Chr(unchar(0)) & Chr(unchar(1)) & Chr(unchar(2)) & Chr(unchar(3))

    description = ""
    For ucharIndex = 4 To 43
    description = description & Chr(unchar(ucharIndex))
    Next ucharIndex

    'debug.print "The description of the file is: " & description


    'xLen = int32(0)
           
            Do
            iCountLoop = iCountLoop + 1
            If Seek(iFileNum) <= 50 Then
            'debug.print " Enter the Do-while Loop"
            Else
           
            'debug.print "------------ End of One Select Case block ---------------------------------"
            'debug.print "                     "
            'debug.print "      "
           
            End If
    '            lThisBlock = lThisBlock + 1
            Get #iFileNum, , int16
            'position = 'position + 2
             BlockID = int16
            
             If Seek(iFileNum) <= 52 Then
            'debug.print "Current Pointer:" & 'position
            'debug.print "standard Pointer:" & Seek(iFileNum)
             End If
            'debug.print "BlockID is: " & BlockID
            
           
            Get #iFileNum, , int32
            'position = 'position + 4
          
            BlockSize = int32
            
            If Seek(iFileNum) <= 56 Then
            'debug.print "Current Pointer:" & 'position
            'debug.print "standard Pointer:" & Seek(iFileNum)
            End If
            'debug.print "Block size is: " & BlockSize
           
           
            If EOF(iFileNum) = True Then
            Exit Do
            End If
           
               Select Case BlockID
                                Case DSet2DC1DIBlock
                                '% Wrapper block.  Read nothing.
                                   'debug.print " -----------------Case DSet2DC1DIBlock; Read Nothing-----------------"
                                   'debug.print "standard Pointer:" & Seek(iFileNum)
                                Case DataSetAbscissaRangeMember
                                 'debug.print " -----------------Case DataSetAbscissaRangeMember-----------------"
                                    Get #iFileNum, , innerCode
                                    'position = 'position + 2
                                    'debug.print "Current Pointer:" & 'position
                                    'debug.print "standard Pointer:" & Seek(iFileNum)
                                    '%_ASSERTE(CvCoOrdRangeType == nInnerCode)
                                    Get #iFileNum, , x0
                                    'position = 'position + 8
                                    'debug.print "Current Pointer:" & 'position
                                    'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , xEnd
                                    'position = 'position + 8
                                    'debug.print "Current Pointer:" & 'position
                                    'debug.print "standard Pointer:" & Seek(iFileNum)
                                  
                                    'debug.print "innerCode is: " & innerCode
                                    'debug.print "x0 is: " & x0
                                    'debug.print "xEnd is: " & xEnd
                                       
                                Case DataSetIntervalMember
                                   'debug.print " -----------------Case DataSetIntervalMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , xDelta
                                       'position = 'position + 8
                                       'debug.print "Current Pointer:" & 'position
                                       'debug.print "standard Pointer:" & Seek(iFileNum)
                                   
                                    'debug.print "innerCode is: " & innerCode
                                    'debug.print "xDelta is: " & xDelta
                                                                   
                       
                                Case DataSetNumPointsMember
                                   'debug.print " -----------------Case DataSetNumPointsMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , xLen
                                        'position = 'position + 4
                                        'debug.print "Current Pointer:" & 'position
                                        'debug.print "standard Pointer:" & Seek(iFileNum)
                                   
                                    'debug.print "innerCode is: " & innerCode
                                    'debug.print "xDelta is: " & xLen
                                                                   
                                Case DataSetXAxisLabelMember
                                   'debug.print " -----------------Case DataSetXAxisLabelMember-----------------"
                                    Get #iFileNum, , innerCode
                                        'position = 'position + 2
                                        'debug.print "Current Pointer:" & 'position
                                        'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                          'position = 'position + 2
                                          'debug.print "Current Pointer:" & 'position
                                          'debug.print "standard Pointer:" & Seek(iFileNum)
                                    ReDim xLabel(0 To length - 1) As Byte 'String
                                   
                                   
                                      Get #iFileNum, , xLabel
                                      'position = 'position + length
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                   
                                    text = ""
                                    For i = 0 To length - 1
                                     text = text & Chr(xLabel(i))
                                    Next i
                                    'debug.print "x Axis Label is: " & text
                                   
                                   
                                Case DataSetYAxisLabelMember
                                 'debug.print " -----------------Case DataSetYAxisLabelMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                  ReDim yLabel(0 To length - 1) As Byte 'String
                                 
                                  
                                     Get #iFileNum, , yLabel
                                       'position = 'position + length
                                       'debug.print "Current Pointer:" & 'position
                                       'debug.print "standard Pointer:" & Seek(iFileNum)
                                 
                              
                                  text = ""
                                  For j = 0 To length - 1
                                  text = text & Chr(yLabel(j))
                                  Next j
                                  'debug.print "y Axis Label is :" & text
                                   
                                Case DataSetAliasMember
                                 'debug.print " -----------------Case DataSetAliasMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    ReDim alias(0 To length - 1) As Byte 'String
                                   
                                   ' For k = 0 To length - 1
                                    Get #iFileNum, , alias
                                      'position = 'position + length
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    'Next k
                                   
                                Case DataSetNameMember
                                 'debug.print " -----------------Case DataSetNameMember-----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    ReDim OriginalName(0 To length - 1) As Byte
                                   
                                      Get #iFileNum, , OriginalName
                                        'position = 'position + length
                                       
                                        text = ""
                                    For m = 0 To length - 1
                                    text = text & Chr(OriginalName(m))
                                    Next m
                                         'debug.print "Original fileName (including folder path) is: " & text
                                        
                                Case DataSetDataMember
                                'debug.print " -----------------Case DataSetDataMember -----------------"
                                    Get #iFileNum, , innerCode
                                      'position = 'position + 2
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    Get #iFileNum, , length32
                                      'position = 'position + 4
                                      'debug.print "Current Pointer:" & 'position
                                      'debug.print "standard Pointer:" & Seek(iFileNum)
                                    '% innerCode should be CvCoOrdArrayType
                                    '% length should be xLen * 8
                                    If xLen = 0 Then
                                        xLen = length / 8
                                    End If
                                    ReDim data(0 To xLen - 1) As Double
                                    Dim size As Long
                                    size = xLen
                                    'For n = 0 To xLen - 1
                                     Get #iFileNum, , data
                                     'debug.print "The dimension of data array is: " & UBound(data)
                                    'ActiveWorkbook.Sheets(1).Range("a1") = data(200)
                                     ''debug.print "****************worksheet data input finished!!"
                                       'position = 'position + length
                                       'debug.print "Current Pointer:" & 'position
                                       'debug.print "standard Pointer:" & Seek(iFileNum)
                                    'Next n
                                   
                                Case Else
                                'debug.print " +++++++++++++++++Case Else+++++++++++++++++++++++"
                               
                                      Seek #iFileNum, Seek(iFileNum) + BlockSize 'position + BlockSize
                                      'position = 'position + BlockSize
                              
                                   'debug.print "Current Pointer:" & 'position
                                   'debug.print "standard Pointer:" & Seek(iFileNum)
                                   'debug.print "'position + BlockSize is: " & ('position + BlockSize)
                                  
                End Select
                        
                If iCountLoop >= 3000 Then
                Exit Sub
                End If
            Loop While EOF(iFileNum) = False
            Close iFileNum
           
        Else
            Exit Sub
       
        End If

     

    If xLen = 0 Then
       MsgBox "The file does not contain spectral data."
        Exit Sub
    End If
    'debug.print "------------ " & sFilename & " data importing finished.------------"
    'debug.print "Now display the data"
    ''debug.print "--------------------      -----------     -----------    ------------"
    Dim index As Integer

    'Exit Sub
    'ActiveWorkbook.Sheets(1).cell("a1") = data(200)

    For index = 1 To size
    ''debug.print "data(" & index & ") is: " & data(index)
    'debug.print data(index - 1)
    ActiveWorkbook.Sheets(1).Range("a" & index).Value = data(index - 1)
    Next index
    'MsgBox "Finished!"
    'debug.print "Size of data Array: " & size
    'debug.print "Final value of Index: " & index
    'ActiveWorkbook.Sheets(1).Range("a" & index).Value = data(index - 1)
    'debug.print "--------------------   The End of This Run. " '
    ''debug.print CDbl(data(200))
    ' Expand the axes specifications into vectors
    'wavenumber= x0: xDelta: xEnd

    ' Return the other details as name,value pairs
    'misc(1,:) = {'xLabel', xLabel}
    'misc(2,:) = {'yLabel', yLabel}
    'misc(3,:) = {'alias', alias}
    'misc(4,:) = {'original name', originalName}


    ErrFailed:
        Close iFileNum
        'debug.print Err.description

    End Sub

    • Marked as answer by cooooldog Friday, September 25, 2009 1:28 AM
    Thursday, September 17, 2009 11:04 AM
  • I tried to covert to VB.net but BlockId and BlockSize read were differents if compares with vba values.

    FileGet(iFileNum, int16)
    BlockID = int16 
    FileGet(iFileNum, int32)
    BlockSize = int32
    Any idea?
    Saturday, July 14, 2012 9:07 PM