Back to more examples at the chemometrics section from www.amdis.net
Subjcamp4PCA() 'Excel Makro in Visual Basic for the import of mass spectra 'from JCAMP-DX data provided by LIB2NIST 'for further processing via PCA or cluster analysis 'see pictures and examples at www.amdis.net ' 'jcamp4PCA V0.92 written by Tobias Kind (C) 2001 www.amdis.net ' 'V0.92 = 219904 spectra import version; 28 spectra/second @1700Mhz 'feel free to distribute or to alter the code 'Dimension Variables 'courious results if defined together MassMin,MZMass,MassMax as integer Dim ResultStr As String Dim FileName As String Dim FileNum As Integer Dim CommaCount As Integer Dim WorkResult As String Dim SpectraCount As Integer Dim Filler As String Dim MassMIN As Integer Dim MassMAX As Integer Dim MZIntensity As Integer Dim MZMass As Integer Dim MassCount As Integer Dim MyActiveWorksheet As Integer Dim i, x, y, z, trigger As Integer 'Definition for 2560 spectra (10*256) 'max value in XL2000 = 859; equals (859x256)= 219904 spectra MaxWorkSheets = 10 'Ask for the name of the file. 'FileName = InputBox("Please type the name of your text file, for example, test.txt") FileName = Application.GetOpenFilename 'Turn off ScreenUpdating and Events so that users can't see what is 'happening and can't affect the code while it is running. Application.ScreenUpdating = True Application.EnableEvents = False 'Check for no entry. If FileName = "" Then End 'Get next available file handle number. FileNum = FreeFile() 'Open text file for input. Open FileName For Input As #FileNum 'Turn ScreenUpdating off is 2x faster (!) Application.ScreenUpdating = False 'Small counter 0..257 SpectraCount = 0 'Counter for all spectra AllSpectraCount = 0 MassMIN = 10000 MassMAX = 0 'extend to 10 worksheets (only first run) - 2560 spectra 'Set NewSheet = Sheets.Add(Type:=xlWorksheet) 'Excel opens new Workbook with 3 worksheets StartWorkSheets = Worksheets.Count For i = 1 To (MaxWorkSheets - StartWorkSheets) Worksheets.Add.Move after:=Worksheets(Worksheets.Count) Next i 'For i = 1 To Sheets.Count ' NewSheet.Cells(i, 1).Value = Sheets(i).Name 'Next i 'Place the data in the first row of the column. 'Activate first worksheet - nice for switching to the next MyActiveWorksheet = 1 Worksheets(MyActiveWorksheet).Activate 'Name of the active worksheet 'important for different language versions. MyWorkheetName = ActiveCell.Worksheet.Name Range("A1").Activate Cells.Select Selection.ClearContents Cells.Select ZeitStart = Timer 'Application.ScreenUpdating = False '************************************************** big parse loop 'Loop until the end of file is reached. Do While Seek(FileNum) <= LOF(FileNum) 'Show row number being imported on status bar. (33% speed decrease) Application.StatusBar = "Importing JCAMP Spectrum " & _ AllSpectraCount & " of JCAMP file " & FileName 'Store one line of text from file to variable. Line Input #FileNum, ResultStr 'Store the entire string into a second, temporary string. WorkResult = ResultStr If InStr(WorkResult, "##TITLE") Then SpectraCount = SpectraCount + 1 End If If SpectraCount = 0 Then MsgBox FileName _ & vbCrLf & vbCrLf & "This seems to be no JCAMP-DX mass spectra file -" _ & vbCrLf & "or has leading linefeeds (CR/LF)- " _ & vbCrLf & "First line should be: ##TITLE=" _ & vbCrLf & vbCrLf & "Import aborted." _ & vbCrLf & "Please contact www.amdis.net" End End If 'write titles to every first line --> switch between: '##CAS REGISTRY NO= '##SAMPLE DESCRIPTION= 'change the following 2 lines together... If InStr(WorkResult, "##CAS REGISTRY") Then Filler = Right(WorkResult, Len(WorkResult) - Len("##CAS REGISTRY NO=")) Worksheets(MyActiveWorksheet).Cells(1, SpectraCount) = Filler End If 'Read number of m/z values and save them If InStr(WorkResult, "##NPOINTS") Then WorkResult = Right(WorkResult, Len(WorkResult) - Len("##NPOINTS=")) 'Parse out any leading spaces. 'If Left(WorkResult, 1) = " " Then WorkResult = Right(WorkResult, Len(WorkResult) - 1) MassCount = LTrim(WorkResult) 'trigger for low mass = first m/z point trigger = 1 '*********************************************** Mass loop 'skip line "##XYDATA=(XY..XY)" Line Input #FileNum, WorkResult 'Read in all Mass/Intensity pairs Do While MassCount > 0 Line Input #FileNum, WorkResult WorkResult = LTrim(WorkResult) MZMass = Left(WorkResult, InStr(WorkResult, " ")) MZIntensity = Right(WorkResult, InStr(WorkResult, " ")) Worksheets(MyActiveWorksheet).Cells(MZMass + 1, SpectraCount) = MZIntensity MassCount = MassCount - 1 ' Get the lowest and highest mass from all points If trigger = 1 Then If MassMIN > MassCount Then MassMIN = MZMass End If trigger = 0 End If If MassCount = 0 Then If MassMAX < MZMass Then MassMAX = MZMass End If End If Loop '*********************************************** Mass loop end AllSpectraCount = AllSpectraCount + 1 End If 'Test for more than 256 columns because EXCEL is 8bit 'even in 2001 we battle with 8bit... 2^8 = 256 'can be extended if switching to lower rows or other table If SpectraCount = 257 Then MyActiveWorksheet = MyActiveWorksheet + 1 Worksheets(MyActiveWorksheet).Activate 'clear content Range("A1").Activate Cells.Select Selection.ClearContents Cells.Select 'initialize new variables 'because line reader run over first line SpectraCount = 1 End If 'test if more than defined spectra 'change the MaxWorkSheets number if wanted If AllSpectraCount = MaxWorkSheets * 256 Then Beep Beep Beep MsgBox MaxWorkSheets * 256 & " spectra version - Import aborted." _ & vbCrLf & "Please extend MaxWorkSheets to " & (AllSpectraCount \ 256) + 1 & "." _ & vbCrLf & "Thank you." End End If Loop '*********************************************** big parse loop end 'Close the open text file. Close 'Fill all empty values with Zero - faster version now OK 'http://www.microsoftexceltraining.com/VBA/VBALoops.htm 'thanks to DavidHawley@ozgrid.com For i = MyActiveWorksheet To 1 Step -1 Application.StatusBar = "Zero-Filling WorkSheet " & MyActiveWorksheet For Each c In Worksheets(MyActiveWorksheet).Range(Cells(1, 2), Cells(MassMAX + 1, SpectraCount)) If c.Value = vbNullString Then c.Value = "0" Next c If i > 1 Then MyActiveWorksheet = MyActiveWorksheet - 1 Worksheets(MyActiveWorksheet).Activate SpectraCount = 256 End If Next 'Time Profiler for testing '1251 spectra imported in 44 seconds (Athlon 1700Mhz) ZeitEnde = Timer AbgelaufeneZeit = (ZeitEnde - ZeitStart) AbgelaufeneZeit = Left(AbgelaufeneZeit, InStr(AbgelaufeneZeit, ",") + 1) Application.StatusBar = "Ready. " & AllSpectraCount & _ " spectra imported. Lowest Mass = " & MassMIN & _ " Highest Mass = " & MassMAX & _ " Time: " & AbgelaufeneZeit & " sec." Beep End Sub
Back to more examples at the chemometrics section from www.amdis.net