这次是真的搞定了, 用VBA读取Perkin Elmer的*.sp二进制谱图文件

最新推荐文章于 2024-03-12 11:14:53 发布

原创最新推荐文章于 2024-03-12 11:14:53 发布 · 1.2k 阅读

0 ·

CC 4.0 BY-SA版权

文章标签：

#vba #integer #byte #string #matlab #wrapper

学习学习专栏收录该内容

669 篇文章

订阅专栏

本文介绍了一个用于解析PerkinElmer光谱文件（*.sp）的VBA程序，该程序能够读取文件中的各项关键信息，如波数范围、间隔、数据点数量、坐标轴标签等，并将光谱数据导入Excel进行进一步处理。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

Option Explicit

'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
' Kevin z. Chen
'
' History
' 2009-9-19 Initial version

' 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"
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, 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

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