Creating a Toolbar is not trivial. There are several steps to follow and some need to be performed in the right order. This HowTo's real usefulness is in its listing of the steps:
Press Ctrl-T to open the Tools dialog. Select Microsoft Windows Common Controls.
Add an ImageList control to the form.
Left-click on the ImageList and select the Properties command.
Click on the Images tab.
Click the Insert Picture button and find your button bitmaps. You can probably find the standard Windows 95 bitmaps in the Common/Graphics section of your computer's programming area. On my computer this is:
C:\Program Files\Microsoft Visual Studio\Common\Graphics\Bitmaps\TlBr_W95
When you have added all your button images, click the Ok button.
Add a Toolbar control to your form.
Left-click on the Toolbar and select the Properties command.
On the General tab, find the ImageList field (3rd from the top in my version). Select the ImageList control from step 2.
Click the Buttons tab.
Click Insert Button to add a button to the Toolbar. Fill in appropriate fields:
Caption appears on the button. For a normal button, leave this blank.
Key is passed to the Toolbar's event handler. This is one way you can tell which button was clicked. Enter a short key word here.
ToolTipText is displayed when the user lets the mouse rest over the button. Enter something short but helpful here. Remember that the user sees only a small picture if Caption is blank, so even very short text is useful here. For example, "Cut" is a good tip for the cut button.
Image is the index of the button's picture in the ImageList control. 0 means no image. 1 is the first image in the ImageList.
Experiment with the other button properties to see how they work.
When you have added all the buttons, click Ok.
Double click on the Toolbar to open the code editor in its ButtonClick event handler. This routine takes as a parameter a Button object representing the button pressed. Look at Button.Key to see which button was pressed.
Note that if you modify the ImageList after you have attached it to the Toolbar, you may mess up the Toolbar. For this reason, you should try to put every picture you will need in the ImageList first. Then initialize the Toolbar.
When the user clicks a button, the Toolbar control's ButtonClick event fires. You can use the buton's Key property to tell which button was clicked.
Private Sub Toolbar1_ButtonClick(ByVal Button As _
MSComctlLib.Button)
Select Case Button.Key
Case "Cut"
MsgBox "Cut"
Case "Copy"
MsgBox "Copy"
Case "Center"
MsgBox "Center"
Case "Snapshot"
MsgBox "Snapshot"
End Select
End Sub
Some additional tips from Gary German:
Toolbar graphics can be assigned from external files at runtime. But, the graphics on each toolbar must all be the same size, otherwise they'll look bad. Specifically, the first button to which a graphic is assigned "wins", and all following graphics will be stretched, if necessary, to fit in that same size.
Max number of buttons on a toolbar is 255.
If you need to create some buttons with graphics, and others with text only, don't use the button's .Caption property - it will cause all buttons to grow vertically because the text is placed below the missing graphic. Instead, use a routine to turn the text you want to display into a graphic, and assign this "graphic" to the image list, and then the toolbar button.
Thursday, July 23, 2009
Sunday, July 19, 2009
Center a Form Accounting for the Taskbar and Other Appbars
Center your forms based on the actual portion of the screen that is exposed. This method takes into account Window's taskbar and any other appbars such as toolbars that are docked to the edge of the screen.
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17
Private Sub Form_Load()
Dim lLeft As Long
Dim lTop As Long
With Me
lLeft = (Screen.TwipsPerPixelX * _
(GetSystemMetrics(SM_CXFULLSCREEN) / 2)) - (.Width / 2)
lTop = (Screen.TwipsPerPixelY * _
(GetSystemMetrics(SM_CYFULLSCREEN) / 2)) - (.Height / 2)
.Move lLeft, lTop
End With
End Sub
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17
Private Sub Form_Load()
Dim lLeft As Long
Dim lTop As Long
With Me
lLeft = (Screen.TwipsPerPixelX * _
(GetSystemMetrics(SM_CXFULLSCREEN) / 2)) - (.Width / 2)
lTop = (Screen.TwipsPerPixelY * _
(GetSystemMetrics(SM_CYFULLSCREEN) / 2)) - (.Height / 2)
.Move lLeft, lTop
End With
End Sub
Classic VB - What is Option Explicit, and why should I use it?
What does it mean?
Putting the "Option Explicit" statement at the top of a code module (which includes forms/modules/classes/...) forces you to declare all variables that you have used in that module, using Dim or similar.
If you try to run your code when a variable hasn't been declared, it will be highlighted, and you will get a clear error: "Variable not defined"
Why should I use it?
You are probably thinking "errors are bad, I don't want that!", but this is actually a very good error - as it tells you about problems that are hard to spot otherwise.
Have a look at this code, can you see why it gives the wrong answers?
vb Code:
Dim MyVariable As Integer MyVariable = 10 MsgBox MyVariable 'should show 10 MyVariable = MyVariable + 1 MsgBox MyVariable 'should show 11 MyVariable = MyVaraible - 2 MsgBox MyVariable 'should show 9 Instead of showing us "10", "11", "9", the messages actually show us "10", "11", "-2"!
The reason for this is that I mis-spelt the variable name (MyVariable = MyVaraible - 2), so VB being 'kind' creates a new variable (which has a default value of 0), and uses it in the calculation.
In the code above it is fairly easy to spot the mistake, but the more code you have the harder it gets to find mistakes like this - generally all you know is that the code is not working properly, but you can't tell why.
Instead of spending lots of time trying to work it out, simply having Option Explicit at the top of the code file will tell you what (and where) the problem is, so all you need to do is correct the variable name (or declare the variable, if it was meant to be a different one!).
Can I have it added to my code automatically?
Yes you can, but only to new files that you create - you will need to add it yourself to existing files.
To have it added to all new files you create, simply select "Tools" -> "Options", and tick the "Require Variable Declaration" box.
Putting the "Option Explicit" statement at the top of a code module (which includes forms/modules/classes/...) forces you to declare all variables that you have used in that module, using Dim or similar.
If you try to run your code when a variable hasn't been declared, it will be highlighted, and you will get a clear error: "Variable not defined"
Why should I use it?
You are probably thinking "errors are bad, I don't want that!", but this is actually a very good error - as it tells you about problems that are hard to spot otherwise.
Have a look at this code, can you see why it gives the wrong answers?
vb Code:
Dim MyVariable As Integer MyVariable = 10 MsgBox MyVariable 'should show 10 MyVariable = MyVariable + 1 MsgBox MyVariable 'should show 11 MyVariable = MyVaraible - 2 MsgBox MyVariable 'should show 9 Instead of showing us "10", "11", "9", the messages actually show us "10", "11", "-2"!
The reason for this is that I mis-spelt the variable name (MyVariable = MyVaraible - 2), so VB being 'kind' creates a new variable (which has a default value of 0), and uses it in the calculation.
In the code above it is fairly easy to spot the mistake, but the more code you have the harder it gets to find mistakes like this - generally all you know is that the code is not working properly, but you can't tell why.
Instead of spending lots of time trying to work it out, simply having Option Explicit at the top of the code file will tell you what (and where) the problem is, so all you need to do is correct the variable name (or declare the variable, if it was meant to be a different one!).
Can I have it added to my code automatically?
Yes you can, but only to new files that you create - you will need to add it yourself to existing files.
To have it added to all new files you create, simply select "Tools" -> "Options", and tick the "Require Variable Declaration" box.
Friday, July 17, 2009
VB 6.0 code for Hex to Decimal Conversion
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
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
VB 6.0 code fro HID Communication and create Excel using data from Hid Device
Option Explicit
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
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
VB 6.0 code for Creating Excel
Firstly Add References:=Microsoft Excel 11.0 Object Library
Dim objExcel As New Excel.Application
Dim oWB As Excel.Workbook
Dim oWS As Excel.Worksheet
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
Dim objExcel As New Excel.Application
Dim oWB As Excel.Workbook
Dim oWS As Excel.Worksheet
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
VB 6.0 code for checking file existing in a folder
Firstly add Reference Microsoft Scripting Runtime
Dim fso As New FileSystemObject
If fso.FileExists(App.Path & "\Excel Files\Default.xls") = False Then
Else
EndIf
Dim fso As New FileSystemObject
If fso.FileExists(App.Path & "\Excel Files\Default.xls") = False Then
Else
EndIf
VB 6.0 code for read data from a file
Dim line 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
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
VB 6.0 code for Open file using Microsoft Common Dialog Control 6.0
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
Dim filename As string
filename = CommonDialog1.filename
Dim fl As String
fl = CommonDialog1.FileTitle
CommonDialog1.Filter = "Log Documents (*.log)|*.log|Text Documents (*.txt)|*.txt|Excel Spreadsheets (*.xls)|*.xls"
CommonDialog1.FilterIndex = 1
CommonDialog1.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
CommonDialog1.ShowOpen
Dim filename As string
filename = CommonDialog1.filename
Dim fl As String
fl = CommonDialog1.FileTitle
VB 6.0 code for delete all files in a folder
On Error Resume Next
MkDir App.Path & "\Temp"
DeleteAllFiles App.Path & "\Temp"
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
MkDir App.Path & "\Temp"
DeleteAllFiles App.Path & "\Temp"
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
Check Tablename in Database using VB 6.0
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim tables() as String
Dim tablename as String
Dim msg as String
Dim table1 as String
If con.State = adStateOpen Then
con.Close
End If
con.Open
Set rs = con.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))
Do Until rs.EOF
If table1 = "" Then
table1 = rs!table_name
Else
table1 = table1 & "," & rs!table_name
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
msg = IsInArray(tablename, tables())
Public Function IsInArray(FindValue As Variant, arrSearch As Variant) As Boolean
On Error GoTo LocalError
If Not IsArray(arrSearch) Then Exit Function
If Not IsNumeric(FindValue) Then FindValue = LCase(FindValue)
IsInArray = InStr(1, vbNullChar & Join(arrSearch, vbNullChar) & vbNullChar, _
vbNullChar & FindValue & vbNullChar) > 0
Exit Function
LocalError:
'Justin (just in case)
End Function
Dim rs As New ADODB.Recordset
Dim tables() as String
Dim tablename as String
Dim msg as String
Dim table1 as String
If con.State = adStateOpen Then
con.Close
End If
con.Open
Set rs = con.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "TABLE"))
Do Until rs.EOF
If table1 = "" Then
table1 = rs!table_name
Else
table1 = table1 & "," & rs!table_name
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
msg = IsInArray(tablename, tables())
Public Function IsInArray(FindValue As Variant, arrSearch As Variant) As Boolean
On Error GoTo LocalError
If Not IsArray(arrSearch) Then Exit Function
If Not IsNumeric(FindValue) Then FindValue = LCase(FindValue)
IsInArray = InStr(1, vbNullChar & Join(arrSearch, vbNullChar) & vbNullChar, _
vbNullChar & FindValue & vbNullChar) > 0
Exit Function
LocalError:
'Justin (just in case)
End Function
Check value in an array using VB 6.0
Dim tables() as String
Dim tablename as String
Dim msg as String
msg = IsInArray(tablename, tables())
Public Function IsInArray(FindValue As Variant, arrSearch As Variant) As Boolean
On Error GoTo LocalError
If Not IsArray(arrSearch) Then Exit Function
If Not IsNumeric(FindValue) Then FindValue = LCase(FindValue)
IsInArray = InStr(1, vbNullChar & Join(arrSearch, vbNullChar) & vbNullChar, _
vbNullChar & FindValue & vbNullChar) > 0
Exit Function
LocalError:
'Justin (just in case)
End Function
Dim tablename as String
Dim msg as String
msg = IsInArray(tablename, tables())
Public Function IsInArray(FindValue As Variant, arrSearch As Variant) As Boolean
On Error GoTo LocalError
If Not IsArray(arrSearch) Then Exit Function
If Not IsNumeric(FindValue) Then FindValue = LCase(FindValue)
IsInArray = InStr(1, vbNullChar & Join(arrSearch, vbNullChar) & vbNullChar, _
vbNullChar & FindValue & vbNullChar) > 0
Exit Function
LocalError:
'Justin (just in case)
End Function
Minimize VB 6.0 Application to TaskBar and checking if it is already running
Open a new standard project in vb 6.0
Then add a module named modPublic.bas in the project and add the following code in the module which are the public declaration and API call code:
Option Explicit
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As MinimiseIconData) As Boolean
'constants required by Shell_NotifyIcon API call:
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click
Then add other module named modType for the public type declaration for the project. Add the following code in this module:
Public Type MinimiseIconData
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Then on the Form1 properties select the icon which you want to display when your application is minimised to the task bar.
Note: icon has the extention .ico
Add one command button on the form
Then in the Form1 code page add the following code:
Option Explicit
Private minIco As MinimiseIconData
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
If App.PrevInstance Then
End
End If
With minIco
.cbSize = Len(minIco)
.hwnd = Me.hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon ' <== You can change this to another icon
.szTip = "Double-click this icon to make the application visible" & vbNullChar ' <== You can change this also.
End With
Shell_NotifyIcon NIM_ADD, minIco
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngButtonAction As Long
lngButtonAction = X / Screen.TwipsPerPixelX
Select Case lngButtonAction
Case WM_LBUTTONDBLCLK
' Left mouse button has been double clicked
' If app is currently minimized ….
Me.WindowState = vbNormal
Me.Show
'If Me.WindowState = vbMinimized Then ' … then restore it to normal size
' Me.WindowState = vbNormal
' Shell_NotifyIcon NIM_DELETE, nid ' and remove the icon
'ElseIf Not Me.Visible Then ' Else, if the app is hidden …
' Me.Show ' then show the form again
' Me.WindowState = vbNormal
' Shell_NotifyIcon NIM_DELETE, nid ' and remove the icon
'End If
Case WM_LBUTTONDOWN
' You could put code in here to make something happen when
' left mouse button is single clicked on the icon
Case WM_RBUTTONDOWN
' You could put code in here to make something happen when
' right mouse button is single clicked on the icon
End Select
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.WindowState = vbMinimized Then
Me.Hide
Shell_NotifyIcon NIM_ADD, minIco
Else ' otherwise don't show it
Me.Show
Shell_NotifyIcon NIM_DELETE, minIco ' ç This removes the icon
End If
End Sub
Private Sub Form_Terminate()
Shell_NotifyIcon NIM_DELETE, minIco
End Sub
Then add a module named modPublic.bas in the project and add the following code in the module which are the public declaration and API call code:
Option Explicit
Public Declare Function Shell_NotifyIcon Lib "shell32" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, pnid As MinimiseIconData) As Boolean
'constants required by Shell_NotifyIcon API call:
Public Const NIM_ADD = &H0
Public Const NIM_MODIFY = &H1
Public Const NIM_DELETE = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_ICON = &H2
Public Const NIF_TIP = &H4
Public Const WM_MOUSEMOVE = &H200
Public Const WM_LBUTTONDOWN = &H201 'Button down
Public Const WM_LBUTTONUP = &H202 'Button up
Public Const WM_LBUTTONDBLCLK = &H203 'Double-click
Public Const WM_RBUTTONDOWN = &H204 'Button down
Public Const WM_RBUTTONUP = &H205 'Button up
Public Const WM_RBUTTONDBLCLK = &H206 'Double-click
Then add other module named modType for the public type declaration for the project. Add the following code in this module:
Public Type MinimiseIconData
cbSize As Long
hwnd As Long
uId As Long
uFlags As Long
uCallBackMessage As Long
hIcon As Long
szTip As String * 64
End Type
Then on the Form1 properties select the icon which you want to display when your application is minimised to the task bar.
Note: icon has the extention .ico
Add one command button on the form
Then in the Form1 code page add the following code:
Option Explicit
Private minIco As MinimiseIconData
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
If App.PrevInstance Then
End
End If
With minIco
.cbSize = Len(minIco)
.hwnd = Me.hwnd
.uId = vbNull
.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
.uCallBackMessage = WM_MOUSEMOVE
.hIcon = Me.Icon ' <== You can change this to another icon
.szTip = "Double-click this icon to make the application visible" & vbNullChar ' <== You can change this also.
End With
Shell_NotifyIcon NIM_ADD, minIco
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim lngButtonAction As Long
lngButtonAction = X / Screen.TwipsPerPixelX
Select Case lngButtonAction
Case WM_LBUTTONDBLCLK
' Left mouse button has been double clicked
' If app is currently minimized ….
Me.WindowState = vbNormal
Me.Show
'If Me.WindowState = vbMinimized Then ' … then restore it to normal size
' Me.WindowState = vbNormal
' Shell_NotifyIcon NIM_DELETE, nid ' and remove the icon
'ElseIf Not Me.Visible Then ' Else, if the app is hidden …
' Me.Show ' then show the form again
' Me.WindowState = vbNormal
' Shell_NotifyIcon NIM_DELETE, nid ' and remove the icon
'End If
Case WM_LBUTTONDOWN
' You could put code in here to make something happen when
' left mouse button is single clicked on the icon
Case WM_RBUTTONDOWN
' You could put code in here to make something happen when
' right mouse button is single clicked on the icon
End Select
End Sub
Private Sub Form_Resize()
On Error Resume Next
If Me.WindowState = vbMinimized Then
Me.Hide
Shell_NotifyIcon NIM_ADD, minIco
Else ' otherwise don't show it
Me.Show
Shell_NotifyIcon NIM_DELETE, minIco ' ç This removes the icon
End If
End Sub
Private Sub Form_Terminate()
Shell_NotifyIcon NIM_DELETE, minIco
End Sub
Subscribe to:
Posts (Atom)
Using Authorization with Swagger in ASP.NET Core
Create Solution like below LoginModel.cs using System.ComponentModel.DataAnnotations; namespace UsingAuthorizationWithSwagger.Models { ...
-
<ControlTemplate x:Key="TextBoxBaseControlTemplate" TargetType="{x:Type TextBoxBase}"> <Borde... -
<?xml version="1.0" encoding="utf-8"?> <Report xmlns:rd="http://schemas.microsoft.com/SQLServer/reporting...
-
using System; using System.Collections.Generic; using System.ComponentModel; using System.Data; using System.D...