Advertisement
j0h

Untitled

j0h
Nov 4th, 2015
419
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. VERSION 5.00
  2. Begin VB.Form Form1
  3.    AutoRedraw      =   -1  'True
  4.   BackColor       =   &H80000005&
  5.    Caption         =   "Vernier UV-Vis Spectrometer"
  6.    ClientHeight    =   9375
  7.    ClientLeft      =   60
  8.    ClientTop       =   450
  9.    ClientWidth     =   16500
  10.    BeginProperty Font
  11.       Name            =   "MS Sans Serif"
  12.       Size            =   12
  13.       Charset         =   0
  14.       Weight          =   400
  15.       Underline       =   0   'False
  16.      Italic          =   0   'False
  17.      Strikethrough   =   0   'False
  18.   EndProperty
  19.    LinkTopic       =   "Form1"
  20.    MinButton       =   0   'False
  21.   ScaleHeight     =   625
  22.    ScaleMode       =   3  'Pixel
  23.   ScaleWidth      =   1100
  24.    StartUpPosition =   3  'Windows Default
  25.   Begin VB.Timer Timer1
  26.       Interval        =   60000
  27.       Left            =   10440
  28.       Top             =   0
  29.    End
  30.    Begin VB.CommandButton ClearGraph
  31.       Appearance      =   0  'Flat
  32.      Caption         =   "Next User"
  33.       BeginProperty Font
  34.          Name            =   "Calibri"
  35.          Size            =   15.75
  36.          Charset         =   0
  37.          Weight          =   400
  38.          Underline       =   0   'False
  39.         Italic          =   0   'False
  40.         Strikethrough   =   0   'False
  41.      EndProperty
  42.       Height          =   495
  43.       Left            =   7440
  44.       TabIndex        =   8
  45.       Top             =   5640
  46.       Width           =   3375
  47.    End
  48.    Begin VB.ListBox List1
  49.       BeginProperty Font
  50.          Name            =   "Calibri"
  51.          Size            =   9.75
  52.          Charset         =   0
  53.          Weight          =   400
  54.          Underline       =   0   'False
  55.         Italic          =   0   'False
  56.         Strikethrough   =   0   'False
  57.      EndProperty
  58.       Height          =   6135
  59.       Left            =   10920
  60.       TabIndex        =   7
  61.       Top             =   1320
  62.       Width           =   3015
  63.    End
  64.    Begin VB.TextBox DirectoryBox
  65.       BeginProperty Font
  66.          Name            =   "Calibri"
  67.          Size            =   12
  68.          Charset         =   0
  69.          Weight          =   400
  70.          Underline       =   0   'False
  71.         Italic          =   0   'False
  72.         Strikethrough   =   0   'False
  73.      EndProperty
  74.       Height          =   405
  75.       Left            =   10920
  76.       TabIndex        =   6
  77.       Top             =   840
  78.       Width           =   3015
  79.    End
  80.    Begin VB.PictureBox Graph
  81.       BackColor       =   &H00FFFFFF&
  82.       BeginProperty Font
  83.          Name            =   "MS Sans Serif"
  84.          Size            =   8.25
  85.          Charset         =   0
  86.          Weight          =   400
  87.          Underline       =   0   'False
  88.         Italic          =   0   'False
  89.         Strikethrough   =   0   'False
  90.      EndProperty
  91.       Height          =   4455
  92.       Left            =   240
  93.       ScaleHeight     =   -111
  94.       ScaleLeft       =   250
  95.       ScaleMode       =   0  'User
  96.      ScaleTop        =   110
  97.       ScaleWidth      =   650
  98.       TabIndex        =   3
  99.       Top             =   840
  100.       Width           =   10575
  101.    End
  102.    Begin VB.CommandButton Blank
  103.       Appearance      =   0  'Flat
  104.      Caption         =   "Blank"
  105.       BeginProperty Font
  106.          Name            =   "Calibri"
  107.          Size            =   15.75
  108.          Charset         =   0
  109.          Weight          =   400
  110.          Underline       =   0   'False
  111.         Italic          =   0   'False
  112.         Strikethrough   =   0   'False
  113.      EndProperty
  114.       Height          =   495
  115.       Left            =   240
  116.       TabIndex        =   2
  117.       Top             =   5640
  118.       Width           =   3375
  119.    End
  120.    Begin VB.CommandButton ScanSample
  121.       Appearance      =   0  'Flat
  122.      Caption         =   "Scan"
  123.       BeginProperty Font
  124.          Name            =   "Calibri"
  125.          Size            =   15.75
  126.          Charset         =   0
  127.          Weight          =   400
  128.          Underline       =   0   'False
  129.         Italic          =   0   'False
  130.         Strikethrough   =   0   'False
  131.      EndProperty
  132.       Height          =   495
  133.       Left            =   3840
  134.       TabIndex        =   1
  135.       Top             =   5640
  136.       Width           =   3375
  137.    End
  138.    Begin VB.CommandButton Exit
  139.       BackColor       =   &H80000005&
  140.       Caption         =   "X"
  141.       BeginProperty Font
  142.          Name            =   "Calibri"
  143.          Size            =   8.25
  144.          Charset         =   0
  145.          Weight          =   400
  146.          Underline       =   0   'False
  147.         Italic          =   0   'False
  148.         Strikethrough   =   0   'False
  149.      EndProperty
  150.       Height          =   195
  151.       Left            =   13800
  152.       MaskColor       =   &H00FFFFFF&
  153.       Style           =   1  'Graphical
  154.      TabIndex        =   0
  155.       Top             =   0
  156.       Width           =   255
  157.    End
  158.    Begin VB.Label Label8
  159.       Alignment       =   2  'Center
  160.      BackColor       =   &H8000000E&
  161.       Caption         =   "versus"
  162.       BeginProperty Font
  163.          Name            =   "MS Sans Serif"
  164.          Size            =   9.75
  165.          Charset         =   0
  166.          Weight          =   400
  167.          Underline       =   0   'False
  168.         Italic          =   0   'False
  169.         Strikethrough   =   0   'False
  170.      EndProperty
  171.       Height          =   255
  172.       Left            =   5160
  173.       TabIndex        =   16
  174.       Top             =   480
  175.       Width           =   735
  176.    End
  177.    Begin VB.Label Label7
  178.       Alignment       =   2  'Center
  179.      Appearance      =   0  'Flat
  180.      BackColor       =   &H80000005&
  181.       BorderStyle     =   1  'Fixed Single
  182.      Caption         =   "Wavelength (nm )"
  183.       BeginProperty Font
  184.          Name            =   "MS Sans Serif"
  185.          Size            =   12
  186.          Charset         =   0
  187.          Weight          =   700
  188.          Underline       =   0   'False
  189.         Italic          =   0   'False
  190.         Strikethrough   =   0   'False
  191.      EndProperty
  192.       ForeColor       =   &H80000008&
  193.       Height          =   375
  194.       Left            =   6240
  195.       TabIndex        =   15
  196.       Top             =   405
  197.       Width           =   2295
  198.    End
  199.    Begin VB.Label Label6
  200.       Alignment       =   2  'Center
  201.      Appearance      =   0  'Flat
  202.      BackColor       =   &H80000005&
  203.       BorderStyle     =   1  'Fixed Single
  204.      Caption         =   "Absorbance ( )"
  205.       BeginProperty Font
  206.          Name            =   "MS Sans Serif"
  207.          Size            =   12
  208.          Charset         =   0
  209.          Weight          =   700
  210.          Underline       =   0   'False
  211.         Italic          =   0   'False
  212.         Strikethrough   =   0   'False
  213.      EndProperty
  214.       ForeColor       =   &H80000008&
  215.       Height          =   375
  216.       Left            =   2520
  217.       TabIndex        =   14
  218.       Top             =   405
  219.       Width           =   2295
  220.    End
  221.    Begin VB.Label Label5
  222.       Alignment       =   2  'Center
  223.      Appearance      =   0  'Flat
  224.      BackColor       =   &H80000005&
  225.       BorderStyle     =   1  'Fixed Single
  226.      Caption         =   "WaveNumber (1/cm)"
  227.       BeginProperty Font
  228.          Name            =   "MS Sans Serif"
  229.          Size            =   8.25
  230.          Charset         =   0
  231.          Weight          =   400
  232.          Underline       =   0   'False
  233.         Italic          =   0   'False
  234.         Strikethrough   =   0   'False
  235.      EndProperty
  236.       ForeColor       =   &H80000008&
  237.       Height          =   255
  238.       Left            =   9000
  239.       TabIndex        =   13
  240.       Top             =   480
  241.       Width           =   1815
  242.    End
  243.    Begin VB.Label Label4
  244.       Alignment       =   2  'Center
  245.      Appearance      =   0  'Flat
  246.      BackColor       =   &H80000005&
  247.       BorderStyle     =   1  'Fixed Single
  248.      Caption         =   "Transmittance (%)"
  249.       BeginProperty Font
  250.          Name            =   "MS Sans Serif"
  251.          Size            =   8.25
  252.          Charset         =   0
  253.          Weight          =   400
  254.          Underline       =   0   'False
  255.         Italic          =   0   'False
  256.         Strikethrough   =   0   'False
  257.      EndProperty
  258.       ForeColor       =   &H80000008&
  259.       Height          =   255
  260.       Left            =   240
  261.       TabIndex        =   12
  262.       Top             =   480
  263.       Width           =   1815
  264.    End
  265.    Begin VB.Label DateLabel
  266.       BackColor       =   &H8000000E&
  267.       Caption         =   "Date"
  268.       BeginProperty Font
  269.          Name            =   "Times New Roman"
  270.          Size            =   9.75
  271.          Charset         =   0
  272.          Weight          =   400
  273.          Underline       =   0   'False
  274.         Italic          =   0   'False
  275.         Strikethrough   =   0   'False
  276.      EndProperty
  277.       Height          =   255
  278.       Left            =   2640
  279.       TabIndex        =   11
  280.       Top             =   120
  281.       Width           =   1815
  282.    End
  283.    Begin VB.Label Label3
  284.       BackColor       =   &H8000000E&
  285.       Caption         =   "ICN DATA COLLECTION:"
  286.       BeginProperty Font
  287.          Name            =   "Times New Roman"
  288.          Size            =   9.75
  289.          Charset         =   0
  290.          Weight          =   700
  291.          Underline       =   0   'False
  292.         Italic          =   0   'False
  293.         Strikethrough   =   0   'False
  294.      EndProperty
  295.       Height          =   255
  296.       Left            =   240
  297.       TabIndex        =   10
  298.       Top             =   120
  299.       Width           =   2295
  300.    End
  301.    Begin VB.Label Label2
  302.       Alignment       =   2  'Center
  303.      BackColor       =   &H00FFFFFF&
  304.       Caption         =   "   Enter ICN Account Name  in the text box below"
  305.       BeginProperty Font
  306.          Name            =   "Calibri"
  307.          Size            =   12
  308.          Charset         =   0
  309.          Weight          =   700
  310.          Underline       =   0   'False
  311.         Italic          =   0   'False
  312.         Strikethrough   =   0   'False
  313.      EndProperty
  314.       Height          =   615
  315.       Left            =   10920
  316.       TabIndex        =   9
  317.       Top             =   120
  318.       Width           =   3015
  319.    End
  320.    Begin VB.Label HelpLine
  321.       BackColor       =   &H80000005&
  322.       Caption         =   "Help Line"
  323.       BeginProperty Font
  324.          Name            =   "Times New Roman"
  325.          Size            =   12
  326.          Charset         =   0
  327.          Weight          =   700
  328.          Underline       =   0   'False
  329.         Italic          =   0   'False
  330.         Strikethrough   =   0   'False
  331.      EndProperty
  332.       Height          =   2295
  333.       Left            =   240
  334.       TabIndex        =   5
  335.       Top             =   6240
  336.       Width           =   10575
  337.       WordWrap        =   -1  'True
  338.   End
  339.    Begin VB.Label Label1
  340.       BackColor       =   &H80000005&
  341.       Caption         =   "250"
  342.       BeginProperty Font
  343.          Name            =   "Calibri"
  344.          Size            =   9.75
  345.          Charset         =   0
  346.          Weight          =   400
  347.          Underline       =   0   'False
  348.         Italic          =   0   'False
  349.         Strikethrough   =   0   'False
  350.      EndProperty
  351.       Height          =   255
  352.       Left            =   120
  353.       TabIndex        =   4
  354.       Top             =   5280
  355.       Width           =   10695
  356.    End
  357. End
  358. Attribute VB_Name = "Form1"
  359. Attribute VB_GlobalNameSpace = False
  360. Attribute VB_Creatable = False
  361. Attribute VB_PredeclaredId = True
  362. Attribute VB_Exposed = False
  363. Option Explicit
  364. 'Dim PixelNumber As Integer ' pixel number from the edit box
  365. Dim StopScanning As Integer ' stop scanning flag for continuous acquisition
  366. Dim Background(1900)
  367. Dim Spectra(1900, 7)
  368. Dim SpectraNbr As Integer
  369. Dim Intensity(1900)
  370. Dim StartTime
  371. Dim PreFix$
  372. ''''''''''''''''''''''''''''''''''''''''''/
  373. 'Additional declarations added here
  374.  
  375. Dim ServerName As String
  376. Dim Directory
  377. Dim HTMLRow$(500)
  378. Dim HTMLRowNumber As Integer
  379. ''''''''''''''''''''''''''''''''''''''''''/
  380. 'This call gives us the hWnd (window handle) of the screen
  381. Private Declare Function GetDesktopWindow Lib "user32" () As Long
  382.  
  383. 'This call assigns an hDC (handle of device context) from an hWnd
  384. Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
  385.  
  386. '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)
  387. 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
  388.  
  389. 'ReleaseDC will be used to clear out the hDC we generate for the screen capture.
  390. Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
  391.  
  392. Dim ScanBlankFlag As Integer
  393. Dim First As Integer, Last As Integer, WL1 As Integer, WL2 As Integer, MinY, MaxY
  394. 'FTP variables:
  395. Dim hOpen As Long, hConnection As Long, hFile As Long
  396. Dim dwType As Long
  397. Dim dwSeman As Long
  398.  
  399. Private Sub ClearGraph_Click()
  400. Dim x, y
  401.   Graph.Cls
  402.   List1.Clear
  403.   DirectoryBox.Text = ""
  404.   For y = 25 To 100 Step 25: Graph.Line (240, y)-(850, y), QBColor(7): Next y
  405.   For x = 250 To 850 Step 50: Graph.Line (x, -1)-(x, 110), QBColor(7): Next x
  406.   SpectraNbr = 0
  407.   HelpLine.Caption = "Enter your lab name in the box at the top right of this page."
  408.   DateLabel.Caption = Date$
  409. End Sub
  410.  
  411. Private Sub Form_Load()
  412.   Me.Top = 0
  413.   Me.Left = 0
  414.   Me.Width = 1366 * Screen.TwipsPerPixelX
  415.   Me.Height = 768 * Screen.TwipsPerPixelY
  416. 'Set up FTP
  417.  hOpen = InternetOpen("My VB Test", INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
  418.   If hOpen = 0 Then
  419.     ErrorOut Err.LastDllError, "InternetOpen"
  420.     Unload Form1
  421.   End If
  422.   dwType = FTP_TRANSFER_TYPE_BINARY
  423.   'dwType = FTP_TRANSFER_TYPE_ASCII
  424.  dwSeman = 0 'Active symantic ftp, not spelling error: semantic? and 0 is active.
  425.  'dwSeman = INTERNET_FLAG_PASSIVE
  426.  hConnection = 0
  427.  
  428. Dim i, s$
  429. 'Set up Ocean Optics Spectrometer
  430. 'ServerName = "130.111.192.243"
  431.  ServerName = "interchemnet.um.maine.edu"
  432.  
  433. 'Open json file template and store in HTMLRow$(I) array
  434.  Open App.Path + "\ICNhtml.txt" For Input As 1
  435.   i = 0
  436.   While Not EOF(1)
  437.     i = i + 1
  438.     Line Input #1, HTMLRow$(i)
  439.   Wend
  440.   HTMLRowNumber = i
  441.   Close 1
  442.   Open App.Path + "\CalNbrs.txt" For Input As 1
  443.     Input #1, WL1
  444.     Input #1, WL2
  445.     Input #1, First
  446.     Input #1, Last
  447.     Input #1, MaxY
  448.     Input #1, PreFix$
  449.   Close 1
  450.   SpectraNbr = 0
  451.   Graph.ScaleLeft = 240
  452.   Graph.ScaleWidth = 610
  453.  
  454.   s$ = "            "
  455.   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"
  456.   s$ = "This program must have the Vernier LoggerLite Program running in the background." + Chr$(13)
  457.   s$ = s$ + "Close all other programs and double click Default.gmbl" + Chr$(13)
  458.   s$ = s$ + "On the Logger program menu, click Experiment, Change Units and then %Transmittance" + Chr$(13)
  459.   s$ = s$ + "Click Experiment again, Calibrate, Spectrometer 1. Wait, then click Disable Calibration." + Chr$(13)
  460.   s$ = s$ + "Then click the Collect icon. Select Erase and Continue if needed." + Chr$(13)
  461.   s$ = s$ + "Click on this program to bring it to the front. Click Next User."
  462.   HelpLine.Caption = s$
  463.   StartTime = Timer
  464. End Sub
  465. Private Sub Form_Unload(Cancel As Integer)
  466.   If hConnection <> 0 Then InternetCloseHandle hConnection
  467.   hConnection = 0
  468.   HelpLine.Caption = "Disconnected."
  469.   End
  470. End Sub
  471.  
  472. Private Sub Blank_Click()
  473.   'Clear background array
  474.  Erase Background
  475.   'Graph.Cls
  476.  Scan 1  '1 is for Blank
  477.  
  478. End Sub
  479. Private Sub Exit_Click()
  480.   Dim w$
  481.   w$ = InputBox$("To calibrate, block beam path and enter password, or click cancel.")
  482.   If w$ = "dark" Then
  483.     'Clear background array
  484.    Graph.Cls
  485.     w = MsgBox("Block light path completely and click OK")
  486.     Scan 0 '0 is for Dark Background
  487.  ElseIf w$ = "exit" Then
  488.     Open App.Path + "\CalNbrs.txt" For Output As 1
  489.       Print #1, WL1
  490.       Print #1, WL2
  491.       Print #1, First
  492.       Print #1, Last
  493.       Print #1, MaxY
  494.       Print #1, PreFix$
  495.       Print #1, "First 2 are Wavelength Range, next 2 are first and last is MaxY Dark Value."
  496.     Close 1
  497.     End
  498.   End If
  499. End Sub
  500.  
  501. Private Sub ScanSample_Click()
  502.   If ScanBlankFlag = 0 Then MsgBox ("A Blank is required before a %T or A scan."): Exit Sub
  503.   Scan 3  '2 is for %T scan, Nbr=3 is for A scan.
  504. End Sub
  505. Private Sub DirectoryBox_KeyUp(KeyCode As Integer, Shift As Integer)
  506.  Dim i1 As Integer, i2 As Integer, w$, ww$
  507.  Dim ftpcheck As Boolean
  508.  
  509.  If KeyCode = 13 Then
  510.   'Open connection to FTP server
  511.    'Make sure all connections are closed.
  512.    If hConnection <> 0 Then
  513.         InternetCloseHandle hConnection
  514.     End If
  515.     'Now open the specified connection
  516.    hConnection = InternetConnect(hOpen, "ftp.umeche.maine.edu", INTERNET_INVALID_PORT_NUMBER, "DebugUser", "Test2015", INTERNET_SERVICE_FTP, dwSeman, 0)
  517.     If hConnection = 0 Then
  518.         ErrorOut Err.LastDllError, "InternetConnect"
  519.         Exit Sub
  520.     Else
  521.         HelpLine.Caption = "Connected to ftp.umeche.maine.edu"
  522.     End If
  523.    
  524.     'Now connect to specified directory
  525.    
  526.     If (FtpSetCurrentDirectory(hConnection, DirectoryBox.Text) = False) Then
  527.        ErrorOut Err.LastDllError, "FtpSetCurrentDirectory"
  528.        Exit Sub
  529.     Else
  530.        HelpLine.Caption = "Directory is changed to " & DirectoryBox.Text
  531.     End If
  532.  
  533.   'Clear listbox and add current datafile names to List1
  534.  List1.Clear
  535.   Dim szDir As String
  536.   Dim hFind As Long
  537.   Dim nLastError As Long
  538.   Dim dError As Long
  539.   Dim ptr As Long
  540.   Dim pData As WIN32_FIND_DATA
  541.  
  542.   hFind = FtpFindFirstFile(hConnection, "*.*", pData, 0, 0)
  543.   nLastError = Err.LastDllError
  544.   If hFind = 0 Then
  545.         If (nLastError = ERROR_NO_MORE_FILES) Then
  546.             MsgBox "This directory is empty!"
  547.         Else
  548.             ErrorOut Err.LastDllError, "FtpFindFirstFile"
  549.         End If
  550.         Exit Sub
  551.   End If
  552.  
  553.   dError = NO_ERROR
  554.   Dim bRet As Boolean
  555.   szDir = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
  556.   List1.AddItem (szDir)
  557.   Do
  558.         pData.cFileName = String(MAX_PATH, 0)
  559.         bRet = InternetFindNextFile(hFind, pData)
  560.         If Not bRet Then
  561.             dError = Err.LastDllError
  562.             If dError = ERROR_NO_MORE_FILES Then
  563.                 Exit Do
  564.             Else
  565.                 ErrorOut Err.LastDllError, "InternetFindNextFile"
  566.                 InternetCloseHandle (hFind)
  567.                 Exit Sub
  568.             End If
  569.         Else
  570.             szDir = Left(pData.cFileName, InStr(1, pData.cFileName, String(1, 0), vbBinaryCompare) - 1)
  571.             List1.AddItem (szDir)
  572.         End If
  573.   Loop
  574.    
  575.   Dim szTemp As String
  576.   szTemp = String(1024, Chr$(0))
  577.   If (FtpGetCurrentDirectory(hConnection, szTemp, 1024) = False) Then
  578.     ErrorOut Err.LastDllError, "FtpGetCurrentDirectory"
  579.     Exit Sub
  580.   End If
  581.   'MsgBox szDir, , "Directory Listing of: " & szTemp
  582.  InternetCloseHandle (hFind)
  583.   'Make sure all connections are closed.
  584.  If hConnection <> 0 Then
  585.         InternetCloseHandle hConnection
  586.   End If
  587.   w$ = "Your data will automatically be stored on the ICN server. To access it from your computer, tablet or smart phone, "
  588.   w$ = w$ & "write down this address in your notebook: http://icn2.umeche.maine.edu/DataFiles/" & DirectoryBox.Text & "/index.html" & Chr$(13)
  589.   w$ = w$ & " Enter the address in the address bar of a browser like Internet Explorer, Chrome, Firefox..."
  590.   HelpLine.Caption = w$
  591.  End If
  592. End Sub
  593.  
  594. Private Sub Scan(Nbr As Integer)
  595.   Dim ScreenColor As Long
  596.   Dim Counter As Integer
  597.   Dim x As Long, y As Long, y0 As Long
  598.   Dim i As Integer, s1, s2, w1, w2
  599.   Dim Ix As Integer
  600.   Dim WL, s, A
  601.   Dim FileName As String
  602.  
  603.   Dim DC As Long
  604.   Dim T0
  605.  
  606.  'First, shrink this window
  607.    Me.Top = 0
  608.     Me.Left = 0
  609.     Me.Width = 1980
  610.     Me.Height = 570
  611.     T0 = Timer: While (Timer - T0) < 1: Wend 'Wait 1 seconds for spectrometer and screen
  612.    'Get the hWnd of the screen
  613.    Dim scrHwnd As Long
  614.     scrHwnd = GetDesktopWindow
  615.     'Now, assign an hDC to the hWnd we generated
  616.    Dim shDC As Long
  617.     shDC = GetDC(scrHwnd)
  618.     'Determine the size of the screen
  619.    Dim screenWidth As Long, screenHeight As Long
  620.     screenWidth = Screen.Width \ Screen.TwipsPerPixelX
  621.     screenHeight = Screen.Height \ Screen.TwipsPerPixelY
  622.     'Copy the pixel data from the screen into our form
  623.    BitBlt Me.hDC, 0, 0, screenWidth, screenHeight, shDC, 0, 0, vbSrcCopy
  624.     'Release our hold on the screen DC
  625.    ReleaseDC scrHwnd, shDC
  626.     Me.Picture = Me.Image
  627.    
  628.    
  629.     't0 = Timer
  630.    'Analyze
  631.    'Hide all boxes and controls
  632.    Blank.Visible = False
  633.     ClearGraph.Visible = False
  634.     DateLabel.Visible = False
  635.     DirectoryBox.Visible = False
  636.     Form1.Exit.Visible = False
  637.     Graph.Visible = False
  638.     HelpLine.Visible = False
  639.     List1.Visible = False
  640.     ScanSample.Visible = False
  641.     Label1.Visible = False
  642.     Label2.Visible = False
  643.     Label3.Visible = False
  644.     Label4.Visible = False
  645.     Label5.Visible = False
  646.     Label6.Visible = False
  647.     Label7.Visible = False
  648.     Label8.Visible = False
  649.    
  650.   ScreenColor = 0
  651.   Counter = 0
  652.   'Screen size 1920 by 1080, x range max: 100 to 1525, y range max: 100 to 1000
  653.  'Laptop Screen size 1366 by 768, x range max: 100 to 1350, y range max: 100 to 1000
  654.  'erase Intensity
  655.  'Expand Form for analysis
  656.  Me.Width = 1366 * Screen.TwipsPerPixelX
  657.   Me.Height = 768 * Screen.TwipsPerPixelY
  658.   'MsgBox ("ok1?")
  659.  'Find the first point on plotted data
  660.  x = First
  661.   For y = 125 To 665
  662.     ScreenColor = Me.Point(x, y)
  663.     If ScreenColor = 3342591 Then Intensity(x) = y: y0 = y: y = 750: Counter = 1
  664.   Next y
  665.   If Counter = 0 Then MsgBox ("Couldn't find data"): Exit Sub
  666.   'To save time, utilize fact that line is continuous and search there and step outward
  667.  For x = First + 3 To Last Step 3
  668.     For y = 1 To 100
  669.       ScreenColor = Me.Point(x, y0 + y)
  670.       If ScreenColor = 3342591 And (y0 + y) < 666 Then
  671.         Intensity(x) = y0 + y:      y0 = y0 + y: y = 999: Counter = Counter + 1
  672.       End If
  673.       ScreenColor = Me.Point(x, y0 - y)
  674.       If ScreenColor = 3342591 And (y0 - y) > 124 Then
  675.         Intensity(x) = y0 - y:      y0 = y0 - y: y = 999: Counter = Counter + 1
  676.       End If
  677.     Next y
  678.     If y = 101 Then MsgBox ("Couldn't extract all data"): Exit Sub
  679.   Next x
  680.  
  681.   Me.Picture = Nothing
  682.   Blank.Visible = True
  683.   ClearGraph.Visible = True
  684.   DateLabel.Visible = True
  685.   DirectoryBox.Visible = True
  686.   Form1.Exit.Visible = True
  687.   Graph.Visible = True
  688.   HelpLine.Visible = True
  689.   List1.Visible = True
  690.   ScanSample.Visible = True
  691.   Label1.Visible = True
  692.   Label2.Visible = True
  693.   Label3.Visible = True
  694.   Label4.Visible = True
  695.   Label5.Visible = True
  696.   Label6.Visible = True
  697.   Label7.Visible = True
  698.   Label8.Visible = True
  699.  
  700.   Graph.Cls
  701.   For y = 25 To 100 Step 25: Graph.Line (240, y)-(850, y), QBColor(7): Next y
  702.   For x = 250 To 850 Step 50: Graph.Line (x, -1)-(x, 110), QBColor(7): Next x
  703.   DoEvents
  704.   'Find first data point, minimum, maximum and last data point for %Signal calculation.
  705.  
  706. 'Now plot %Signal versus wavelength
  707.  If Nbr = 0 Then 'Find first x, last x and MaxY (Max is actually min value since y plots down
  708.    'If this is not done, program uses last good values stored in calnbrs.txt
  709.    MaxY = 0: y = 0 'First = 0: Last = 0
  710.    For x = First To Last Step 3
  711.       MaxY = MaxY + Intensity(x): y = y + 1
  712.       'If First = 0 And Ix > 0 Then First = X
  713.      'If First > 0 Then MaxY = MaxY + Ix
  714.      'If First > 0 And Ix = 0 Then Last = X: X = 1900
  715.    Next x
  716.     MaxY = MaxY / y
  717.   ElseIf Nbr = 1 Then 'Scan blank
  718.    For x = First To Last Step 3
  719.       WL = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
  720.       Background(x) = MaxY - Intensity(x)
  721.       Graph.PSet (WL, 100), QBColor(7)
  722.     Next x
  723.     SpectraNbr = 0
  724.     ScanBlankFlag = 1
  725.   ElseIf Nbr = 2 Then 'Plot Transmittance. Don't Scan unless a blank has been done.
  726.    For x = First To Last Step 3
  727.       If Background(x) > 0 Then
  728.         Spectra(x, SpectraNbr) = 100 * (MaxY - Intensity(x)) / Background(x)
  729.       End If
  730.     Next x
  731.     For i = 0 To SpectraNbr
  732.       For x = First To Last Step 3
  733.         If Background(x) > 0 And Background(x + 3) > 0 Then
  734.           w1 = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
  735.           w2 = Int((WL2 - WL1) * ((x + 3) - First) / (Last - First) + WL1 + 0.5)
  736.           Graph.Line (w1, Spectra(x, i))-(w2, Spectra(x + 3, i)), QBColor(i)
  737.         End If
  738.       Next x
  739.     Next i
  740.     SpectraNbr = SpectraNbr + 1
  741.    
  742.   ElseIf Nbr = 3 Then 'Plot Absorbance. Don't Scan unless a blank has been done.
  743.    For x = First To Last Step 3
  744.       WL = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
  745.       If Background(x) > 0 Then
  746.         Spectra(x, SpectraNbr) = 100 * (MaxY - Intensity(x)) / Background(x)
  747.         'If s > 0 Then A = -Log(s) / Log(10) Else A = 5
  748.        'Graph.PSet (WL, 25 * A)
  749.      End If
  750.     Next x
  751.     For i = 0 To SpectraNbr
  752.       For x = First To Last Step 3
  753.         If Background(x) > 0 And Background(x + 3) > 0 Then
  754.           s1 = Spectra(x, i) / 100
  755.           s2 = Spectra(x + 3, i) / 100
  756.           If s1 > 0 And s2 > 0 Then
  757.             w1 = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
  758.             w2 = Int((WL2 - WL1) * ((x + 3) - First) / (Last - First) + WL1 + 0.5)
  759.             Graph.Line (w1, 25 * (-Log(s1) / Log(10)))-(w2, 25 * (-Log(s2) / Log(10))), QBColor(i)
  760.           End If
  761.         End If
  762.       Next x
  763.     Next i
  764.     SpectraNbr = SpectraNbr + 1
  765.   End If
  766.  
  767.   If Nbr > 1 Then
  768.      'Create HTML file and save on server
  769.    If DirectoryBox.Text <> "" Then 'assume an IP and save it on server
  770.      HelpLine.Caption = "Scan Complete. Now writing file to server."
  771.       icnmake ("temp.json")
  772.       HelpLine.Caption = "Temp.json Data File Saved"
  773. ''''''SaveToDisk
  774.      SaveToServer
  775.       'HelpLine.Caption = "File saved on server and web page updated."
  776.    Else 'Save it locally as a text file.
  777.      'FileName = Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
  778.      'FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
  779.      'FileName = FileName + ".TXT"
  780.      'Open App.Path + "\" + FileName For Output As 1
  781.      'For j = 300 To 700
  782.      '  'Graph.PSet (x, yy(j, 1)), QBColor(14)
  783.      '  x = 10000000# / j  'All files saved as wavenumber and %Transmission like FTIR
  784.      '  If jCount(j - 300) > 0 Then Print #1, Str$(Int(x + 0.5)) + "," + Str$(Int(100 * Spectra(j - 300) + 0.5) / 100)
  785.      'Next j
  786.      'Close 1
  787.      '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."
  788.    End If
  789.   End If
  790.  
  791.   'DarkBack.Enabled = True
  792.  Blank.Enabled = True ' re-enable buttons
  793.  ScanSample.Enabled = True
  794. End Sub
  795.  
  796.  
  797. Sub icnmake(fname2$)
  798. Dim Count As Integer
  799. Dim WorkString As String * 12
  800. Dim Record As String * 36
  801. Dim RecordLength As Integer
  802. Dim i, L, j, kk, k1, k2, Sign, Sign0, Exponent, Exponent0 As Integer
  803. Dim ICNPath As String, FileName As String
  804. Dim d, d2, iflag
  805. Dim lf$, Cr$, s$, s2$, d3$, xs$, ys$
  806. Dim work, x As Long, y, WL
  807.  
  808. lf$ = Chr$(10)   'W* variables w are always temp. & local. DL
  809. Cr$ = Chr$(13)   'i,(j,k,l) variables are always temp. & local  DL
  810.  
  811. ICNPath = CurDir
  812.  
  813. Open App.Path + "\" + fname2$ For Output As 1
  814. 'Header is single string.
  815.    FileName = PreFix$ + "-" + Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
  816.     FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
  817.     s$ = FileName  'ICN ID Header
  818.    Print #1, "{"
  819.     Print #1, "label: " + "'" + s$ + "',"
  820.     Print #1, "data: [";
  821.    
  822.     For x = First To Last Step 3 'First point will be at 240 nm, last at 850 nm.
  823.      If Background(x) > 0 Then
  824.         WL = Int((WL2 - WL1) * (x - First) / (Last - First) + WL1 + 0.5)
  825.         y = 100 * (MaxY - Intensity(x)) / Background(x)
  826.         xs$ = Str$(10000000# / WL): ys$ = Str$(y) 'All files saved as wavenumber rather than wavelength
  827.        Print #1, "[" + xs$ + "," + ys$ + "], ";
  828.       End If
  829.     Next x
  830.     Print #1, "[" + xs$ + "," + ys$ + "]]"  'duplicate last point to close out string
  831.    Print #1, "}"
  832. Close 1 'Close File
  833.  
  834. End Sub
  835.  
  836.  
  837. Private Sub SaveToServer()
  838.   Dim T0, fp$, fname2$, i, FileName As String
  839.   FileName = PreFix$ + "-" + Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
  840.   FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
  841.   FileName = FileName + ".JSON"
  842.   Dim ftpcheck As Boolean
  843.  'Open connection and change directory
  844.  If hConnection <> 0 Then
  845.         InternetCloseHandle hConnection
  846.   End If
  847.   'Now open the specified connection
  848.  hConnection = InternetConnect(hOpen, "interchemnet.um.maine.edu", INTERNET_INVALID_PORT_NUMBER, "icninstrument", "5ka#ixo9", INTERNET_SERVICE_FTP, dwSeman, 0)
  849.   If hConnection = 0 Then
  850.         ErrorOut Err.LastDllError, "InternetConnect"
  851.         Exit Sub
  852.   Else
  853.         HelpLine.Caption = "Connected to interchemnet.um.maine.edu"
  854.   End If
  855.   'Now connect to specified directory
  856.  If (FtpSetCurrentDirectory(hConnection, DirectoryBox.Text) = False) Then
  857.        ErrorOut Err.LastDllError, "FtpSetCurrentDirectory"
  858.        Exit Sub
  859.   Else
  860.        HelpLine.Caption = "Directory is changed to " & DirectoryBox.Text
  861.   End If
  862.  
  863.   'Place data file in student folder
  864.  If (FtpPutFile(hConnection, CurDir$ + "\" + "Temp.json", FileName, dwType, 0) = False) Then
  865.     'Wait a second and try one more time
  866.    T0 = Timer: While Timer - T0 < 1: Wend
  867.     If (FtpPutFile(hConnection, CurDir$ + "\" + "Temp.json", FileName, dwType, 0) = False) Then
  868.       ErrorOut Err.LastDllError, "FtpPutFile"
  869.       Exit Sub
  870.     End If
  871.   End If
  872.   HelpLine.Caption = FileName & " has been saved on server!"
  873.  
  874.  
  875.   'Add filename to list box
  876.  Form1.List1.AddItem FileName
  877.   Form1.List1.ListIndex = Form1.List1.ListCount - 1
  878.   'Create HTML file: index.html
  879.  CreateHTML
  880.   'Copy updated student index.html to student folder
  881.  fp$ = App.Path + "\index.html"
  882.   fname2$ = "index.html"
  883.   If (FtpPutFile(hConnection, fp$, fname2$, dwType, 0) = False) Then
  884.       ErrorOut Err.LastDllError, "FtpPutFile"
  885.       Exit Sub
  886.   Else
  887.       HelpLine.Caption = FileName & " saved on server!"
  888.   End If
  889.  
  890.   'Close connection
  891.  If hConnection <> 0 Then
  892.         InternetCloseHandle hConnection
  893.   End If
  894.  
  895. 'erase temp.json
  896. 'skip next line for testing
  897.  '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Kill fp$
  898. 'Find position of new file for LoadFiles_Click and select it
  899. For i = 0 To Form1.List1.ListCount - 1
  900.   If Form1.List1.List(i) = FileName + ".json" Then Form1.List1.Selected(i) = True
  901. Next i
  902. FileName = ""
  903. '''FirstTime = "YES" 'Force load defaults for new sample scans
  904. T0 = Timer: While Timer - T0 < 1: Wend
  905.  
  906. End Sub
  907. Private Sub SaveToDisk()
  908.   Dim T0, fp$, fname2$, i, FileName
  909.   'Rename temp.json file to filename.json
  910.  FileName = PreFix$ + "-" + Right$(Date$, 2) + Left$(Date$, 2) + Mid$(Date$, 4, 2)
  911.   FileName = FileName + "-" + Left$(Time$, 2) + Mid$(Time$, 4, 2) + Right$(Time$, 2)
  912.   FileName = FileName + ".JSON"
  913.   FileCopy "temp.json", FileName
  914.   'Add filename to list box
  915.  Form1.List1.AddItem FileName
  916.   Form1.List1.ListIndex = Form1.List1.ListCount - 1
  917.   CreateHTML
  918.   For i = 0 To Form1.List1.ListCount - 1
  919.     If Form1.List1.List(i) = FileName + ".json" Then Form1.List1.Selected(i) = True
  920.   Next i
  921.   FileName = ""
  922. End Sub
  923.  
  924. Private Sub CreateHTML()
  925. 'Updates student index.html file
  926. Dim i, j, k, Q$, fp$
  927. Q$ = Chr$(34)
  928. Open "index.html" For Output As 1
  929. For i = 1 To HTMLRowNumber
  930.   If HTMLRow$(i) <> "<!--icnstart-->" Then
  931.     Print #1, HTMLRow$(i)
  932.   Else 'write button for filename
  933.    Print #1, "<!--icnstart-->"
  934.     Print #1, "<b>" + DirectoryBox.Text + "</b>"
  935.     Print #1, "  </br>"
  936.     Print #1, "  <table border=" + Q$ + "0" + Q$ + ">"
  937.     Print #1, "  <tr>"
  938.     k = 0
  939.     For j = Form1.List1.ListCount - 1 To 0 Step -1
  940.       fp$ = Form1.List1.List(j)
  941.       Print #1, "    <td>"
  942.       Print #1, "      <input class=" + Q$ + "fetchSeries" + Q$ + " type=" + Q$ + "button" + Q$ + " value=" + Q$ + Left$(fp$, 16) + Q$ + ">"
  943.       Print #1, "      <a href=" + Q$ + fp$ + Q$ + ">*</a>"
  944.       Print #1, "      <span></span>"
  945.       Print #1, "    </td>"
  946.       k = k + 1: If k Mod 4 = 0 Then Print #1, "  <tr>" 'start a new row
  947.    Next j
  948.     Print #1, "  </tr>"
  949.     Print #1, "  </table>"
  950.   End If
  951. Next i
  952. Close 1
  953. End Sub
  954.  
  955. Private Sub ErrorOut(ByVal dwError As Long, ByRef szFunc As String)
  956. Dim dwRet As Long
  957. Dim dwTemp As Long
  958. Dim szString As String * 2048
  959. Dim szErrorMessage As String
  960.  
  961. dwRet = FormatMessage(FORMAT_MESSAGE_FROM_HMODULE, GetModuleHandle("wininet.dll"), dwError, 0, szString, 256, 0)
  962. szErrorMessage = szFunc & " error code: " & dwError & " Message: " & szString
  963. Debug.Print szErrorMessage
  964. MsgBox szErrorMessage
  965. If (dwError = 12003) Then
  966.     ' Extended error information was returned
  967.    dwRet = InternetGetLastResponseInfo(dwTemp, szString, 2048)
  968.     MsgBox szString
  969. End If
  970. End Sub
  971.  
  972. Private Sub Timer1_Timer()
  973.   If (Timer - StartTime > 7200) Then
  974.     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")
  975.     StartTime = Timer
  976.   End If
  977. End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement