VB 6.0 code fro HID Communication and create Excel...
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Const SW_HIDE = 0
Private Const SW_MAXIMIZE = 3
Private Const SW_MINIMIZE = 6
Private Const SW_RESTORE = 9
Private Const SW_SHOW = 5
Private Const SW_SHOWDEFAULT = 10
Private Const SW_SHOWMAXIMIZED = 3
Private Const SW_SHOWMINIMIZED = 2
Private Const SW_SHOWMINNOACTIVE = 7
Private Const SW_SHOWNA = 8
Private Const SW_SHOWNOACTIVATE = 4
Private Const SW_SHOWNORMAL = 1
Private Const ERROR_FILE_NOT_FOUND = 2&
Private Const ERROR_PATH_NOT_FOUND = 3&
Private Const ERROR_BAD_FORMAT = 11&
Private Const SE_ERR_ACCESSDENIED = 5 ' access denied
Private Const SE_ERR_ASSOCINCOMPLETE = 27
Private Const SE_ERR_DDEBUSY = 30
Private Const SE_ERR_DDEFAIL = 29
Private Const SE_ERR_DDETIMEOUT = 28
Private Const SE_ERR_DLLNOTFOUND = 32
Private Const SE_ERR_NOASSOC = 31
Private Const SE_ERR_OOM = 8 ' out of memory
Private Const SE_ERR_SHARE = 26
Private Const STYLE_NORMAL = 11
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
Dim HIDHandle As Long
Dim HIDOverlapped As OVERLAPPED
Dim LastDevice As Boolean
Dim 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 OutputReportData(7) As Byte
Dim PreparsedData As Long
Dim ReadHandle As Long
Dim Result As Long
Dim Security As SECURITY_ATTRIBUTES
Dim Timeout As Boolean
Dim my_data As Byte
Dim qty As Integer
Dim txtline, h As String
Dim i, j, k As Integer
Dim objExcel As New Excel.Application
Dim data() As String
Dim oWB As Excel.Workbook
Dim oWS As Excel.Worksheet
Dim dtlog() As String
Dim log, time, time1, date2, date1 As String
Dim datalg() As String
Dim filename, interval, timediff As String
Dim volt1, volt2, cur1, cur2, bcur, freq1, freq2 As String
Dim vlt1value, vlt2value, cr1value, cr2value, bcrvalue, fr1value, fr2value As String
Dim datear() As String
Dim dtr As String
Dim sFile, sfile1 As String
Dim cell As Integer
Dim chrcur, dishrcur, gntime, nongntime, fault, file3, fault1 As String
Dim exdate, extime As String
Dim edate() As String
Dim etime() As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim bname, bname1, wkflname, sfile2 As String
'Set these to match the values in the device's firmware and INF file.
'0925h is Lakeview Research's vendor ID.
Const MyVendorID = &H1234
Const MyProductID = &H2
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.
If HidGuid.Data4(Count) >= &H10 Then
GUIDString = GUIDString & Hex$(HidGuid.Data4(Count)) & " "
Else
GUIDString = GUIDString & "0" & Hex$(HidGuid.Data4(Count)) & " "
End If
Next Count
'lstResults.AddItem " 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, _
HidGuid, _
MemberIndex, _
MyDeviceInterfaceData)
Call DisplayResultOfAPICall("SetupDiEnumDeviceInterfaces")
If Result = 0 Then LastDevice = True
'If a device exists, display the information returned.
If Result <> 0 Then
'******************************************************************************
'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")
'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: ")
'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)
'******************************************************************************
'CreateFile
'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")
'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
Else
End If
'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.
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)
Call DisplayResultOfAPICall("CreateFile, ReadHandle")
Call PrepareForOverlappedTransfer
Else
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)
'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 close_Click()
DataGrid1.Visible = False
DataGrid2.Visible = False
DataGrid3.Visible = False
fraSendAndReceive.Visible = False
Frame1.Visible = False
End Sub
Private Sub cmdContinuous_Click()
'Enables the user to select 1-time or continuous data transfers.
If cmdContinuous.Caption = "Start" Then
qty = 0
Text1.Text = ""
my_data = 0
Text2.Enabled = False
Command1.Enabled = False
Command2.Enabled = False
Label3.Caption = "0% completed"
'Change the command button to Cancel Continuous
cmdContinuous.Caption = "Stop"
'Enable the timer to read and write to the device once/second.
tmrContinuousDataCollect.Enabled = True
Call ReadAndWriteToDevice
Else
'Change the command button to Continuous
cmdContinuous.Caption = "Start"
Text2.Enabled = True
Command1.Enabled = True
Command2.Enabled = True
'Disable the timer that reads and writes to the device once/second.
tmrContinuousDataCollect.Enabled = False
End If
End Sub
Private Sub cmddata_Click()
filename = App.Path & "\Log Files\" & Text4.Text & ".log"
date1 = ""
date2 = ""
time = ""
time1 = ""
Text1.Enabled = True
Command3.Enabled = True
Dim fso As New FileSystemObject
If fso.FileExists(App.Path & "\Excel Files\" & Text5.Text & ".xls") = False Then
Workbooks.open filename:=sfile2
Set oWB = objExcel.Application.ActiveWorkbook
oWB.SaveAs (App.Path & "\Excel Files\" & Text5.Text & ".xls")
objExcel.Visible = True
Else
If MsgBox("Filename already exists.Do you want to repalce it?", vbYesNo + vbCritical, "Deletion") = vbYes Then
Workbooks.open filename:=sfile2
Set oWB = objExcel.Application.ActiveWorkbook
oWB.Save
objExcel.Visible = True
Else
MsgBox "Please Enter Another File Name"
objExcel.Visible = False
End If
End If
End Sub
Private Sub cmdOnce_Click()
Call ReadAndWriteToDevice
End Sub
Private Sub DisplayResultOfAPICall(FunctionName As String)
'Display the results of an API call.
Dim ErrorString As String
ErrorString = GetErrorString(Err.LastDllError)
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
End Sub
Private Sub Combo1_Click()
date1 = ""
date2 = ""
time = ""
time1 = ""
interval = Trim(Combo1.Text)
If interval = "All" Then
convertexcel
convertexcelcumdata
convertexcelfaultdata
End If
If interval = "5min" Then
convertexcel5min
convertexcelcumdata
convertexcelfaultdata
End If
If interval = "10 min" Then
convertexcel10min
convertexcelcumdata
convertexcelfaultdata
End If
Text1.Enabled = True
Command3.Enabled = True
Adodc1.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile2
Adodc1.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc1.Refresh
Adodc2.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile1
Adodc2.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc2.Refresh
Adodc3.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & file3
Adodc3.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc3.Refresh
Set DataGrid1.DataSource = Adodc1
DataGrid1.Refresh
Set DataGrid2.DataSource = Adodc2
DataGrid2.Refresh
Set DataGrid3.DataSource = Adodc3
DataGrid3.Refresh
DataGrid1.Columns("Date").Width = 1000 'test here
DataGrid1.Columns("Time").Width = 1000
DataGrid1.Columns("Voltage(ERRU1)").Width = 1500
DataGrid1.Columns("Voltage(ERRU2)").Width = 1500
DataGrid1.Columns("Current(ERRU1)").Width = 1500
DataGrid1.Columns("Current(ERRU2)").Width = 1500
DataGrid1.Columns("Charging Current").Width = 1500
DataGrid1.Columns("Discharging Current").Width = 1700
DataGrid1.Columns("Alternator RPM").Width = 1500
DataGrid2.Columns("Date").Width = 800 'test here
DataGrid2.Columns("Time").Width = 800
DataGrid2.Columns("Charging Current").Width = 1400
DataGrid2.Columns("Discharging Current").Width = 1700
DataGrid2.Columns("Generation Time").Width = 1400
DataGrid3.Columns("Date").Width = 800 'test here
DataGrid3.Columns("Time").Width = 800
DataGrid3.Columns("Fault").Width = 3100
DataGrid1.Visible = True
End Sub
Private Sub Command1_Click()
Dim fso As New FileSystemObject
If fso.FileExists(App.Path & "\Log Files\" & Text2.Text & ".log") = False Then
Open App.Path & "\Log Files\" & Text2.Text & ".log" For Output As #1
Print #1, Text1.Text
Close #1
MsgBox "File saved successfully!"
Else
If MsgBox("Filename already exists.Do you want to repalce it?", vbYesNo + vbCritical, "Deletion") = vbYes Then
Open App.Path & "\Log Files\" & Text2.Text & ".log" For Output As #1
Print #1, Text1.Text
Close #1
MsgBox "File saved successfully!"
Else
MsgBox "Please Enter Another File Name"
End If
End If
End Sub
Private Sub Command2_Click()
Call Startup
Call FindTheHid
If MyDeviceDetected = True Then
Label4.ForeColor = &HFF00&
Label4.Caption = " Device is connected on port"
cmdContinuous.Enabled = True
Else
Label4.ForeColor = &HFF
Label4.Caption = " Device is not connected on port"
cmdContinuous.Enabled = False
End If
End Sub
Private Sub Command3_Click()
Dim fso As New FileSystemObject
If fso.FileExists(App.Path & "\Log Files\" & Text4.Text & ".log") = False Then
Open App.Path & "\Log Files\" & Text4.Text & ".log" For Output As #1
Print #1, Text1.Text
Close #1
MsgBox "File saved successfully!"
Else
If MsgBox("Filename already exists.Do you want to repalce it?", vbYesNo + vbCritical, "Deletion") = vbYes Then
Open App.Path & "\Log Files\" & Text4.Text & ".log" For Output As #1
Print #1, Text1.Text
Close #1
MsgBox "File saved successfully!"
Else
MsgBox "Please Enter Another File Name"
End If
End If
filename = App.Path & "\Log Files\" & Text4.Text & ".log"
convertexcel
convertexcelcumdata
Adodc1.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile2
Adodc1.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc1.Refresh
Adodc2.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile1
Adodc2.RecordSource = "SELECT * FROM [Sheet2$]"
Adodc2.Refresh
DataGrid1.Visible = True
DataGrid2.Visible = True
DataGrid3.Visible = True
Frame1.Visible = True
Label6.Visible = True
Combo1.Visible = True
Label1.Visible = True
Label8.Visible = True
Text5.Visible = True
Label9.Visible = True
cmddata.Visible = True
fraSendAndReceive.Visible = False
Label3.Visible = False
objExcel.Application.Quit
Text5.Text = "Default"
Label8.Caption = "Your Current FileName:"
End Sub
Private Sub Command4_Click()
Set oWB = objExcel.Workbooks.open(App.Path & "\Excel Files\" & Text5.Text & ".xls")
objExcel.Visible = True
End Sub
Private Sub download_Click()
fraSendAndReceive.Visible = True
Label3.Visible = True
DataGrid1.Visible = False
Frame1.Visible = False
DataGrid2.Visible = False
DataGrid3.Visible = False
DataGrid4.Visible = False
Command3.Enabled = False
End Sub
Private Sub exit_Click()
End
End Sub
Private Sub export_Click()
filename = App.Path & "\Log Files\" & Text4.Text & ".log"
convertexcel
convertexcelcumdata
Adodc1.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile2
Adodc1.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc1.Refresh
Adodc2.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile1
Adodc2.RecordSource = "SELECT * FROM [Sheet2$]"
Adodc2.Refresh
DataGrid1.Visible = True
DataGrid2.Visible = True
DataGrid3.Visible = True
Frame1.Visible = True
Label6.Visible = True
Combo1.Visible = True
Label1.Visible = True
Label8.Visible = True
Text5.Visible = True
Label9.Visible = True
cmddata.Visible = True
fraSendAndReceive.Visible = False
Label3.Visible = False
objExcel.Application.Quit
Text5.Text = "Default"
Label8.Caption = "Your Current FileName:"
End Sub
Private Sub Form_Load()
frmMain.Show
my_data = 0
tmrDelay.Enabled = False
Call Startup
Call FindTheHid
If MyDeviceDetected = True Then
Label4.ForeColor = &HFF00&
Label4.Caption = " Device is connected on port"
cmdContinuous.Enabled = True
Else
Label4.ForeColor = &HFF
Label4.Caption = " Device is not connected on port"
cmdContinuous.Enabled = False
End If
On Error Resume Next
MkDir App.Path & "\Log Files"
On Error Resume Next
MkDir App.Path & "\Excel Files"
On Error Resume Next
MkDir App.Path & "\Temp"
objExcel.DisplayAlerts = False
Dim oFs As New FileSystemObject
Dim oFolder As Folder
Dim oFile As file
DeleteAllFiles App.Path & "\Temp"
End Sub
Public Function DeleteAllFiles(ByVal FolderSpec As String) As Boolean
Dim oFs As New FileSystemObject
Dim oFolder As Folder
Dim oFile As file
If oFs.FolderExists(FolderSpec) Then
Set oFolder = oFs.GetFolder(FolderSpec)
On Error Resume Next
For Each oFile In oFolder.Files
oFile.Delete True 'setting force to true
'deletes read-only file
Next
DeleteAllFiles = oFolder.Files.Count = 0
End If
End Function
Private Sub Form_Unload(Cancel As Integer)
Call Shutdown
End Sub
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,
'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")
'******************************************************************************
'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")
'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 InitializeDisplay()
Dim Count As Integer
Dim ByteValue As String
'Create a dropdown list box for each byte to send.
For Count = 0 To 255
If Len(Hex$(Count)) < 2 Then
ByteValue = "0" & Hex$(Count)
Else
ByteValue = Hex$(Count)
End If
frmMain.cboByte0.AddItem ByteValue, Count
Next Count
For Count = 0 To 255
If Len(Hex$(Count)) < 2 Then
ByteValue = "0" & Hex$(Count)
Else
ByteValue = Hex$(Count)
End If
frmMain.cboByte1.AddItem ByteValue, Count
Next Count
'Select a default item for each box
frmMain.cboByte0.ListIndex = 0
frmMain.cboByte1.ListIndex = 128
'Check the autoincrement box to increment the values each time a report is sent.
chkAutoincrement.Value = 1
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 ReadAndWriteToDevice()
'Sends two bytes to the device and reads two bytes back.
Dim Count As Integer
'Report Header
'Some data to send
'(if not using the combo boxes):
'OutputReportData(0) = &H12
'OutputReportData(1) = &H34
'OutputReportData(2) = &HF0
'OutputReportData(3) = &HF1
'OutputReportData(4) = &HF2
'OutputReportData(5) = &HF3
'OutputReportData(6) = &HF4
'OutputReportData(7) = &HF5
'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
'Get the bytes to send from the combo boxes.
'Increment the values if the autoincrement check box is selected.
If chkAutoincrement.Value = 1 Then
If cboByte0.ListIndex < 255 Then
cboByte0.ListIndex = cboByte0.ListIndex + 1
Else
cboByte0.ListIndex = 0
End If
If cboByte1.ListIndex < 255 Then
cboByte1.ListIndex = cboByte1.ListIndex + 1
Else
cboByte1.ListIndex = 0
End If
End If
OutputReportData(0) = cboByte0.ListIndex
'OutputReportData(1) = cboByte1.ListIndex
'Write a report to the device
Call WriteReport
'Read a report from the device.
Call ReadReport
Else
End If
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
'If the list box has more than 300 items, trim the contents.
If lstResults.ListCount > 300 Then
For Count = 1 To 100
lstResults.RemoveItem (Count)
Next Count
End If
End Sub
Private Sub ReadReport()
'Read data from the device.
Dim Count
Dim data_count
Dim NumberOfBytesRead As Long
'Allocate a buffer for the report.
'Byte 0 is the report ID.
Dim ReadBuffer() As Byte
Dim UBoundReadBuffer As Integer
'******************************************************************************
'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)
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
'Do an overlapped ReadFile.
'The function returns immediately, even if the data hasn't been received yet.
data_count = 0
Top:
Result = ReadFile _
(ReadHandle, _
ReadBuffer(0), _
CLng(Capabilities.InputReportByteLength), _
NumberOfBytesRead, _
HIDOverlapped)
Call DisplayResultOfAPICall("ReadFile")
'lstResults.AddItem "waiting for ReadFile"
'Scroll to the bottom of the list box.
lstResults.ListIndex = lstResults.ListCount - 1
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)
Call DisplayResultOfAPICall("CloseHandle (HIDHandle)")
CloseHandle (ReadHandle)
Call DisplayResultOfAPICall("CloseHandle (ReadHandle)")
MyDeviceDetected = False
Case Else
MyDeviceDetected = False
End Select
If data_count < 511 Then
txtBytesReceived.Text = ""
For Count = 1 To UBound(ReadBuffer)
'Add a leading 0 to values 0 - Fh.
If Len(Hex$(ReadBuffer(Count))) < 2 Then
ByteValue = "0" & Hex$(ReadBuffer(Count))
Else
ByteValue = Hex$(ReadBuffer(Count))
End If
Text1.Text = Text1.Text & ByteValue & " "
data_count = data_count + 1
'Display the received bytes in the text box.
txtBytesReceived.SelStart = Len(txtBytesReceived.Text)
txtBytesReceived.SelText = ByteValue & vbCrLf
Next Count
GoTo Top
End If
'******************************************************************************
'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
Private Sub Shutdown()
'Actions that must execute when the program ends.
'Close the open handles to the device.
Result = CloseHandle _
(HIDHandle)
Call DisplayResultOfAPICall("CloseHandle (HIDHandle)")
Result = CloseHandle _
(ReadHandle)
Call DisplayResultOfAPICall("CloseHandle (ReadHandle)")
End Sub
Private Sub Startup()
Call InitializeDisplay
tmrContinuousDataCollect.Enabled = False
tmrContinuousDataCollect.interval = 1000
End Sub
Private Sub new_Click()
fraSendAndReceive.Visible = True
Label3.Visible = True
'Text1.Visible = True
End Sub
Private Sub open_Click()
CommonDialog1.DialogTitle = "Open File"
CommonDialog1.Filter = "Log Documents (*.log)|*.log|Text Documents (*.txt)|*.txt|Excel Spreadsheets (*.xls)|*.xls"
CommonDialog1.FilterIndex = 1
CommonDialog1.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
CommonDialog1.ShowOpen
filename = CommonDialog1.filename
Dim fl As String
fl = CommonDialog1.FileTitle
If filename = "" Then
Else
convertexcel
convertexcelcumdata
convertexcelfaultdata
sFile = App.Path & "\Excel Files\Default.xls"
Adodc1.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile2
Adodc1.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc1.Refresh
Adodc2.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & sfile1
Adodc2.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc2.Refresh
Adodc3.ConnectionString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & file3
Adodc3.RecordSource = "SELECT * FROM [Sheet1$]"
Adodc3.Refresh
Set DataGrid1.DataSource = Adodc1
DataGrid1.Refresh
Set DataGrid2.DataSource = Adodc2
DataGrid2.Refresh
Set DataGrid3.DataSource = Adodc3
DataGrid3.Refresh
DataGrid1.Columns("Date").Width = 1000 'test here
DataGrid1.Columns("Time").Width = 1000
DataGrid1.Columns("Voltage(ERRU1)").Width = 1500
DataGrid1.Columns("Voltage(ERRU2)").Width = 1500
DataGrid1.Columns("Current(ERRU1)").Width = 1500
DataGrid1.Columns("Current(ERRU2)").Width = 1500
DataGrid1.Columns("Charging Current").Width = 1500
DataGrid1.Columns("Discharging Current").Width = 1700
DataGrid1.Columns("Alternator RPM").Width = 1500
DataGrid2.Columns("Date").Width = 800 'test here
DataGrid2.Columns("Time").Width = 800
DataGrid2.Columns("Charging Current").Width = 1400
DataGrid2.Columns("Discharging Current").Width = 1700
DataGrid2.Columns("Generation Time").Width = 1400
DataGrid3.Columns("Date").Width = 800 'test here
DataGrid3.Columns("Time").Width = 800
DataGrid3.Columns("Fault").Width = 3100
If interval = "5min" Then
DataGrid4.Visible = True
DataGrid1.Visible = False
End If
DataGrid1.Visible = True
DataGrid2.Visible = True
DataGrid3.Visible = True
Frame1.Visible = True
Label6.Visible = True
Combo1.Visible = True
Label1.Visible = True
Label8.Visible = True
Text5.Visible = True
Label9.Visible = True
cmddata.Visible = True
fraSendAndReceive.Visible = False
Label3.Visible = False
objExcel.Application.Quit
Text5.Text = "Default"
Label8.Caption = "Your Current FileName:"
End If
End Sub
Private Sub tmrContinuousDataCollect_Timer()
If my_data < Val(Text3.Text) * 2.54 Then
Call ReadAndWriteToDevice
Else
tmrContinuousDataCollect.Enabled = False
End If
qty = Round((my_data / 2.54) * (100 / Val(Text3.Text)), 0)
If qty > 98 Then
cmdContinuous.Caption = "Start"
Command1.Enabled = True
Command2.Enabled = True
Text2.Enabled = True
End If
If qty > 100 Then
qty = 100
End If
Label3.Caption = qty & "% Completed"
If Label3.Caption = "100% Completed" Then
Label6.Visible = True
Combo1.Visible = True
Label1.Visible = True
cmddata.Visible = True
Command3.Enabled = True
Text4.Enabled = True
End If
End Sub
Private Sub tmrDelay_Timer()
Timeout = True
tmrDelay.Enabled = False
End Sub
Private Sub WriteReport()
'Send data to the device.
Dim Count As Integer
Dim NumberOfBytesRead As Long
Dim NumberOfBytesToSend As Long
Dim NumberOfBytesWritten As Long
Dim ReadBuffer() As Byte
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
SendBuffer(1) = my_data
NumberOfBytesWritten = 0
Result = WriteFile _
(HIDHandle, _
SendBuffer(0), _
CLng(Capabilities.OutputReportByteLength), _
NumberOfBytesWritten, _
0)
Call DisplayResultOfAPICall("WriteFile")
my_data = my_data + 1
For Count = 1 To UBound(SendBuffer)
lstResults.AddItem " " & Hex$(SendBuffer(Count))
Next Count
End Sub
Function convertexcel()
Dim line As String
Dim Count As String
h = 2
Dim TextLine As String
Open filename For Input Shared As #1
Do While Not EOF(1) '// Loop until end of file.
Line Input #1, TextLine '// Read line into variable.
' use the TextLine herer...
line = TextLine
Loop
Close #1
'create excel file
Set oWB = objExcel.Workbooks.Add
Set oWS = oWB.Worksheets("Sheet1")
bname = oWB.Name
oWS.Cells.Columns.AutoFit
oWS.Cells.WrapText = False
oWS.Range("A1").Value = "Date"
oWS.Range("B1").Value = "Time"
oWS.Range("C1").Value = "Voltage(ERRU1)"
oWS.Range("D1").Value = "Current(ERRU1)"
oWS.Range("E1").Value = "Voltage(ERRU2)"
oWS.Range("F1").Value = "Current(ERRU2)"
oWS.Range("G1").Value = "Charging Current"
oWS.Range("H1").Value = "Discharging Current"
oWS.Range("I1").Value = "Alternator RPM"
dtlog = Split(line, "FE FF")
For k = 0 To UBound(dtlog) - 1
log = dtlog(k)
If k = 0 Then
Dim dlog() As String
dlog = Split(log, "FF")
log = dlog(1)
End If
datalg = Split(log, " ")
Count = UBound(datalg)
If Count <= 21 Then
If Count >= 18 Then
time = datalg(3) & ":" & datalg(2)
date1 = datalg(4) & "/" & datalg(5) & "/" & datalg(6)
If exdate = "" Then
exdate = date1
Else
exdate = exdate & "," & date1
End If
If extime = "" Then
extime = time
Else
extime = extime & "," & time
End If
If dtr = "" Then
dtr = date1
Else
dtr = dtr + "," + date1
End If
oWS.Range("A" & h).Value = " " & Trim$(Trim$(datalg(4)) & "/" & Trim$(datalg(5)) & "/" & Trim$(datalg(6)))
oWS.Range("B" & h).Value = datalg(3) & ":" & datalg(2)
volt1 = HextoDec(datalg(7) & datalg(8))
vlt1value = Round((volt1 - 511) * 0.495, 2)
If vlt1value < 0 Then
vlt1value = 0
End If
cur1 = HextoDec(datalg(11) & datalg(12))
cr1value = Round((cur1 - 511) * 2.44, 2)
If cr1value < 0 Then
cr1value = 0
End If
volt2 = HextoDec(datalg(9) & datalg(10))
vlt2value = Round((volt2 - 511) * 0.495, 2)
If vlt2value < 0 Then
vlt2value = 0
End If
cur2 = HextoDec(datalg(13) & datalg(14))
cr2value = Round((cur2 - 511) * 2.44, 2)
If cr2value < 0 Then
cr2value = 0
End If
bcur = HextoDec(datalg(15) & datalg(16))
bcrvalue = Round((bcur - 511) * 2.44, 2)
freq1 = HextoDec(datalg(17) & datalg(18))
fr1value = Round((freq1 * 0.79) * 7.5)
If bcrvalue < 0 Then
bcrvalue = 0
End If
If fr1value < 0 Then
fr1value = 0
End If
oWS.Range("C" & h).Value = vlt1value
oWS.Range("D" & h).Value = cr1value
oWS.Range("E" & h).Value = vlt1value
oWS.Range("F" & h).Value = cr2value
oWS.Range("G" & h).Value = bcrvalue
oWS.Range("I" & h).Value = fr1value
h = h + 1
End If
End If
Count = ""
Next k
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xls": FileFormatNum = 56
End If
TempFilePath = App.Path
TempFileName = "\Temp\All" & Hour(Now) & "-" & Minute(Now) & "-" & Second(Now)
oWB.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
oWB.close SaveChanges:=True
sfile2 = TempFilePath & TempFileName & FileExtStr
objExcel.Application.Quit
End Function
Function convertexcel5min()
DataGrid1.Visible = False
Dim line As String
Dim Count As String
h = 2
Dim TextLine As String
Open filename For Input Shared As #1
Do While Not EOF(1) '// Loop until end of file.
Line Input #1, TextLine '// Read line into variable.
' use the TextLine herer...
line = TextLine
Loop
Close #1
'create excel file
Dim fso As New FileSystemObject
Set oWB = objExcel.Workbooks.Add
Set oWS = oWB.Worksheets("Sheet1")
bname = oWB.Name
oWS.Cells.Columns.AutoFit
oWS.Cells.WrapText = False
bname = oWB.Name
oWS.Range("A1").Value = "Date"
oWS.Range("B1").Value = "Time"
oWS.Range("C1").Value = "Voltage(ERRU1)"
oWS.Range("D1").Value = "Current(ERRU1)"
oWS.Range("E1").Value = "Voltage(ERRU2)"
oWS.Range("F1").Value = "Current(ERRU2)"
oWS.Range("G1").Value = "Charging Current"
oWS.Range("H1").Value = "Discharging Current"
oWS.Range("I1").Value = "Alternator RPM"
dtlog = Split(line, "FE FF")
For k = 0 To UBound(dtlog) - 1
log = dtlog(k)
If k = 0 Then
Dim dlog() As String
dlog = Split(log, "FF")
log = dlog(1)
End If
datalg = Split(log, " ")
Count = UBound(datalg)
If Count <= 21 Then
If Count >= 18 Then
time = datalg(4) & "/" & datalg(5) & "/" & datalg(6) & " " & datalg(3) & ":" & datalg(2)
date1 = datalg(4) & "/" & datalg(5) & "/" & datalg(6)
If date1 >= date2 Then
date2 = date1
If time >= time1 Then
time1 = Format(DateAdd("n", 5, time), "dd/MM/yy hh:mm")
time = ""
date1 = ""
oWS.Range("A" & h).Value = " " & datalg(4) & "/" & datalg(5) & "/" & datalg(6)
oWS.Range("B" & h).Value = datalg(3) & ":" & datalg(2)
volt1 = HextoDec(datalg(7) & datalg(8))
vlt1value = Round((volt1 - 511) * 0.495, 2)
If vlt1value < 0 Then
vlt1value = 0
End If
cur1 = HextoDec(datalg(11) & datalg(12))
cr1value = (cur1 - 511) * 2.44
If cr1value < 0 Then
cr1value = 0
End If
volt2 = HextoDec(datalg(9) & datalg(10))
vlt2value = Round((volt2 - 511) * 0.495, 2)
If vlt2value < 0 Then
vlt2value = 0
End If
cur2 = HextoDec(datalg(13) & datalg(14))
cr2value = (cur2 - 511) * 2.44
If cr2value < 0 Then
cr2value = 0
End If
bcur = HextoDec(datalg(15) & datalg(16))
bcrvalue = Round((bcur - 511) * 2.44, 2)
freq1 = HextoDec(datalg(17) & datalg(18))
fr1value = Round((freq1 * 0.79) * 7.5)
If bcrvalue < 0 Then
bcrvalue = 0
End If
If fr1value < 0 Then
fr1value = 0
End If
oWS.Range("C" & h).Value = vlt1value
oWS.Range("D" & h).Value = cr1value
oWS.Range("E" & h).Value = vlt2value
oWS.Range("F" & h).Value = cr2value
oWS.Range("G" & h).Value = bcrvalue
oWS.Range("I" & h).Value = fr1value
h = h + 1
End If
End If
End If
End If
Count = ""
Next k
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xls": FileFormatNum = 56
End If
TempFilePath = App.Path
TempFileName = "\Temp\5min" & Hour(Now) & "-" & Minute(Now) & "-" & Second(Now)
oWB.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
oWB.close SaveChanges:=True
sfile2 = TempFilePath & TempFileName & FileExtStr
objExcel.Application.Quit
End Function
Function convertexcel10min()
Dim line As String
Dim Count As String
h = 2
Dim TextLine As String
'Open App.Path & "\download.log" For Input Access Read As #nHandle
Open filename For Input Shared As #1
Do While Not EOF(1) '// Loop until end of file.
Line Input #1, TextLine '// Read line into variable.
' use the TextLine herer...
line = TextLine
Loop
Close #1
'create excel file
Dim fso As New FileSystemObject
If fso.FileExists(App.Path & "\Excel Files\Default.xls") = False Then
Set oWB = objExcel.Workbooks.Add
Set oWS = oWB.Worksheets("Sheet1")
bname = oWB.Name
Else
Workbooks.open filename:=sfile2
Set oWB = objExcel.Application.ActiveWorkbook
Set oWS = oWB.Worksheets("Sheet1")
bname = oWB.Name
End If
bname = oWB.Name
oWS.Cells.Columns.AutoFit
oWS.Cells.WrapText = False
oWS.Range("A1").Value = "Date"
oWS.Range("B1").Value = "Time"
oWS.Range("C1").Value = "Voltage(ERRU1)"
oWS.Range("D1").Value = "Current(ERRU1)"
oWS.Range("E1").Value = "Voltage(ERRU2)"
oWS.Range("F1").Value = "Current(ERRU2)"
oWS.Range("G1").Value = "Charging Current"
oWS.Range("H1").Value = "Discharging Current"
oWS.Range("I1").Value = "Alternator RPM"
dtlog = Split(line, "FE FF")
For k = 0 To UBound(dtlog) - 1
log = dtlog(k)
If k = 0 Then
Dim dlog() As String
dlog = Split(log, "FF")
log = dlog(1)
End If
datalg = Split(log, " ")
Count = UBound(datalg)
If Count <= 21 Then
If Count >= 18 Then
time = datalg(4) & "/" & datalg(5) & "/" & datalg(6) & " " & datalg(3) & ":" & datalg(2)
date1 = datalg(4) & "/" & datalg(5) & "/" & datalg(6)
If date1 >= date2 Then
date2 = date1
If time >= time1 Then
time1 = Format(DateAdd("n", 10, time), "dd/MM/yy hh:mm")
time = ""
date1 = ""
oWS.Range("A" & h).Value = " " & datalg(4) & "/" & datalg(5) & "/" & datalg(6)
oWS.Range("B" & h).Value = datalg(3) & ":" & datalg(2)
volt1 = HextoDec(datalg(7) & datalg(8))
vlt1value = Round((volt1 - 511) * 0.495, 2)
If vlt1value < 0 Then
vlt1value = 0
End If
cur1 = HextoDec(datalg(11) & datalg(12))
cr1value = (cur1 - 511) * 2.44
If cr1value < 0 Then
cr1value = 0
End If
volt2 = HextoDec(datalg(9) & datalg(10))
vlt2value = Round((volt2 - 511) * 0.495, 2)
If vlt2value < 0 Then
vlt2value = 0
End If
cur2 = HextoDec(datalg(13) & datalg(14))
cr2value = (cur2 - 511) * 2.44
If cr2value < 0 Then
cr2value = 0
End If
bcur = HextoDec(datalg(15) & datalg(16))
bcrvalue = Round((bcur - 511) * 2.44, 2)
freq1 = HextoDec(datalg(17) & datalg(18))
fr1value = Round((freq1 * 0.79) * 7.5)
If bcrvalue < 0 Then
bcrvalue = 0
End If
If fr1value < 0 Then
fr1value = 0
End If
oWS.Range("C" & h).Value = vlt1value
oWS.Range("D" & h).Value = cr1value
oWS.Range("E" & h).Value = vlt2value
oWS.Range("F" & h).Value = cr2value
oWS.Range("G" & h).Value = bcrvalue
oWS.Range("I" & h).Value = fr1value
h = h + 1
End If
End If
End If
End If
Count = ""
Next k
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xls": FileFormatNum = 56
End If
TempFilePath = App.Path
TempFileName = "\Temp\10min" & Hour(Now) & "-" & Minute(Now) & "-" & Second(Now)
oWB.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
oWB.close SaveChanges:=True
sfile2 = TempFilePath & TempFileName & FileExtStr
objExcel.Application.Quit
End Function
Public Function HextoDec(HexNum As String) As Long
Dim lngOut As Long
Dim i As Integer
Dim c As Integer
For i = 1 To Len(HexNum)
c = Asc(UCase(Mid(HexNum, i, 1)))
Select Case c
Case 65 To 70
lngOut = lngOut + ((c - 55) * 16 ^ (Len(HexNum) - i))
Case 48 To 57
lngOut = lngOut + ((c - 48) * 16 ^ (Len(HexNum) - i))
Case Else
End Select
Next i
HextoDec = lngOut
End Function
Function convertexcelcumdata()
'nHandle = FreeFile
Dim line As String
Dim Count As String
h = 2
Dim TextLine As String
'Open App.Path & "\download.log" For Input Access Read As #nHandle
'Open filename For Input Access Read As #1
Open filename For Input Shared As #1
Do While Not EOF(1) '// Loop until end of file.
Line Input #1, TextLine '// Read line into variable.
' use the TextLine herer...
line = TextLine
Loop
Close #1
Set oWB = objExcel.Workbooks.Add
Set oWS = oWB.Worksheets("Sheet1")
bname1 = oWB.Name
oWS.Cells.Columns.AutoFit
oWS.Cells.WrapText = False
oWS.Range("A1").Value = "Date"
oWS.Range("B1").Value = "Time"
oWS.Range("C1").Value = "Charging Current"
oWS.Range("D1").Value = "Discharging Current"
oWS.Range("E1").Value = "Generation Time"
oWS.Range("F1").Value = "Non Generation Time"
dtlog = Split(line, "FE FF")
For k = 0 To UBound(dtlog) - 1
log = dtlog(k)
If k = 0 Then
Dim dlog() As String
dlog = Split(log, "FF")
log = dlog(1)
End If
Dim vl As String
vl = Mid(log, 2, 2)
If vl = "02" Then
datalg = Split(log, " ")
Dim dt As String
Count = UBound(datalg)
If Count <= 21 Then
If Count >= 11 Then
Dim dt1 As String
edate = Split(exdate, ",")
dt1 = edate(1)
Dim tm As String
etime = Split(extime, ",")
tm = etime(1)
chrcur = HextoDec(datalg(2) & datalg(3) & datalg(4))
dishrcur = HextoDec(datalg(5) & datalg(6) & datalg(7))
gntime = HextoDec(datalg(8) & datalg(9))
nongntime = HextoDec(datalg(10) & datalg(11))
oWS.Range("A" & h).Value = dt1
oWS.Range("B" & h).Value = tm
oWS.Range("C" & h).Value = chrcur
oWS.Range("D" & h).Value = dishrcur
oWS.Range("E" & h).Value = gntime
oWS.Range("F" & h).Value = nongntime
h = h + 1
End If
End If
End If
Count = ""
Next k
oWB.Save
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xls": FileFormatNum = 56
End If
TempFilePath = App.Path
TempFileName = "\Temp\cum" & Hour(Now) & "-" & Minute(Now) & "-" & Second(Now)
oWB.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
oWB.close SaveChanges:=True
sfile1 = TempFilePath & TempFileName & FileExtStr
objExcel.Application.Quit
End Function
Function convertexcelfaultdata()
Dim line As String
Dim Count As String
h = 2
Dim TextLine As String
Open filename For Input Shared As #1
Do While Not EOF(1) '// Loop until end of file.
Line Input #1, TextLine '// Read line into variable.
' use the TextLine herer...
line = TextLine
Loop
Close #1
'create excel file
Set oWB = objExcel.Workbooks.Add
Set oWS = oWB.Worksheets("Sheet1")
bname1 = oWB.Name
oWS.Cells.Columns.AutoFit
oWS.Cells.WrapText = False
oWS.Range("A1").Value = "Date"
oWS.Range("B1").Value = "Time"
oWS.Range("C1").Value = "Fault"
dtlog = Split(line, "FE FF")
For k = 0 To UBound(dtlog) - 1
log = dtlog(k)
If k = 0 Then
Dim dlog() As String
dlog = Split(log, "FF")
log = dlog(1)
End If
Dim vl As String
vl = Mid(log, 2, 2)
If vl = "04" Then
datalg = Split(log, " ")
Count = UBound(datalg)
If Count <= 21 Then
If Count >= 8 Then
fault = datalg(7)
If fault = "E1" Then
fault1 = "Alternator Failure"
End If
If fault = "E2" Then
fault1 = "Power Voltage"
End If
If fault = "E3" Then
fault1 = "UVC Failure"
End If
If fault = "E4" Then
fault1 = "Power Circuit Failure"
End If
If fault = "E5" Then
fault1 = "OVC Trip to OVC Reset"
End If
If fault = "E6" Then
fault1 = "Overload"
End If
If fault = "E7" Then
fault1 = "Short Circuit"
End If
If fault = "E8" Then
fault1 = "Battery Low Voltage"
End If
If fault = "E9" Then
fault1 = "Phase Failure"
End If
If fault = "EA" Then
fault1 = "Shaft Failure"
End If
oWS.Range("A" & h).Value = " " & datalg(4) & "/" & datalg(5) & "/" & datalg(6)
oWS.Range("B" & h).Value = datalg(3) & ":" & datalg(2)
oWS.Range("C" & h).Value = fault1
h = h + 1
End If
End If
End If
Count = ""
Next k
oWB.Save
If Val(Application.Version) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
FileExtStr = ".xls": FileFormatNum = 56
End If
TempFilePath = App.Path
TempFileName = "\Temp\fault" & Hour(Now) & "-" & Minute(Now) & "-" & Second(Now)
oWB.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
oWB.close SaveChanges:=True
file3 = TempFilePath & TempFileName & FileExtStr
objExcel.Application.Quit
End Function
Category:
