Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- VERSION 5.00
- Begin VB.Form Form1
- AutoRedraw = -1 'True
- BackColor = &H80000005&
- Caption = "Vernier UV-Vis Spectrometer"
- ClientHeight = 9375
- ClientLeft = 60
- ClientTop = 450
- ClientWidth = 16500
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 12
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- LinkTopic = "Form1"
- MinButton = 0 'False
- ScaleHeight = 625
- ScaleMode = 3 'Pixel
- ScaleWidth = 1100
- StartUpPosition = 3 'Windows Default
- Begin VB.Timer Timer1
- Interval = 60000
- Left = 10440
- Top = 0
- End
- Begin VB.CommandButton ClearGraph
- Appearance = 0 'Flat
- Caption = "Next User"
- BeginProperty Font
- Name = "Calibri"
- Size = 15.75
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 495
- Left = 7440
- TabIndex = 8
- Top = 5640
- Width = 3375
- End
- Begin VB.ListBox List1
- BeginProperty Font
- Name = "Calibri"
- Size = 9.75
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 6135
- Left = 10920
- TabIndex = 7
- Top = 1320
- Width = 3015
- End
- Begin VB.TextBox DirectoryBox
- BeginProperty Font
- Name = "Calibri"
- Size = 12
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 405
- Left = 10920
- TabIndex = 6
- Top = 840
- Width = 3015
- End
- Begin VB.PictureBox Graph
- BackColor = &H00FFFFFF&
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 8.25
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 4455
- Left = 240
- ScaleHeight = -111
- ScaleLeft = 250
- ScaleMode = 0 'User
- ScaleTop = 110
- ScaleWidth = 650
- TabIndex = 3
- Top = 840
- Width = 10575
- End
- Begin VB.CommandButton Blank
- Appearance = 0 'Flat
- Caption = "Blank"
- BeginProperty Font
- Name = "Calibri"
- Size = 15.75
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 495
- Left = 240
- TabIndex = 2
- Top = 5640
- Width = 3375
- End
- Begin VB.CommandButton ScanSample
- Appearance = 0 'Flat
- Caption = "Scan"
- BeginProperty Font
- Name = "Calibri"
- Size = 15.75
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 495
- Left = 3840
- TabIndex = 1
- Top = 5640
- Width = 3375
- End
- Begin VB.CommandButton Exit
- BackColor = &H80000005&
- Caption = "X"
- BeginProperty Font
- Name = "Calibri"
- Size = 8.25
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 195
- Left = 13800
- MaskColor = &H00FFFFFF&
- Style = 1 'Graphical
- TabIndex = 0
- Top = 0
- Width = 255
- End
- Begin VB.Label Label8
- Alignment = 2 'Center
- BackColor = &H8000000E&
- Caption = "versus"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 9.75
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 5160
- TabIndex = 16
- Top = 480
- Width = 735
- End
- Begin VB.Label Label7
- Alignment = 2 'Center
- Appearance = 0 'Flat
- BackColor = &H80000005&
- BorderStyle = 1 'Fixed Single
- Caption = "Wavelength (nm )"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 12
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- ForeColor = &H80000008&
- Height = 375
- Left = 6240
- TabIndex = 15
- Top = 405
- Width = 2295
- End
- Begin VB.Label Label6
- Alignment = 2 'Center
- Appearance = 0 'Flat
- BackColor = &H80000005&
- BorderStyle = 1 'Fixed Single
- Caption = "Absorbance ( )"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 12
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- ForeColor = &H80000008&
- Height = 375
- Left = 2520
- TabIndex = 14
- Top = 405
- Width = 2295
- End
- Begin VB.Label Label5
- Alignment = 2 'Center
- Appearance = 0 'Flat
- BackColor = &H80000005&
- BorderStyle = 1 'Fixed Single
- Caption = "WaveNumber (1/cm)"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 8.25
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- ForeColor = &H80000008&
- Height = 255
- Left = 9000
- TabIndex = 13
- Top = 480
- Width = 1815
- End
- Begin VB.Label Label4
- Alignment = 2 'Center
- Appearance = 0 'Flat
- BackColor = &H80000005&
- BorderStyle = 1 'Fixed Single
- Caption = "Transmittance (%)"
- BeginProperty Font
- Name = "MS Sans Serif"
- Size = 8.25
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- ForeColor = &H80000008&
- Height = 255
- Left = 240
- TabIndex = 12
- Top = 480
- Width = 1815
- End
- Begin VB.Label DateLabel
- BackColor = &H8000000E&
- Caption = "Date"
- BeginProperty Font
- Name = "Times New Roman"
- Size = 9.75
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 2640
- TabIndex = 11
- Top = 120
- Width = 1815
- End
- Begin VB.Label Label3
- BackColor = &H8000000E&
- Caption = "ICN DATA COLLECTION:"
- BeginProperty Font
- Name = "Times New Roman"
- Size = 9.75
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 240
- TabIndex = 10
- Top = 120
- Width = 2295
- End
- Begin VB.Label Label2
- Alignment = 2 'Center
- BackColor = &H00FFFFFF&
- Caption = " Enter ICN Account Name in the text box below"
- BeginProperty Font
- Name = "Calibri"
- Size = 12
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 615
- Left = 10920
- TabIndex = 9
- Top = 120
- Width = 3015
- End
- Begin VB.Label HelpLine
- BackColor = &H80000005&
- Caption = "Help Line"
- BeginProperty Font
- Name = "Times New Roman"
- Size = 12
- Charset = 0
- Weight = 700
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 2295
- Left = 240
- TabIndex = 5
- Top = 6240
- Width = 10575
- WordWrap = -1 'True
- End
- Begin VB.Label Label1
- BackColor = &H80000005&
- Caption = "250"
- BeginProperty Font
- Name = "Calibri"
- Size = 9.75
- Charset = 0
- Weight = 400
- Underline = 0 'False
- Italic = 0 'False
- Strikethrough = 0 'False
- EndProperty
- Height = 255
- Left = 120
- TabIndex = 4
- Top = 5280
- Width = 10695
- End
- End
- Attribute VB_Name = "Form1"
- Attribute VB_GlobalNameSpace = False
- Attribute VB_Creatable = False
- Attribute VB_PredeclaredId = True
- Attribute VB_Exposed = False
- Option Explicit
- 'Dim PixelNumber As Integer ' pixel number from the edit box
- Dim StopScanning As Integer ' stop scanning flag for continuous acquisition
- Dim Background(1900)
- Dim Spectra(1900, 7)
- Dim SpectraNbr As Integer
- Dim Intensity(1900)
- Dim StartTime
- Dim PreFix$
- ''''''''''''''''''''''''''''''''''''''''''/
- 'Additional declarations added here
- Dim ServerName As String
- Dim Directory
- Dim HTMLRow$(500)
- Dim HTMLRowNumber As Integer
- ''''''''''''''''''''''''''''''''''''''''''/
- 'This call gives us the hWnd (window handle) of the screen
- Private Declare Function GetDesktopWindow Lib "user32" () As Long
- 'This call assigns an hDC (handle of device context) from an hWnd
- Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
- 'BitBlt lets us draw an image from a hDC to another hDC (in our case, from an hDC of the screen capture to the hDC of a VB picture box)
- Private Declare Function BitBlt Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal opCode As Long) As Long
- 'ReleaseDC will be used to clear out the hDC we generate for the screen capture.
- Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
- Dim ScanBlankFlag As Integer
- Dim First As Integer, Last As Integer, WL1 As Integer, WL2 As Integer, MinY, MaxY
- 'FTP variables:
- Dim hOpen As Long, hConnection As Long, hFile As Long
- Dim dwType As Long
- Dim dwSeman As Long
- Private Sub ClearGraph_Click()
- Dim x, y
- Graph.Cls
- List1.Clear
- DirectoryBox.Text = ""
- For y = 25 To 100 Step 25: Graph.Line (240, y)-(850, y), QBColor(7): Next y
- For x = 250 To 850 Step 50: Graph.Line (x, -1)-(x, 110), QBColor(7): Next x
- SpectraNbr = 0
- HelpLine.Caption = "Enter your lab name in the box at the top right of this page."
- DateLabel.Caption = Date$
- End Sub
- Private Sub Form_Load()
- Me.Top = 0
- Me.Left = 0
- Me.Width = 1366 * Screen.TwipsPerPixelX
- Me.Height = 768 * Screen.TwipsPerPixelY
- 'Set up FTP
- hOpen = InternetOpen("My VB Test", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
- If hOpen = 0 Then
- ErrorOut Err.LastDllError, "InternetOpen"
- Unload Form1
- End If
- dwType = FTP_TRANSFER_TYPE_BINARY
- 'dwType = FTP_TRANSFER_TYPE_ASCII
- dwSeman = 0 'Active symantic ftp, not spelling error: semantic? and 0 is active.
- 'dwSeman = INTERNET_FLAG_PASSIVE
- hConnection = 0
- Dim i, s$
- 'Set up Ocean Optics Spectrometer
- 'ServerName = "130.111.192.243"
- ServerName = "interchemnet.um.maine.edu"
- 'Open json file template and store in HTMLRow$(I) array
- Open App.Path + "\ICNhtml.txt" For Input As 1
- i = 0
- While Not EOF(1)
- i = i + 1
- Line Input #1, HTMLRow$(i)
- Wend
- HTMLRowNumber = i
- Close 1
- Open App.Path + "\CalNbrs.txt" For Input As 1
- Input #1, WL1
- Input #1, WL2
- Input #1, First
- Input #1, Last
- Input #1, MaxY
- Input #1, PreFix$
- Close 1
- SpectraNbr = 0
- Graph.ScaleLeft = 240
- Graph.ScaleWidth = 610
- s$ = " "
- Label1.Caption = " 250" & s$ & "300" & s$ & "350" & s$ & "400" & s$ & "450" & s$ & " 500" & s$ & "550" & s$ & "600" & s$ & "650" & s$ & "700" & s$ & "750" & s$ & "800"
- s$ = "This program must have the Vernier LoggerLite Program running in the background." + Chr$(13)
- s$ = s$ + "Close all other programs and double click Default.gmbl" + Chr$(13)
- s$ = s$ + "On the Logger program menu, click Experiment, Change Units and then %Transmittance" + Chr$(13)
- s$ = s$ + "Click Experiment again, Calibrate, Spectrometer 1. Wait, then click Disable Calibration." + Chr$(13)
- s$ = s$ + "Then click the Collect icon. Select Erase and Continue if needed." + Chr$(13)
- s$ = s$ + "Click on this program to bring it to the front. Click Next User."
- HelpLine.Caption = s$
- StartTime = Timer
- End Sub
- Private Sub Form_Unload(Cancel As Integer)
- If hConnection <> 0 Then InternetCloseHandle hConnection
- hConnection = 0
- HelpLine.Caption = "Disconnected."
- End
- End Sub
- Private Sub Blank_Click()
- 'Clear background array
- Erase Background
- 'Graph.Cls
- Scan 1 '1 is for Blank
- End Sub
- Private Sub Exit_Click()
- Dim w$
- w$ = InputBox$("To calibrate, block beam path and enter password, or click cancel.")
- If w$ = "dark" Then
- 'Clear background array
- Graph.Cls
- w = MsgBox("Block light path completely and click OK")
- Scan 0 '0 is for Dark Background
- ElseIf w$ = "exit" Then
- Open App.Path + "\CalNbrs.txt" For Output As 1
- Print #1, WL1
- Print #1, WL2
- Print #1, First
- Print #1, Last
- Print #1, MaxY
- Print #1, PreFix$
- Print #1, "First 2 are Wavelength Range, next 2 are first and last is MaxY Dark Value."
- Close 1
- End
- End If
- End Sub
- Private Sub ScanSample_Click()
- If ScanBlankFlag = 0 Then MsgBox ("A Blank is required before a %T or A scan."): Exit Sub
- Scan 3 '2 is for %T scan, Nbr=3 is for A scan.
- End Sub
- Private Sub DirectoryBox_KeyUp(KeyCode As Integer, Shift As Integer)
- Dim i1 As Integer, i2 As Integer, w$, ww$
- Dim ftpcheck As Boolean
- If KeyCode = 13 Then
- 'Open connection to FTP server
- 'Make sure all connections are closed.
- If hConnection <> 0 Then
- InternetCloseHandle hConnection
- End If
- 'Now open the specified connection
- hConnection = InternetConnect(hOpen, "ftp.umeche.maine.edu", INTERNET_INVALID_PORT_NUMBER, "DebugUser", "Test2015", INTERNET_SERVICE_FTP, dwSeman, 0)
- If hConnection = 0 Then
- ErrorOut Err.LastDllError, "InternetConnect"
- Exit Sub
- Else
- HelpLine.Caption = "Connected to ftp.umeche.maine.edu"
- End If
- 'Now connect to specified directory
- If (FtpSetCurrentDirectory(hConnection, DirectoryBox.Text) = False) Then
- ErrorOut Err.LastDllError, "FtpSetCurrentDirectory"
- Exit Sub
- Else
- HelpLine.Caption = "Directory is changed to " & DirectoryBox.Text
- End If
- 'Clear listbox and add current datafile names to List1
- List1.Clear
- Dim szDir As String
- Dim hFind As Long
- Dim nLastError As Long
- Dim dError As Long
- Dim ptr As Long
- Dim pData As WIN32_FIND_DATA
- hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
- nLastError = Err.LastDllError
- If hFind = 0 Then
- If (nLastError = ERROR_NO_MORE_FILES) Then
- MsgBox "This directory is empty!"
- Else
- ErrorOut Err.LastDllError, "FtpFindFirstFile"
- End If
- Exit Sub
- End If
- dError = NO_ERROR
- Dim bRet As Boolean
- szDir = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
- List1.AddItem (szDir)
- Do
- pData.cFileName = String(MAX_PATH, 0)
- bRet = InternetFindNextFile(hFind, pData)
- If Not bRet Then
- dError = Err.LastDllError
- If dError = ERROR_NO_MORE_FILES Then
- Exit Do
- Else
- ErrorOut Err.LastDllError, "InternetFindNextFile"
- InternetCloseHandle (hFind)
- Exit Sub
- End If
- Else
- szDir = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
- List1.AddItem (szDir)
- End If
- Loop
- Dim szTemp As String
- szTemp = String(1024, Chr$(0))
- If (FtpGetCurrentDirectory(hConnection, szTemp, 1024) = False) Then
- ErrorOut Err.LastDllError, "FtpGetCurrentDirectory"
- Exit Sub
- End If
- 'MsgBox szDir, , "Directory Listing of: " & szTemp
- InternetCloseHandle (hFind)
- 'Make sure all connections are closed.
- If hConnection <> 0 Then
- InternetCloseHandle hConnection
- End If
- w$ = "Your data will automatically be stored on the ICN server. To access it from your computer, tablet or smart phone, "
- w$ = w$ & "write down this address in your notebook: http://icn2.umeche.maine.edu/DataFiles/" & DirectoryBox.Text & "/index.html" & Chr$(13)
- w$ = w$ & " Enter the address in the address bar of a browser like Internet Explorer, Chrome, Firefox..."
- HelpLine.Caption = w$
- End If
- End Sub
- Private Sub Scan(Nbr As Integer)
- Dim ScreenColor As Long
- Dim Counter As Integer
- Dim x As Long, y As Long, y0 As Long
- Dim i As Integer, s1, s2, w1, w2
- Dim Ix As Integer
- Dim WL, s, A
- Dim FileName As String
- Dim DC As Long
- Dim T0
- 'First, shrink this window
- Me.Top = 0
- Me.Left = 0
- Me.Width = 1980
- Me.Height = 570
- T0 = Timer: While (Timer - T0) < 1: Wend 'Wait 1 seconds for spectrometer and screen
- 'Get the hWnd of the screen
- Dim scrHwnd As Long
- scrHwnd = GetDesktopWindow
- 'Now, assign an hDC to the hWnd we generated
- Dim shDC As Long
- shDC = GetDC(scrHwnd)
- 'Determine the size of the screen
- Dim screenWidth As Long, screenHeight As Long
- screenWidth = Screen.Width \ Screen.TwipsPerPixelX
- screenHeight = Screen.Height \ Screen.TwipsPerPixelY
- 'Copy the pixel data from the screen into our form
- BitBlt Me.hDC, 0, 0, screenWidth, screenHeight, shDC, 0, 0, vbSrcCopy
- 'Release our hold on the screen DC
- ReleaseDC scrHwnd, shDC
- Me.Picture = Me.Image
- 't0 = Timer
- 'Analyze
- 'Hide all boxes and controls
- Blank.Visible = False
- ClearGraph.Visible = False
- DateLabel.Visible = False
- DirectoryBox.Visible = False
- Form1.Exit.Visible = False
- Graph.Visible = False
- HelpLine.Visible = False
- List1.Visible = False
- ScanSample.Visible = False
- Label1.Visible = False
- Label2.Visible = False
- Label3.Visible = False
- Label4.Visible = False
- Label5.Visible = False
- Label6.Visible = False
- Label7.Visible = False
- Label8.Visible = False
- ScreenColor = 0
- Counter = 0
- 'Screen size 1920 by 1080, x range max: 100 to 1525, y range max: 100 to 1000
- 'Laptop Screen size 1366 by 768, x range max: 100 to 1350, y range max: 100 to 1000
- 'erase Intensity
- 'Expand Form for analysis
- Me.Width = 1366 * Screen.TwipsPerPixelX
- Me.Height = 768 * Screen.TwipsPerPixelY
- 'MsgBox ("ok1?")
- 'Find the first point on plotted data
- x = First
- For y = 125 To 665
- ScreenColor = Me.Point(x, y)
- If ScreenColor = 3342591 Then Intensity(x) = y: y0 = y: y = 750: Counter = 1
- Next y
- If Counter = 0 Then MsgBox ("Couldn't find data"): Exit Sub
- 'To save time, utilize fact that line is continuous and search there and step outward
- For x = First + 3 To Last Step 3
- For y = 1 To 100
- ScreenColor = Me.Point(x, y0 + y)
- If ScreenColor = 3342591 And (y0 + y) < 666 Then
- Intensity(x) = y0 + y: y0 = y0 + y: y = 999: Counter = Counter + 1
- End If
- ScreenColor = Me.Point(x, y0 - y)
- If ScreenColor = 3342591 And (y0 - y) > 124 Then
- Intensity(x) = y0 - y: y0 = y0 - y: y = 999: Counter = Counter + 1
- End If
- Next y
- If y = 101 Then MsgBox ("Couldn't extract all data"): Exit Sub
- Next x
- Me.Picture = Nothing
- Blank.Visible = True
- ClearGraph.Visible = True
- DateLabel.Visible = True
- DirectoryBox.Visible = True
- Form1.Exit.Visible = True
- Graph.Visible = True
- HelpLine.Visible = True
- List1.Visible = True
- ScanSample.Visible = True
- Label1.Visible = True
- Label2.Visible = True
- Label3.Visible = True
- Label4.Visible = True
- Label5.Visible = True
- Label6.Visible = True
- Label7.Visible = True
- Label8.Visible = True
- Graph.Cls
- For y = 25 To 100 Step 25: Graph.Line (240, y)-(850, y), QBColor(7): Next y
- For x = 250 To 850 Step 50: Graph.Line (x, -1)-(x, 110), QBColor(7): Next x
- DoEvents
- 'Find first data point, minimum, maximum and last data point for %Signal calculation.
- 'Now plot %Signal versus wavelength
- If Nbr = 0 Then 'Find first x, last x and MaxY (Max is actually min value since y plots down
- 'If this is not done, program uses last good values stored in calnbrs.txt
- MaxY = 0: y = 0 'First = 0: Last = 0
- For x = First To Last Step 3
- MaxY = MaxY + Intensity(x): y = y + 1
- 'If First = 0 And Ix > 0 Then First = X
- 'If First > 0 Then MaxY = MaxY + Ix
- 'If First > 0 And Ix = 0 Then Last = X: X = 1900
- Next x
- MaxY = MaxY / y
- ElseIf Nbr = 1 Then 'Scan blank
- For x = First To Last Step 3
- WL = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
- Background(x) = MaxY - Intensity(x)
- Graph.PSet (WL, 100), QBColor(7)
- Next x
- SpectraNbr = 0
- ScanBlankFlag = 1
- ElseIf Nbr = 2 Then 'Plot Transmittance. Don't Scan unless a blank has been done.
- For x = First To Last Step 3
- If Background(x) > 0 Then
- Spectra(x, SpectraNbr) = 100 * (MaxY - Intensity(x)) / Background(x)
- End If
- Next x
- For i = 0 To SpectraNbr
- For x = First To Last Step 3
- If Background(x) > 0 And Background(x + 3) > 0 Then
- w1 = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
- w2 = Int((WL2 - WL1) * ((x + 3) - First) / (Last - First) + WL1 + 0.5)
- Graph.Line (w1, Spectra(x, i))-(w2, Spectra(x + 3, i)), QBColor(i)
- End If
- Next x
- Next i
- SpectraNbr = SpectraNbr + 1
- ElseIf Nbr = 3 Then 'Plot Absorbance. Don't Scan unless a blank has been done.
- For x = First To Last Step 3
- WL = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
- If Background(x) > 0 Then
- Spectra(x, SpectraNbr) = 100 * (MaxY - Intensity(x)) / Background(x)
- 'If s > 0 Then A = -Log(s) / Log(10) Else A = 5
- 'Graph.PSet (WL, 25 * A)
- End If
- Next x
- For i = 0 To SpectraNbr
- For x = First To Last Step 3
- If Background(x) > 0 And Background(x + 3) > 0 Then
- s1 = Spectra(x, i) / 100
- s2 = Spectra(x + 3, i) / 100
- If s1 > 0 And s2 > 0 Then
- w1 = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
- w2 = Int((WL2 - WL1) * ((x + 3) - First) / (Last - First) + WL1 + 0.5)
- Graph.Line (w1, 25 * (-Log(s1) / Log(10)))-(w2, 25 * (-Log(s2) / Log(10))), QBColor(i)
- End If
- End If
- Next x
- Next i
- SpectraNbr = SpectraNbr + 1
- End If
- If Nbr > 1 Then
- 'Create HTML file and save on server
- If DirectoryBox.Text <> "" Then 'assume an IP and save it on server
- HelpLine.Caption = "Scan Complete. Now writing file to server."
- icnmake ("temp.json")
- HelpLine.Caption = "Temp.json Data File Saved"
- ''''''SaveToDisk
- SaveToServer
- 'HelpLine.Caption = "File saved on server and web page updated."
- Else 'Save it locally as a text file.
- 'FileName = Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
- 'FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
- 'FileName = FileName + ".TXT"
- 'Open App.Path + "\" + FileName For Output As 1
- 'For j = 300 To 700
- ' 'Graph.PSet (x, yy(j, 1)), QBColor(14)
- ' x = 10000000# / j 'All files saved as wavenumber and %Transmission like FTIR
- ' If jCount(j - 300) > 0 Then Print #1, Str$(Int(x + 0.5)) + "," + Str$(Int(100 * Spectra(j - 300) + 0.5) / 100)
- 'Next j
- 'Close 1
- 'HelpLine.Caption = "Scan Complete. Text file saved on hard drive in: " & Chr$(13) & App.Path & "\" & FileName & Chr$(13) & "Note your data has not been saved on the ICN server! Enter your lab name and recollect data."
- End If
- End If
- 'DarkBack.Enabled = True
- Blank.Enabled = True ' re-enable buttons
- ScanSample.Enabled = True
- End Sub
- Sub icnmake(fname2$)
- Dim Count As Integer
- Dim WorkString As String * 12
- Dim Record As String * 36
- Dim RecordLength As Integer
- Dim i, L, j, kk, k1, k2, Sign, Sign0, Exponent, Exponent0 As Integer
- Dim ICNPath As String, FileName As String
- Dim d, d2, iflag
- Dim lf$, Cr$, s$, s2$, d3$, xs$, ys$
- Dim work, x As Long, y, WL
- lf$ = Chr$(10) 'W* variables w are always temp. & local. DL
- Cr$ = Chr$(13) 'i,(j,k,l) variables are always temp. & local DL
- ICNPath = CurDir
- Open App.Path + "\" + fname2$ For Output As 1
- 'Header is single string.
- FileName = PreFix$ + "-" + Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
- FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
- s$ = FileName 'ICN ID Header
- Print #1, "{"
- Print #1, "label: " + "'" + s$ + "',"
- Print #1, "data: [";
- For x = First To Last Step 3 'First point will be at 240 nm, last at 850 nm.
- If Background(x) > 0 Then
- WL = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
- y = 100 * (MaxY - Intensity(x)) / Background(x)
- xs$ = Str$(10000000# / WL): ys$ = Str$(y) 'All files saved as wavenumber rather than wavelength
- Print #1, "[" + xs$ + "," + ys$ + "], ";
- End If
- Next x
- Print #1, "[" + xs$ + "," + ys$ + "]]" 'duplicate last point to close out string
- Print #1, "}"
- Close 1 'Close File
- End Sub
- Private Sub SaveToServer()
- Dim T0, fp$, fname2$, i, FileName As String
- FileName = PreFix$ + "-" + Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
- FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
- FileName = FileName + ".JSON"
- Dim ftpcheck As Boolean
- 'Open connection and change directory
- If hConnection <> 0 Then
- InternetCloseHandle hConnection
- End If
- 'Now open the specified connection
- hConnection = InternetConnect(hOpen, "interchemnet.um.maine.edu", INTERNET_INVALID_PORT_NUMBER, "icninstrument", "5ka#ixo9", INTERNET_SERVICE_FTP, dwSeman, 0)
- If hConnection = 0 Then
- ErrorOut Err.LastDllError, "InternetConnect"
- Exit Sub
- Else
- HelpLine.Caption = "Connected to interchemnet.um.maine.edu"
- End If
- 'Now connect to specified directory
- If (FtpSetCurrentDirectory(hConnection, DirectoryBox.Text) = False) Then
- ErrorOut Err.LastDllError, "FtpSetCurrentDirectory"
- Exit Sub
- Else
- HelpLine.Caption = "Directory is changed to " & DirectoryBox.Text
- End If
- 'Place data file in student folder
- If (FtpPutFile(hConnection, CurDir$ + "\" + "Temp.json", FileName, dwType, 0) = False) Then
- 'Wait a second and try one more time
- T0 = Timer: While Timer - T0 < 1: Wend
- If (FtpPutFile(hConnection, CurDir$ + "\" + "Temp.json", FileName, dwType, 0) = False) Then
- ErrorOut Err.LastDllError, "FtpPutFile"
- Exit Sub
- End If
- End If
- HelpLine.Caption = FileName & " has been saved on server!"
- 'Add filename to list box
- Form1.List1.AddItem FileName
- Form1.List1.ListIndex = Form1.List1.ListCount - 1
- 'Create HTML file: index.html
- CreateHTML
- 'Copy updated student index.html to student folder
- fp$ = App.Path + "\index.html"
- fname2$ = "index.html"
- If (FtpPutFile(hConnection, fp$, fname2$, dwType, 0) = False) Then
- ErrorOut Err.LastDllError, "FtpPutFile"
- Exit Sub
- Else
- HelpLine.Caption = FileName & " saved on server!"
- End If
- 'Close connection
- If hConnection <> 0 Then
- InternetCloseHandle hConnection
- End If
- 'erase temp.json
- 'skip next line for testing
- '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Kill fp$
- 'Find position of new file for LoadFiles_Click and select it
- For i = 0 To Form1.List1.ListCount - 1
- If Form1.List1.List(i) = FileName + ".json" Then Form1.List1.Selected(i) = True
- Next i
- FileName = ""
- '''FirstTime = "YES" 'Force load defaults for new sample scans
- T0 = Timer: While Timer - T0 < 1: Wend
- End Sub
- Private Sub SaveToDisk()
- Dim T0, fp$, fname2$, i, FileName
- 'Rename temp.json file to filename.json
- FileName = PreFix$ + "-" + Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
- FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
- FileName = FileName + ".JSON"
- FileCopy "temp.json", FileName
- 'Add filename to list box
- Form1.List1.AddItem FileName
- Form1.List1.ListIndex = Form1.List1.ListCount - 1
- CreateHTML
- For i = 0 To Form1.List1.ListCount - 1
- If Form1.List1.List(i) = FileName + ".json" Then Form1.List1.Selected(i) = True
- Next i
- FileName = ""
- End Sub
- Private Sub CreateHTML()
- 'Updates student index.html file
- Dim i, j, k, Q$, fp$
- Q$ = Chr$(34)
- Open "index.html" For Output As 1
- For i = 1 To HTMLRowNumber
- If HTMLRow$(i) <> "<!--icnstart-->" Then
- Print #1, HTMLRow$(i)
- Else 'write button for filename
- Print #1, "<!--icnstart-->"
- Print #1, "<b>" + DirectoryBox.Text + "</b>"
- Print #1, " </br>"
- Print #1, " <table border=" + Q$ + "0" + Q$ + ">"
- Print #1, " <tr>"
- k = 0
- For j = Form1.List1.ListCount - 1 To 0 Step -1
- fp$ = Form1.List1.List(j)
- Print #1, " <td>"
- Print #1, " <input class=" + Q$ + "fetchSeries" + Q$ + " type=" + Q$ + "button" + Q$ + " value=" + Q$ + Left$(fp$, 16) + Q$ + ">"
- Print #1, " <a href=" + Q$ + fp$ + Q$ + ">*</a>"
- Print #1, " <span></span>"
- Print #1, " </td>"
- k = k + 1: If k Mod 4 = 0 Then Print #1, " <tr>" 'start a new row
- Next j
- Print #1, " </tr>"
- Print #1, " </table>"
- End If
- Next i
- Close 1
- End Sub
- Private Sub ErrorOut(ByVal dwError As Long, ByRef szFunc As String)
- Dim dwRet As Long
- Dim dwTemp As Long
- Dim szString As String * 2048
- Dim szErrorMessage As String
- dwRet = FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, GetModuleHandle("wininet.dll"), dwError, 0, szString, 256, 0)
- szErrorMessage = szFunc & " error code: " & dwError & " Message: " & szString
- Debug.Print szErrorMessage
- MsgBox szErrorMessage
- If (dwError = 12003) Then
- ' Extended error information was returned
- dwRet = InternetGetLastResponseInfo(dwTemp, szString, 2048)
- MsgBox szString
- End If
- End Sub
- Private Sub Timer1_Timer()
- If (Timer - StartTime > 7200) Then
- MsgBox$ ("If you are done with this spectrometer, turn off the switch on the back of the spectrometer. Don't unplug anything. Don't exit the software. Just close the laptop cover. If you have more to do click OK")
- StartTime = Timer
- End If
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement