Đề tài Thiết kế và chế tạo máy phân tích đa kênh (1024 kênh) ghép với máy vi tính qua cổng usb

lục A - 23 l = l + 1 Else Exit For End If Next For i = 0 To 9 If Text2(i) "" Then m = m + 1 Else Exit For End If Next If m <= l Then min = m Else min = l End If min = min - 1 If min >= 0 Then ReDim X(0, min) As Double ReDim Y(min, 0) As Double ReDim z(min, 0) As Double ReDim e(min, 0) As Double For i = 0 To (min) X(0, i) = CDbl(Text1(i).Text) Y(i, 0) = CDbl(Text2(i).Text) Next Bac = min b = taomtA(X, Bac) c = Mat.Transpose(b) d = Mat.Multiply(c, b) mat1 = Mat.Find_R_C(d) e = Mat.Inv(d) F = Mat.Multiply(e, c) p = Mat.Multiply(F, Y) For i = 0 To min z(i, 0) = 0 Next For i = 0 To min For j = 0 To Bac z(i, 0) = z(i, 0) + p(j, 0) * X(0, i) ^ (Bac - j) e(i, 0) = Abs(z(i, 0) - Y(i, 0)) Next Text4(i).Text = Format(e(i, 0), "00.00e-00") Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 24 Text3(i).Text = Format(z(i, 0), "00.0000") Next For j = 0 To Bac Text5(j).Text = Format(p(Bac - j, 0), "00.0000") Next For i = 0 To 1023 Kev(i) = 0 Next For i = 0 To 1023 For j = 0 To Bac Kev(i) = Kev(i) + p(j, 0) * i ^ (Bac - j) Next Next Else End If End Sub Private Sub Form_Load() If frmMain.Label24.Caption = "Cal" Then Dim NextLine As String Dim XY(10), X(10), Y(10) As String Dim DataRead As Integer Dim j, Last As Integer ClrTab Open frmMain.Label26.Caption For Input As #31 j = 0 NextLine = "" Do While Not EOF(31) Line Input #31, NextLine XY(j) = Trim(NextLine) NextLine = "" j = j + 1 Loop Last = j - 1 Close #31 For j = 0 To Last X(j) = Mid(XY(j), 1, InStr(1, XY(j), " ")) Text1(j).Text = CDbl(X(j)) Y(j) = Mid(XY(j), InStr(1, XY(j), " ") + 1, Len(XY(j)) - 1 - InStr(1, XY(j), " ")) Text2(j).Text = CDbl(Y(j)) Next CmdCal_Click Label15.Caption = frmMain.Label26.Caption End If End Sub Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 25 Private Sub mnuNew_Click() ClrTab Label15.Caption = "" End Sub Private Sub mnuOpen_Click() Dim NextLine As String Dim XY(10), X(10), Y(10) As String Dim DataRead As Integer Dim j, Last As Integer With CalDialog .Filter = "DataFile(*.eng)|*.eng|AllData(*.*)|*.*" .ShowOpen End With If CalDialog.FileName "" Then Open CalDialog.FileName For Input As #31 j = 0 NextLine = "" Do While Not EOF(31) Line Input #31, NextLine XY(j) = Trim(NextLine) 'Text2(j).Text = NextLine NextLine = "" j = j + 1 Loop Last = j - 1 Close #31 For j = 0 To Last X(j) = Mid(XY(j), 1, InStr(1, XY(j), " ")) Text1(j).Text = CDbl(X(j)) Y(j) = Mid(XY(j), InStr(1, XY(j), " ") + 1, Len(XY(j)) - 1 - InStr(1, XY(j), " ")) Text2(j).Text = CDbl(Y(j)) Next CmdCal_Click Label15.Caption = CalDialog.FileName frmMain.Label26.Caption = CalDialog.FileName frmMain.Label24.Caption = "Cal" frmMain.Label12.Caption = "Counts/Kev" frmMain.Label13.Caption = "Counts/Kev" End If End Sub Private Sub mnuSaveAS_Click() Dim l As Integer Dim m As Integer Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 26 Dim min As Integer Dim st As String Dim file1 Dim i As Integer l = 0 m = 0 For i = 0 To 9 If Text1(i) "" Then l = l + 1 Else Exit For End If Next For i = 0 To 9 If Text2(i) "" Then m = m + 1 Else Exit For End If Next If m <= l Then min = m Else min = l End If min = min - 1 ReDim X(min) As Double ReDim Y(min) As Double For i = 0 To (min) X(i) = CDbl(Text1(i).Text) Y(i) = CDbl(Text2(i).Text) Next CalDialog.Filter = "DataFile(*.eng)|*.eng|AllData(*.*)|*.*" CalDialog.ShowSave file1 = CalDialog.FileName Open file1 For Output As #31 Close #31 Open file1 For Append As #31 For i = 0 To min st = Str(X(i)) + " " + Str(Y(i)) + Chr(9) Print #31, st Next Close #31 Label15.Caption = CalDialog.FileName Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 27 frmMain.Label26.Caption = CalDialog.FileName frmMain.Label12.Caption = "Counts/Kev" frmMain.Label13.Caption = "Counts/Kev" End Sub Private Sub ClrTab() Dim i As Integer For i = 0 To 9 Text1(i).Text = "" Text2(i).Text = "" Text3(i).Text = "" Text4(i).Text = "" Next End Sub Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 28 ''------------------------------------------------------------------------ '' '' MÃ NGUỒN MODULE cMATHLIB ĐỂ TÍNH MA TRÂN '' ''------------------------------------------------------------------------ Option Explicit '''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' The dimensions of the matrix are checked ' Here '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Find_R_C(Mat() As Double) As Double() Dim Rows As Integer, Columns As Integer Dim i As Integer, j As Integer Dim Result() As Double Columns = 0 If Mat_1D(Mat, Rows) Then ReDim Result(Rows, 1) Result(0, 0) = Rows Result(0, 1) = Columns + 1 For i = 1 To Rows Result(i, 1) = Mat(i - 1) Next i Else Call Mat_2D(Mat, Rows, Columns) ReDim Result(Rows, Columns) Result(0, 0) = Rows Result(0, 1) = Columns For i = 1 To Rows For j = 1 To Columns '- 1 Result(i, j) = Mat(i - 1, j - 1) Next j Next i End If Find_R_C = Result End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Check if matrix has only one column ' shift the matrix one level and keep ' its dimensions details in Mat(0,0) and Mat(0,1) ' Mat(0,0)= no of rows ' Mat(0,1)= no of columns '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 29 Private Function Mat_1D(Mat() As Double, m As Integer) As Boolean Dim Temp_MAT As Double On Error GoTo Error_Handler Temp_MAT = Mat(0, 0) Mat_1D = False Exit Function Error_Handler: Mat_1D = True m = UBound(Mat) + 1 End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Check if matrix has more than one column ' if so return the dimension as described above '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Private Sub Mat_2D(Mat() As Double, m As Integer, n As Integer) Dim Temp_MAT As Double, i As Integer i = 0 m = UBound(Mat) + 1 On Error GoTo Error_Handler Do Until i < -1 Temp_MAT = Mat(0, i) i = i + 1 Loop Error_Handler: n = i End Sub '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function gan_m(Mat_1() As Double) As Double() Dim mat1() As Double Dim sol() As Double Dim i As Integer, j As Integer 'On Error GoTo Error_Handler mat1 = Find_R_C(Mat_1) ' // kiem tra chieu ma tran 'Mat2 = Find_R_C(Mat_2) 'If Mat1(0, 0) Mat2(0, 0) Or Mat1(0, 1) Mat2(0, 1) Then 'GoTo Error_Dimension 'End If ReDim sol(mat1(0, 0) - 1, mat1(0, 1) - 1) For i = 1 To mat1(0, 0) For j = 1 To mat1(0, 1) sol(i - 1, j - 1) = mat1(i, j) Next j Next i Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 30 gan_m = sol Erase sol 'Exit Function 'Error_Dimension: 'Err.Raise "5005", , "Dimensions of the two matrices do not match !" 'Error_Handler: 'If Err.Number = 5005 Then 'Err.Raise "5005", , "Dimensions of the two matrices do not match !" 'Else ' Err.Raise "5022", , "One or both of the matrices are null, this operation cannot be done !!" 'End If End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Add two matrices, their dimensions should be compatible! ' Function returns the summation or errors due to ' dimensions incompatibility ' Example: ' Check Main Form !! '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Add(Mat_1() As Double, Mat_2() As Double) As Double() Dim mat1() As Double, Mat2() As Double Dim sol() As Double Dim i As Integer, j As Integer On Error GoTo Error_Handler mat1 = Find_R_C(Mat_1) ' // kiem tra chieu ma tran Mat2 = Find_R_C(Mat_2) If mat1(0, 0) Mat2(0, 0) Or mat1(0, 1) Mat2(0, 1) Then GoTo Error_Dimension End If ReDim sol(mat1(0, 0) - 1, mat1(0, 1) - 1) For i = 1 To mat1(0, 0) For j = 1 To mat1(0, 1) sol(i - 1, j - 1) = mat1(i, j) + Mat2(i, j) Next j Next i Add = sol Erase sol Exit Function Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 31 Error_Dimension: Err.Raise "5005", , "Dimensions of the two matrices do not match !" Error_Handler: If Err.Number = 5005 Then Err.Raise "5005", , "Dimensions of the two matrices do not match !" Else Err.Raise "5022", , "One or both of the matrices are null, this operation cannot be done !!" End If End Function '''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Subtracts two matrices from each other, their ' dimensions should be compatible! ' Function returns the solution or errors due to ' dimensions incompatibility ' Example: ' Check Main Form !! '''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Subtract(Mat_1() As Double, Mat_2() As Double) As Double() Dim mat1() As Double, Mat2() As Double Dim i As Integer, j As Integer, sol() As Double On Error GoTo Error_Handler mat1 = Find_R_C(Mat_1) Mat2 = Find_R_C(Mat_2) If mat1(0, 0) Mat2(0, 0) Or mat1(0, 1) Mat2(0, 1) Then GoTo Error_Dimension End If ReDim sol(mat1(0, 0) - 1, mat1(0, 1) - 1) For i = 1 To mat1(0, 0) For j = 1 To mat1(0, 1) sol(i - 1, j - 1) = mat1(i, j) - Mat2(i, j) Next j Next i Subtract = sol Erase sol Exit Function Error_Dimension: Err.Raise "5007", , "Dimensions of the two matrices do not match !" Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 32 Error_Handler: If Err.Number = 5007 Then Err.Raise "5007", , "Dimensions of the two matrices do not match !" Else Err.Raise "5022", , "One or both of the matrices are null, this operation cannot be done !!" End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Multiply two matrices, their dimensions should be compatible! ' Function returns the solution or errors due to ' dimensions incompatibility ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Multiply(Mat_1() As Double, Mat_2() As Double) As Double() Dim mat1() As Double, Mat2() As Double, l As Integer Dim i As Integer, j As Integer, OptiString As String Dim sol() As Double, MulAdd As Double On Error GoTo Error_Handler MulAdd = 0 mat1 = Find_R_C(Mat_1) Mat2 = Find_R_C(Mat_2) If mat1(0, 1) Mat2(0, 0) Then GoTo Error_Dimension End If ReDim sol(mat1(0, 0) - 1, Mat2(0, 1) - 1) For i = 1 To mat1(0, 0) For j = 1 To Mat2(0, 1) For l = 1 To mat1(0, 1) MulAdd = MulAdd + mat1(i, l) * Mat2(l, j) Next l sol(i - 1, j - 1) = MulAdd MulAdd = 0 Next j Next i Multiply = sol Erase sol Exit Function Error_Dimension: Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 33 Err.Raise "5009", , "Dimensions of the two matrices not suitable for multiplication !" Error_Handler: If Err.Number = 5009 Then Err.Raise "5009", , "Dimensions of the two matrices not suitable for multiplication !" Else Err.Raise "5022", , "One or both of the matrices are null, this operation cannot be done !!" End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Determinant of a matrix should be (nxn) ' Function returns the solution or errors due to ' dimensions incompatibility ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Det(Mat() As Double) As Double Dim DArray() As Double, S As Integer Dim k As Integer, i As Integer, j As Integer Dim save As Double, ArrayK As Double, k1 As Integer Dim M1 As String, mat1() As Double On Error GoTo Error_Handler mat1 = Find_R_C(Mat) If mat1(0, 0) mat1(0, 1) Then GoTo Error_Dimension S = mat1(0, 0) Det = 1 DArray = mat1() For k = 1 To S If DArray(k, k) = 0 Then j = k Do While ((j < S) And (DArray(k, j) = 0)) j = j + 1 Loop If DArray(k, j) = 0 Then Det = 0 Exit Function Else For i = k To S save = DArray(i, j) DArray(i, j) = DArray(i, k) DArray(i, k) = save Next i Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 34 End If Det = -Det End If ArrayK = DArray(k, k) Det = Det * ArrayK If k < S Then k1 = k + 1 For i = k1 To S For j = k1 To S DArray(i, j) = DArray(i, j) - DArray(i, k) * (DArray(k, j) / ArrayK) Next j Next i End If Next Exit Function Error_Dimension: Err.Raise "5011", , "Matrix should be a square matrix !" Error_Handler: If Err.Number = 5011 Then Err.Raise "5011", , "Matrix should be a square matrix !" Else Err.Raise "5022", , "In order to do this operation values must be assigned to the matrix !!" End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Inverse of a matrix, should be (nxn) and det(Mat)0 ' Function returns the solution or errors due to ' dimensions incompatibility ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Inv(Mat() As Double) As Double() Dim sol() As Double Dim AI() As Double, AIN As Double, AF As Double, _ mat1() As Double Dim LL As Integer, LLM As Integer, L1 As Integer, _ L2 As Integer, LC As Integer, LCA As Integer, _ LCB As Integer, i As Integer, j As Integer On Error GoTo Error_Handler mat1 = Find_R_C(Mat) If mat1(0, 0) mat1(0, 1) Then GoTo Error_Dimension Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 35 If Det(mat1) = 0 Then GoTo Error_Zero ReDim sol(mat1(0, 0) - 1, mat1(0, 0) - 1) LL = mat1(0, 0) LLM = mat1(0, 1) ReDim AI(LL, LL) For L2 = 1 To LL For L1 = 1 To LL AI(L1, L2) = 0 Next AI(L2, L2) = 1 Next For LC = 1 To LL If Abs(mat1(LC, LC)) < 0.0000000001 Then For LCA = LC + 1 To LL If LCA = LC Then GoTo 1090 If Abs(mat1(LC, LCA)) > 0.0000000001 Then For LCB = 1 To LL mat1(LCB, LC) = mat1(LCB, LC) + mat1(LCB, LCA) AI(LCB, LC) = AI(LCB, LC) + AI(LCB, LCA) Next GoTo 1100 End If 1090 Next End If 1100 AIN = 1 / mat1(LC, LC) For LCA = 1 To LL mat1(LCA, LC) = AIN * mat1(LCA, LC) AI(LCA, LC) = AIN * AI(LCA, LC) Next For LCA = 1 To LL If LCA = LC Then GoTo 1150 AF = mat1(LC, LCA) For LCB = 1 To LL mat1(LCB, LCA) = mat1(LCB, LCA) - AF * mat1(LCB, LC) AI(LCB, LCA) = AI(LCB, LCA) - AF * AI(LCB, LC) Next 1150 Next Next For i = 1 To LL For j = 1 To LL sol(i - 1, j - 1) = AI(i, j) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 36 Next j Next i Inv = sol Erase sol Exit Function Error_Zero: Err.Raise "5012", , "Determinent equals zero, inverse can't be found !" Error_Dimension: Err.Raise "5014", , "Matrix should be a square matrix !" Error_Handler: If Err.Number = 5012 Then Err.Raise "5012", , "Determinent equals zero, inverse can't be found !" ElseIf Err.Number = 5014 Then Err.Raise "5014", , "Matrix should be a square matrix !" End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Multiply two vectors, dimensions should be (3x1) ' Function returns the solution or errors due to ' dimensions incompatibility ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function MultiplyVectors(Mat_1() As Double, Mat_2() As Double) As Double() Dim mat1() As Double, Mat2() As Double Dim i As Double, j As Double, k As Double Dim sol(2) As Double On Error GoTo Error_Handler mat1 = Find_R_C(Mat_1) Mat2 = Find_R_C(Mat_2) If mat1(0, 0) 3 Or mat1(0, 1) 1 Then GoTo Error_Dimension End If If Mat2(0, 0) 3 Or Mat2(0, 1) 1 Then GoTo Error_Dimension End If i = mat1(2, 1) * Mat2(3, 1) - mat1(3, 1) * Mat2(2, 1) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 37 j = mat1(3, 1) * Mat2(1, 1) - mat1(1, 1) * Mat2(3, 1) k = mat1(1, 1) * Mat2(2, 1) - mat1(2, 1) * Mat2(1, 1) sol(0) = i: sol(1) = j: sol(2) = k MultiplyVectors = sol Exit Function Error_Dimension: Err.Raise "5016", , "Dimension should be (3 x 1) for both matrices in order to do cross multiplication !" Error_Handler: If Err.Number = 5016 Then Err.Raise "5016", , "Dimension should be (3 x 1) for both matrices in order to do cross multiplication !" Else Err.Raise "5022", , "One or both of the matrices are null, this operation cannot be done !!" End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Magnitude of a Vector, vector should be (3x1) ' Function returns the solution or errors due to ' dimensions incompatibility ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function VectorMagnitude(Mat() As Double) As Double Dim mat1() As Double On Error GoTo Error_Handler mat1 = Find_R_C(Mat) If mat1(0, 0) 3 Or mat1(0, 1) 1 Then GoTo Error_Dimension End If VectorMagnitude = Sqr(mat1(1, 1) * mat1(1, 1) + mat1(2, 1) * mat1(2, 1) + mat1(3, 1) * mat1(3, 1)) Exit Function Error_Dimension: Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 38 Err.Raise "5018", , "Dimension of the matrix should be (1 x 3) in order to find the vector's norm !" Error_Handler: If Err.Number = 5018 Then Err.Raise "5018", , "Dimension of the matrix should be (3 x 1) in order to find the vector's magnitude !" Else Err.Raise "5022", , "In order to do this operation values must be assigned to the matrix !!" End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Transpose of a matrix ' Function returns the solution or errors ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function Transpose(Mat() As Double) As Double() Dim mat1() As Double, Tr_Mat() As Double Dim i As Integer, j As Integer, sol() As Double On Error GoTo Error_Handler mat1() = Find_R_C(Mat()) ReDim Tr_Mat(0 To mat1(0, 1), 0 To mat1(0, 0)) ReDim sol(mat1(0, 1) - 1, mat1(0, 0) - 1) Tr_Mat(0, 0) = mat1(0, 1) Tr_Mat(0, 1) = mat1(0, 0) For i = 1 To mat1(0, 0) For j = 1 To mat1(0, 1) Tr_Mat(j, i) = mat1(i, j) Next j Next i For i = 1 To Tr_Mat(0, 0) For j = 1 To Tr_Mat(0, 1) sol(i - 1, j - 1) = Tr_Mat(i, j) Next j Next i Transpose = sol Erase sol Exit Function Error_Handler: Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 39 Err.Raise "5028", , "In order to do this operation values must be assigned to the matrix !!" End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Multiply a matrix or a vector with a scalar quantity ' Function returns the solution or errors ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function ScalarMultiply(Value As Double, Mat() As Double) As Double() Dim i As Integer, j As Integer Dim mat1() As Double, sol() As Double On Error GoTo Error_Handler mat1 = Find_R_C(Mat) ReDim sol(mat1(0, 0) - 1, mat1(0, 1) - 1) For i = 1 To mat1(0, 0) For j = 1 To mat1(0, 1) sol(i - 1, j - 1) = mat1(i, j) * Value Next j Next i ScalarMultiply = sol Exit Function Error_Handler: Err.Raise "5022", , "Matrix was not assigned" End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Divide matrix elements or a vector by a scalar quantity ' Function returns the solution or errors ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function ScalarDivide(Value As Double, Mat() As Double) As Double() Dim i As Integer, j As Integer Dim mat1() As Double, sol() As Double On Error GoTo Error_Handler mat1 = Find_R_C(Mat) ReDim sol(mat1(0, 0) - 1, mat1(0, 1) - 1) For i = 1 To mat1(0, 0) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 40 For j = 1 To mat1(0, 1) sol(i - 1, j - 1) = mat1(i, j) / Value Next j Next i ScalarDivide = sol Exit Function Error_Handler: Err.Raise "5022", , "Matrix was not assigned" End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Print a matrix to multitext text box ' Function returns the solution or errors ' Example: ' Check Main Form !! ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function PrintMat(Mat_1() As Double) As String Dim N_Rows As Integer, N_Columns, k As Integer, _ i As Integer, j As Integer, m As Integer Dim StrElem As String, StrLen As Long, _ Greatest() As Integer, LarString As String Dim OptiString As String, sol As String Dim mat1() As Double mat1 = Find_R_C(Mat_1) sol = "" OptiString = "" N_Rows = mat1(0, 0) N_Columns = mat1(0, 1) ReDim Greatest(N_Columns) For i = 1 To N_Rows For j = 1 To N_Columns If i = 1 Then Greatest(j) = 0 For m = 1 To N_Rows StrElem = Format$(mat1(m, j), "0.0000") StrLen = Len(StrElem) If Greatest(j) < StrLen Then Greatest(j) = StrLen LarString = StrElem End If Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 41 Next m If Mid$(LarString, 1, 1) = "-" Then Greatest(j) = Greatest(j) + 1 End If StrElem = Format$(mat1(i, j), "0.0000") If Mid$(StrElem, 1, 1) = "-" Then StrLen = Len(StrElem) If Greatest(j) >= StrLen Then For k = 1 To (Greatest(j) - StrLen) OptiString = OptiString & " " Next k OptiString = OptiString & " " End If Else StrLen = Len(StrElem) If Greatest(j) > StrLen Then For k = 1 To (Greatest(j) - StrLen) OptiString = OptiString & " " Next k End If End If OptiString = OptiString & " " & Format$(mat1(i, j), "0.0000") Next j If i N_Rows Then sol = sol & OptiString & vbCrLf OptiString = "" End If sol = sol & OptiString OptiString = "" Next i PrintMat = sol Exit Function End Function Private Function Cutting(M_L As Integer) Dim Num As Integer Num = 0 Num = M_L \ 20 If M_L Mod 20 0 Then Num = Num + 1 Cutting = Num End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Return the maximum of two numbers ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function max(ByVal X As Double, Y As Double) As Double If X >= Y Then Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 42 max = X ElseIf X < Y Then max = Y End If End Function ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ' Return the minimum of two numbers ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' Public Function min(ByVal X As Double, Y As Double) As Double If X >= Y Then min = Y ElseIf X < Y Then min = X End If End Function ''''''''''''''''''''''''''''''''''''''''''''''' ' This routine finds the ' atan2(y,x) vlaue ''''''''''''''''''''''''''''''''''''''''''''''' Public Function atan2(ByVal Y As Double, ByVal X As Double) As Double Dim yy As Double, xx As Double yy = Abs(Y) xx = Abs(X) If Y = 0 And X > 0 Then atan2 = 0 ElseIf Y > 0 And X > 0 Then atan2 = Atn(yy / xx) ElseIf Y > 0 And X = 0 Then atan2 = PI / 2 ElseIf Y > 0 And X < 0 Then atan2 = PI - Atn(yy / xx) ElseIf Y = 0 And X < 0 Then atan2 = PI ElseIf Y < 0 And X < 0 Then atan2 = Atn(yy / xx) - PI ElseIf Y < 0 And X = 0 Then atan2 = PI / 2 ElseIf Y 0 Then atan2 = -Atn(yy / xx) End If End Function ''''''''''''''''''''''''''''''''''''''''''''''' ' This routine returns Pi value ''''''''''''''''''''''''''''''''''''''''''''''' Public Function PI() As Double PI = 4 * Atn(1) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 43 End Function ''''''''''''''''''''''''''''''''''''''''''''''' ' This routine returns the ' arc sin vlaue of an angle ''''''''''''''''''''''''''''''''''''''''''''''' Public Function asin(ByVal X As Double) As Double asin = Atn(X / (Sqr(Abs(1 - X * X)) + 1E-200)) End Function ''''''''''''''''''''''''''''''''''''''''''''''' ' This routine returns the ' arc cos vlaue of an angle ''''''''''''''''''''''''''''''''''''''''''''''' Public Function acos(ByVal X As Double) As Double acos = Atn(-X / (Sqr(1 - X * X))) + 2 * Atn(1) End Function Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 44 ‘ MÃ NGUỒN MODULE CRCMODULE ĐỂ KIỂM TRA LỖI TRUYỀN USB Option Explicit Function booleanAND(X As Long, Y As Long) As Long Dim output As Long Dim i As Integer Dim temp, temp1 As Integer output = 0 For i = 23 To 0 Step -1 '24 bit numbers accepted temp = X \ (2 ^ i) 'gets the bit of text1.text X = X - temp * (2 ^ i) 'subtracts it from the number temp1 = Y \ (2 ^ i) 'gets the bit of text2.text Y = Y - temp1 * (2 ^ i) 'subtracts it from the number If temp = 1 And temp1 = 1 Then 'If both are equal to 1 then return a 1 output = output + (2 ^ i) 'This returns a decimal number End If Next i booleanAND = output End Function Function booleanXOR(X As Long, Y As Long) As Long Dim output As Long Dim i As Integer Dim temp, temp1 As Integer output = 0 For i = 23 To 0 Step -1 '24 bit numbers accepted temp = X \ (2 ^ i) 'gets the bit of text1.text X = X - temp * (2 ^ i) 'subtracts it from the number temp1 = Y \ (2 ^ i) 'gets the bit of text2.text Y = Y - temp1 * (2 ^ i) 'subtracts it from the number If temp = 1 Xor temp1 = 1 Then 'If one or the other but not both=1 then return a 1 output = output + (2 ^ i) 'This returns a decimal number End If Next i booleanXOR = output End Function Function RShift(ByVal plValue As Long, piTimes As Integer) As Long 'Note a unsigned int needs to be stored ' in a long plValue = (plValue \ (2 ^ piTimes)) RShift = plValue End Function Function LShift(ByVal plValue As Long, piTimes As Integer) As Long Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 45 Dim k As Integer 'Note a unsigned int needs to be stored ' in a long plValue = plValue And CLng(RShift(CLng("&HFFFF"), piTimes)) plValue = (plValue * (2 ^ piTimes)) LShift = plValue End Function Public Function calc_CRC(oldCRC As Byte, newByte As Byte) As Integer Dim shift_reg, data_bit, sr_lsb, fb_bit, j As Integer shift_reg = oldCRC For j = 0 To 7 data_bit = booleanAND(RShift(newByte, j), 1) sr_lsb = booleanAND(Val(shift_reg), 1) fb_bit = booleanAND(booleanXOR(Val(data_bit), Val(sr_lsb)), 1) shift_reg = RShift(shift_reg, 1) If (fb_bit = 1) Then shift_reg = booleanXOR(Val(shift_reg), 140) Next calc_CRC = shift_reg End Function ‘ MÃ NGUỒN MODULE HID CỦA GIAO THỨC HID Option Explicit Dim bAlertable As Long Dim Capabilities As HIDP_CAPS Dim DataString As String Dim DetailData As Long Dim DetailDataBuffer() As Byte Dim DeviceAttributes As HIDD_ATTRIBUTES Dim DevicePathName As String Dim DeviceInfoSet As Long Dim ErrorString As String Dim EventObject As Long Public HIDHandle As Long Dim HIDOverlapped As OVERLAPPED Dim LastDevice As Boolean Public MyDeviceDetected As Boolean Dim MyDeviceInfoData As SP_DEVINFO_DATA Dim MyDeviceInterfaceDetailData As SP_DEVICE_INTERFACE_DETAIL_DATA Dim MyDeviceInterfaceData As SP_DEVICE_INTERFACE_DATA Dim Needed As Long Dim PreparsedData As Long Public ReadHandle As Long Dim Result As Long Dim Security As SECURITY_ATTRIBUTES Public Timeout As Boolean 'Set these to match the values in the device's firmware and INF file. '0925h is Lakeview Research's vendor ID. Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 46 Const MyVendorID = &H461 Const MyProductID = &H20 Public ReadBuffer() As Byte Public OutputReportData(31) As Byte Function FindTheHid() As Boolean 'Makes a series of API calls to locate the desired HID-class device. 'Returns True if the device is detected, False if not detected. Dim Count As Integer Dim GUIDString As String Dim HidGuid As GUID Dim MemberIndex As Long LastDevice = False MyDeviceDetected = False 'Values for SECURITY_ATTRIBUTES structure: Security.lpSecurityDescriptor = 0 Security.bInheritHandle = True Security.nLength = Len(Security) '************************************************************************** 'HidD_GetHidGuid 'Get the GUID for all system HIDs. 'Returns: the GUID in HidGuid. 'The routine doesn't return a value in Result 'but the routine is declared as a function for consistency with the other API calls. '************************************************************************** Result = HidD_GetHidGuid(HidGuid) Call DisplayResultOfAPICall("GetHidGuid") 'Display the GUID. GUIDString = _ Hex$(HidGuid.Data1) & "-" & _ Hex$(HidGuid.Data2) & "-" & _ Hex$(HidGuid.Data3) & "-" For Count = 0 To 7 'Ensure that each of the 8 bytes in the GUID displays two characters. Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 47 If HidGuid.Data4(Count) >= &H10 Then GUIDString = GUIDString & Hex$(HidGuid.Data4(Count)) & " " Else GUIDString = GUIDString & "0" & Hex$(HidGuid.Data4(Count)) & " " End If Next Count 'GUID for system HIDs = GUIDString '************************************************************************** 'SetupDiGetClassDevs 'Returns: a handle to a device information set for all installed devices. 'Requires: the HidGuid returned in GetHidGuid. '************************************************************************** DeviceInfoSet = SetupDiGetClassDevs _ (HidGuid, _ vbNullString, _ 0, _ (DIGCF_PRESENT Or DIGCF_DEVICEINTERFACE)) Call DisplayResultOfAPICall("SetupDiClassDevs") DataString = GetDataString(DeviceInfoSet, 32) '************************************************************************** 'SetupDiEnumDeviceInterfaces 'On return, MyDeviceInterfaceData contains the handle to a 'SP_DEVICE_INTERFACE_DATA structure for a detected device. 'Requires: 'the DeviceInfoSet returned in SetupDiGetClassDevs. 'the HidGuid returned in GetHidGuid. 'An index to specify a device. '************************************************************************** 'Begin with 0 and increment until no more devices are detected. MemberIndex = 0 Do 'The cbSize element of the MyDeviceInterfaceData structure must be set to 'the structure's size in bytes. The size is 28 bytes. MyDeviceInterfaceData.cbSize = LenB(MyDeviceInterfaceData) Result = SetupDiEnumDeviceInterfaces _ (DeviceInfoSet, _ 0, _ Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 48 HidGuid, _ MemberIndex, _ MyDeviceInterfaceData) Call DisplayResultOfAPICall("SetupDiEnumDeviceInterfaces") If Result = 0 Then LastDevice = True 'If a device exists, display the information returned. If Result 0 Then '" DeviceInfoSet for device #" & CStr(MemberIndex) & ": " '" cbSize = " & CStr(MyDeviceInterfaceData.cbSize) '" InterfaceClassGuid.Data1 = " & Hex$(MyDeviceInterfaceData.InterfaceClassGuid.Data1) '" InterfaceClassGuid.Data2 = " & Hex$(MyDeviceInterfaceData.InterfaceClassGuid.Data2) '" InterfaceClassGuid.Data3 = " & Hex$(MyDeviceInterfaceData.InterfaceClassGuid.Data3) '" Flags = " & Hex$(MyDeviceInterfaceData.Flags) '************************************************************************** 'SetupDiGetDeviceInterfaceDetail 'Returns: an SP_DEVICE_INTERFACE_DETAIL_DATA structure 'containing information about a device. 'To retrieve the information, call this function twice. 'The first time returns the size of the structure in Needed. 'The second time returns a pointer to the data in DeviceInfoSet. 'Requires: 'A DeviceInfoSet returned by SetupDiGetClassDevs and 'an SP_DEVICE_INTERFACE_DATA structure returned by SetupDiEnumDeviceInterfaces. '************************************************************************** MyDeviceInfoData.cbSize = Len(MyDeviceInfoData) Result = SetupDiGetDeviceInterfaceDetail _ (DeviceInfoSet, _ MyDeviceInterfaceData, _ 0, _ 0, _ Needed, _ 0) DetailData = Needed Call DisplayResultOfAPICall("SetupDiGetDeviceInterfaceDetail") '(OK to say too small) 'Required buffer size for the data = Needed Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 49 'Store the structure's size. MyDeviceInterfaceDetailData.cbSize = _ Len(MyDeviceInterfaceDetailData) 'Use a byte array to allocate memory for 'the MyDeviceInterfaceDetailData structure ReDim DetailDataBuffer(Needed) 'Store cbSize in the first four bytes of the array. Call RtlMoveMemory _ (DetailDataBuffer(0), _ MyDeviceInterfaceDetailData, _ 4) 'Call SetupDiGetDeviceInterfaceDetail again. 'This time, pass the address of the first element of DetailDataBuffer 'and the returned required buffer size in DetailData. Result = SetupDiGetDeviceInterfaceDetail _ (DeviceInfoSet, _ MyDeviceInterfaceData, _ VarPtr(DetailDataBuffer(0)), _ DetailData, _ Needed, _ 0) Call DisplayResultOfAPICall(" Result of second call: ") 'MyDeviceInterfaceDetailData.cbSize = CStr(MyDeviceInterfaceDetailData.cbSize) 'Convert the byte array to a string. DevicePathName = CStr(DetailDataBuffer()) 'Convert to Unicode. DevicePathName = StrConv(DevicePathName, vbUnicode) 'Strip cbSize (4 bytes) from the beginning. DevicePathName = Right$(DevicePathName, Len(DevicePathName) - 4) 'Device pathname = DevicePathName '************************************************************************** 'CreateFile Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 50 'Returns: a handle that enables reading and writing to the device. 'Requires: 'The DevicePathName returned by SetupDiGetDeviceInterfaceDetail. '************************************************************************** HIDHandle = CreateFile _ (DevicePathName, _ GENERIC_READ Or GENERIC_WRITE, _ (FILE_SHARE_READ Or FILE_SHARE_WRITE), _ Security, _ OPEN_EXISTING, _ 0&, _ 0) Call DisplayResultOfAPICall("CreateFile") 'Returned handle = HIDHandle 'Now we can find out if it's the device we're looking for. '************************************************************************** 'HidD_GetAttributes 'Requests information from the device. 'Requires: The handle returned by CreateFile. 'Returns: an HIDD_ATTRIBUTES structure containing 'the Vendor ID, Product ID, and Product Version Number. 'Use this information to determine if the detected device 'is the one we're looking for. '************************************************************************** 'Set the Size property to the number of bytes in the structure. DeviceAttributes.Size = LenB(DeviceAttributes) Result = HidD_GetAttributes _ (HIDHandle, _ DeviceAttributes) Call DisplayResultOfAPICall("HidD_GetAttributes") If Result 0 Then 'HIDD_ATTRIBUTES structure filled without error. Else 'Error in filling HIDD_ATTRIBUTES structure. End If 'Structure size = DeviceAttributes.Size 'Vendor ID = Hex$(DeviceAttributes.VendorID) 'Product ID = Hex$(DeviceAttributes.ProductID) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 51 'Version Number = Hex$(DeviceAttributes.VersionNumber) 'Find out if the device matches the one we're looking for. If (DeviceAttributes.VendorID = MyVendorID) And _ (DeviceAttributes.ProductID = MyProductID) Then 'It's the desired device. 'My device detected MyDeviceDetected = True Else MyDeviceDetected = False 'If it's not the one we want, close its handle. Result = CloseHandle _ (HIDHandle) DisplayResultOfAPICall ("CloseHandle") End If End If 'Keep looking until we find the device or there are no more left to examine. MemberIndex = MemberIndex + 1 Loop Until (LastDevice = True) Or (MyDeviceDetected = True) 'Free the memory reserved for the DeviceInfoSet returned by SetupDiGetClassDevs. Result = SetupDiDestroyDeviceInfoList _ (DeviceInfoSet) Call DisplayResultOfAPICall("DestroyDeviceInfoList") If MyDeviceDetected = True Then FindTheHid = True 'Learn the capabilities of the device Call GetDeviceCapabilities 'Get another handle for the overlapped ReadFiles. ReadHandle = CreateFile _ (DevicePathName, _ (GENERIC_READ Or GENERIC_WRITE), _ (FILE_SHARE_READ Or FILE_SHARE_WRITE), _ Security, _ OPEN_EXISTING, _ FILE_FLAG_OVERLAPPED, _ 0) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 52 Call DisplayResultOfAPICall("CreateFile, ReadHandle") 'Returned handle = ReadHandle Call PrepareForOverlappedTransfer Else 'Device not found End If End Function Private Function GetDataString _ (Address As Long, _ Bytes As Long) _ As String 'Retrieves a string of length Bytes from memory, beginning at Address. 'Adapted from Dan Appleman's "Win32 API Puzzle Book" Dim Offset As Integer Dim Result$ Dim ThisByte As Byte For Offset = 0 To Bytes - 1 Call RtlMoveMemory(ByVal VarPtr(ThisByte), ByVal Address + Offset, 1) If (ThisByte And &HF0) = 0 Then Result$ = Result$ & "0" End If Result$ = Result$ & Hex$(ThisByte) & " " Next Offset GetDataString = Result$ End Function Private Function GetErrorString _ (ByVal LastError As Long) _ As String 'Returns the error message for the last error. 'Adapted from Dan Appleman's "Win32 API Puzzle Book" Dim Bytes As Long Dim ErrorString As String ErrorString = String$(129, 0) Bytes = FormatMessage _ (FORMAT_MESSAGE_FROM_SYSTEM, _ 0&, _ LastError, _ 0, _ ErrorString$, _ 128, _ 0) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 53 'Subtract two characters from the message to strip the CR and LF. If Bytes > 2 Then GetErrorString = Left$(ErrorString, Bytes - 2) End If End Function Private Sub GetDeviceCapabilities() '************************************************************************** 'HidD_GetPreparsedData 'Returns: a pointer to a buffer containing information about the device's capabilities. 'Requires: A handle returned by CreateFile. 'There's no need to access the buffer directly, 'but HidP_GetCaps and other API functions require a pointer to the buffer. '************************************************************************** Dim ppData(29) As Byte Dim ppDataString As Variant 'Preparsed Data is a pointer to a routine-allocated buffer. Result = HidD_GetPreparsedData _ (HIDHandle, _ PreparsedData) Call DisplayResultOfAPICall("HidD_GetPreparsedData") 'Copy the data at PreparsedData into a byte array. Result = RtlMoveMemory _ (ppData(0), _ PreparsedData, _ 30) Call DisplayResultOfAPICall("RtlMoveMemory") ppDataString = ppData() 'Convert the data to Unicode. ppDataString = StrConv(ppDataString, vbUnicode) '************************************************************************** 'HidP_GetCaps 'Find out the device's capabilities. 'For standard devices such as joysticks, you can find out the specific 'capabilities of the device. 'For a custom device, the software will probably know what the device is capable of, Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 54 'so this call only verifies the information. 'Requires: The pointer to a buffer containing the information. 'The pointer is returned by HidD_GetPreparsedData. 'Returns: a Capabilites structure containing the information. '************************************************************************** Result = HidP_GetCaps _ (PreparsedData, _ Capabilities) Call DisplayResultOfAPICall("HidP_GetCaps") '" Last error: " & ErrorString '" Usage: " & Hex$(Capabilities.Usage) '" Usage Page: " & Hex$(Capabilities.UsagePage) '" Input Report Byte Length: " & Capabilities.InputReportByteLength '" Output Report Byte Length: " & Capabilities.OutputReportByteLength '" Feature Report Byte Length: " & Capabilities.FeatureReportByteLength '" Number of Link Collection Nodes: " & Capabilities.NumberLinkCollectionNodes '" Number of Input Button Caps: " & Capabilities.NumberInputButtonCaps '" Number of Input Value Caps: " & Capabilities.NumberInputValueCaps '" Number of Input Data Indices: " & Capabilities.NumberInputDataIndices '" Number of Output Button Caps: " & Capabilities.NumberOutputButtonCaps '" Number of Output Value Caps: " & Capabilities.NumberOutputValueCaps '" Number of Output Data Indices: " & Capabilities.NumberOutputDataIndices '" Number of Feature Button Caps: " & Capabilities.NumberFeatureButtonCaps '" Number of Feature Value Caps: " & Capabilities.NumberFeatureValueCaps '" Number of Feature Data Indices: " & Capabilities.NumberFeatureDataIndices '************************************************************************** 'HidP_GetValueCaps 'Returns a buffer containing an array of HidP_ValueCaps structures. 'Each structure defines the capabilities of one value. 'This application doesn't use this data. '************************************************************************** 'This is a guess. The byte array holds the structures. Dim ValueCaps(1023) As Byte Result = HidP_GetValueCaps _ (HidP_Input, _ ValueCaps(0), _ Capabilities.NumberInputValueCaps, _ PreparsedData) Call DisplayResultOfAPICall("HidP_GetValueCaps") Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 55 'lstResults.AddItem "ValueCaps= " & GetDataString((VarPtr(ValueCaps(0))), 180) 'To use this data, copy the byte array into an array of structures. 'Free the buffer reserved by HidD_GetPreparsedData Result = HidD_FreePreparsedData _ (PreparsedData) Call DisplayResultOfAPICall("HidD_FreePreparsedData") End Sub Private Sub PrepareForOverlappedTransfer() '************************************************************************** 'CreateEvent 'Creates an event object for the overlapped structure used with ReadFile. 'Requires a security attributes structure or null, 'Manual Reset = True (ResetEvent resets the manual reset object to nonsignaled), 'Initial state = True (signaled), 'and event object name (optional) 'Returns a handle to the event object. '************************************************************************** If EventObject = 0 Then EventObject = CreateEvent _ (Security, _ True, _ True, _ "") End If Call DisplayResultOfAPICall("CreateEvent") 'Set the members of the overlapped structure. HIDOverlapped.Offset = 0 HIDOverlapped.OffsetHigh = 0 HIDOverlapped.hEvent = EventObject End Sub Private Sub DisplayResultOfAPICall(FunctionName As String) 'Display the results of an API call. Dim ErrorString As String ErrorString = GetErrorString(Err.LastDllError) 'FunctionName Result = ErrorString End Sub Public Sub ReadAndWriteToDevice() Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 56 'Sends two bytes to the device and reads two bytes back. Dim Count As Integer 'If the device hasn't been detected or it timed out on a previous attempt 'to access it, look for the device. If MyDeviceDetected = False Then MyDeviceDetected = FindTheHid End If If MyDeviceDetected = True Then 'Write a report to the device Call WriteReport 'Read a report from the device. Call ReadReport Else End If End Sub Public Sub ReadReport() 'Read data from the device. Dim Count Dim NumberOfBytesRead As Long 'Allocate a buffer for the report. 'Byte 0 is the report ID. '************************************************************************** 'ReadFile 'Returns: the report in ReadBuffer. 'Requires: a device handle returned by CreateFile '(for overlapped I/O, CreateFile must be called with FILE_FLAG_OVERLAPPED), 'the Input report length in bytes returned by HidP_GetCaps, 'and an overlapped structure whose hEvent member is set to an event object. '************************************************************************** Dim ByteValue As String 'The ReadBuffer array begins at 0, so subtract 1 from the number of bytes. ReDim ReadBuffer(Capabilities.InputReportByteLength - 1) 'Do an overlapped ReadFile. 'The function returns immediately, even if the data hasn't been received yet. Result = ReadFile _ (ReadHandle, _ Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 57 ReadBuffer(0), _ CLng(Capabilities.InputReportByteLength), _ NumberOfBytesRead, _ HIDOverlapped) Call DisplayResultOfAPICall("ReadFile") 'Waiting for ReadFile bAlertable = True '************************************************************************** 'WaitForSingleObject 'Used with overlapped ReadFile. 'Returns when ReadFile has received the requested amount of data or on timeout. 'Requires an event object created with CreateEvent 'and a timeout value in milliseconds. '************************************************************************** Result = WaitForSingleObject _ (EventObject, _ 6000) Call DisplayResultOfAPICall("WaitForSingleObject") 'Find out if ReadFile completed or timeout. Select Case Result Case WAIT_OBJECT_0 'ReadFile has completed Case WAIT_TIMEOUT 'Timeout 'Cancel the operation '************************************************************* 'CancelIo 'Cancels the ReadFile 'Requires the device handle. 'Returns non-zero on success. '************************************************************* Result = CancelIo _ (ReadHandle) Call DisplayResultOfAPICall("CancelIo") 'The timeout may have been because the device was removed, 'so close any open handles and 'set MyDeviceDetected=False to cause the application to 'look for the device on the next attempt. CloseHandle (HIDHandle) Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 58 Call DisplayResultOfAPICall("CloseHandle (HIDHandle)") CloseHandle (ReadHandle) Call DisplayResultOfAPICall("CloseHandle (ReadHandle)") MyDeviceDetected = False Case Else 'Readfile undefined error MyDeviceDetected = False End Select 'Report ID = ReadBuffer(0) 'Report Data = ReadBuffer(Count) '************************************************************************** 'ResetEvent 'Sets the event object in the overlapped structure to non-signaled. 'Requires a handle to the event object. 'Returns non-zero on success. '************************************************************************** Call ResetEvent(EventObject) Call DisplayResultOfAPICall("ResetEvent") End Sub Public Sub WriteReport() 'Send data to the device. Dim Count As Integer Dim NumberOfBytesWritten As Long Dim SendBuffer() As Byte 'The SendBuffer array begins at 0, so subtract 1 from the number of bytes. ReDim SendBuffer(Capabilities.OutputReportByteLength - 1) '************************************************************************** 'WriteFile 'Sends a report to the device. 'Returns: success or failure. 'Requires: the handle returned by CreateFile and 'The output report byte length returned by HidP_GetCaps '************************************************************************** 'The first byte is the Report ID SendBuffer(0) = 0 'The next bytes are data Phụ lục A: Mã nguồn phần mềm trên máy vi tính Chủ nhiệm đề tài: Nguyễn Văn Sơn Phụ lục A - 59 For Count = 1 To Capabilities.OutputReportByteLength - 1 SendBuffer(Count) = OutputReportData(Count - 1) Next Count NumberOfBytesWritten = 0 Result = WriteFile _ (HIDHandle, _ SendBuffer(0), _ CLng(Capabilities.OutputReportByteLength), _ NumberOfBytesWritten, _ 0) Call DisplayResultOfAPICall("WriteFile") 'OutputReportByteLength = Capabilities.OutputReportByteLength 'NumberOfBytesWritten = NumberOfBytesWritten 'Report ID = SendBuffer(0) 'Report Data = SendBuffer(Count) End Sub