Detect when Removable USB Volume Drive Devices are Attached or Removed – VB.NET [duplicate] - vb.net

This question already has an answer here:
Portable Device Detection
(1 answer)
Closed 5 years ago.
Below is some code I saw on a vb message board along time ago but I can’t remember where. It may have been vbforums.com. I made some code changes and then tested the code to have it throw a messagebox with the drive letter of the new usb device being attached or removed. It uses application subclassing to intercept the messages and checks if any are activated by a removable volume being Removed, Inserted, Attached, etc.. If it is then it will parse the volume drive letter of the device and throw a messagebox letting you know. USB devices like flash drives (Thumb Drives or Pen Drive’s as they are also called), external hard drives, etc. with a removable disk volume should be detected just fine. My testing recognized different usb volumes with no problems. You can use this code with VB.NET, Visual Basic 2008, VB 2010, 2013, etc. to check for both the arrival of usb volume devices and the removal. You can also make some changes to make it work for VB 6.0 as well. Visual Basic 6.0 will need an addiional API call or two for the subclassing portion.

Protected Overrides Sub WndProc(ByRef M As System.Windows.Forms.Message)
'
'These are the required subclassing codes for detecting device based removal and arrival.
'
If M.Msg = WM_DEVICECHANGE Then
Select Case M.WParam
'
'Check if a device was added.
Case DBT_DEVICEARRIVAL
Dim DevType As Integer = Runtime.InteropServices.Marshal.ReadInt32(M.LParam, 4)
If DevType = DBT_DEVTYP_VOLUME Then
Dim Vol As New DEV_BROADCAST_VOLUME
Vol = Runtime.InteropServices.Marshal.PtrToStructure(M.LParam, GetType(DEV_BROADCAST_VOLUME))
If Vol.Dbcv_Flags = 0 Then
For i As Integer = 0 To 20
If Math.Pow(2, i) = Vol.Dbcv_Unitmask Then
Dim Usb As String = Chr(65 + i) + ":\"
MsgBox("Looks like a USB device was plugged in!" & vbNewLine & vbNewLine & "The drive letter is: " & Usb.ToString)
Exit For
End If
Next
End If
End If
'
'Check if the message was for the removal of a device.
Case DBT_DEVICEREMOVECOMPLETE
Dim DevType As Integer = Runtime.InteropServices.Marshal.ReadInt32(M.LParam, 4)
If DevType = DBT_DEVTYP_VOLUME Then
Dim Vol As New DEV_BROADCAST_VOLUME
Vol = Runtime.InteropServices.Marshal.PtrToStructure(M.LParam, GetType(DEV_BROADCAST_VOLUME))
If Vol.Dbcv_Flags = 0 Then
For i As Integer = 0 To 20
If Math.Pow(2, i) = Vol.Dbcv_Unitmask Then
Dim Usb As String = Chr(65 + i) + ":\"
MsgBox("Looks like a volume device was removed!" & vbNewLine & vbNewLine & "The drive letter is: " & Usb.ToString)
Exit For
End If
Next
End If
End If
End Select
End If
MyBase.WndProc(M)
End Sub

Related

Telnet (winsock) connection in VBA - class not registered

I have GSM gateway that use telnet for sending/recivieng SMS. I'am making a small app in my ms-access for sending sms notifications for my clients. For that I need winsock connection from my client computer -> gsm gateway. It supposed to be easy :)
I can't establish an object. I'm receiving run-time error -2147221164(80040154) - Class not registered. Error is indicated in "Set winsock = ..." line. I have added reference MS Winsock Control 6.0 (SP6) - MSWINSCK.OCX. I have a feeling this is a problem with reference, but I don't have any idea how to correct it (code below is simplified) :( .
Option Explicit
Private WithEvents Winsock1 As Winsock
Sub Start_Telnet_Session()
Dim Data As String
Dim Winsock1
Set Winsock1 = New MSWinsockLib.Winsock
Winsock1.RemoteHost = "192.168.1.1"
Winsock1.RemotePort = "23"
Winsock1.connect
Do Until Winsock1.State = 7
DoEvents
If Winsock1.State = sckError Then
Exit Sub
End If
Loop
Winsock1.SendData "user" & vbCrLf
Winsock1.SendData "pass" & vbCrLf
Dim I As Integer
I = 5
While TelnetCommands <> ""
Winsock1.SendData "TelnetCommands" & vbCrLf
Winsock1.GetData Data
Data = VBA.Replace(Data, vbLf, "")
Data = VBA.Replace(Data, vbCr, vbNewLine)
MsgBox Data
I = I + 1
Wend
Winsock1.Close
End Sub

Program reading CPU temperature incorrectly when put on new computer

I am trying to add a feature to an existing program that would display the current CPU core temperature using the Open Hardware Monitor. I have it working properly on my personal computer where it displays the temperature on a tool strip status label and refreshes on a timer. However, when I copy everything over to a new PC and test run the program the temperatures it returns are always coming back roughly 25 degrees higher than what the Monitor shows. If anyone has any ideas as to why it would read correctly on one computer but not another I would appreciate it as I'm stumped...
Here are the Monitor Temps and what my program is displaying on my PC both matched up.
Open Hardware Monitor temperatures
Temperature displayed in program
Now these are the temperatures displayed on the new PC that would be shipped out.
New PC Open Hardware Monitor
Program temperature display on New PC
This is the code I am currently using to get the temps.
Private Sub Timer3_Tick(sender As Object, e As EventArgs) Handles Timer3.Tick
Dim cp As New Computer()
cp.Open()
cp.HDDEnabled = True
cp.FanControllerEnabled = True
cp.RAMEnabled = True
cp.GPUEnabled = True
cp.MainboardEnabled = True
cp.CPUEnabled = True
Dim Info As String = ""
Timer3.Interval = 5000
For i As Integer = 0 To cp.Hardware.Length - 1
Dim hw = cp.Hardware(i)
Select Case hw.HardwareType
Case HardwareType.CPU
ToolStripStatusLabel5.Text = "CPU" & vbCrLf
For j = 0 To hw.Sensors.Length - 1
Dim sensor = hw.Sensors(j)
If cp.Hardware(i).Sensors(j).SensorType = SensorType.Temperature Then
ToolStripStatusLabel5.Text = sensor.Name & " - " & sensor.Value & vbCrLf
End If
Next
End Select
Next
End Sub
I didn't see the error in the code, here is an example of using OpenHardwaremonitor and WMI to get the CPU temperature, maybe you can try it.

Memory files get trashed by third party software

I have an collection of apps that rely on memory files. I create them with a persistent app, then 3 apps update the files with GPS, IMU and switch data, and 3 apps read the current status and generate commands to servo controllers. This has worked fine for years, but today the apps failed due to missing memory files when I started a third party c# camera control app.
I suspect the other app overwrites the memory area. Is there a way to protect these memory files.
I am in Visual Studio 2017, Win10/64 and .net 4.6.1
I have included the create and sample read and write code - all of which have worked for years. I did update the system to current .net 4.6.1, and without the 3rd party app the system runs for hours without error. The instant I start the c# app compiled app the memory files disappear. I do not have access to the source, and am hopeless with C#.
Not a clue now, one solution is to install a new CPU and run the 3rd partys app on a separate box. There is no communication between my apps and it.
I create with :
Dim LoopForever As Boolean = True
Dim AHRS_Memory_File_Name As String = "AHRSMemoryData"
Dim GPS_Memory_File_Name As String = "GPSMemoryData"
Dim Switch_Memory_File_Name As String = "SwitchMemoryData"
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As
System.EventArgs) Handles Button1.Click
Dim MMS = MemoryMappedFile.CreateNew(Switch_Memory_File_Name, 20,
MemoryMappedFileAccess.ReadWrite)
Dim GPS = MemoryMappedFile.CreateNew(GPS_Memory_File_Name, 200,
MemoryMappedFileAccess.ReadWrite)
Dim AHRS = MemoryMappedFile.CreateNew(AHRS_Memory_File_Name, 200,
MemoryMappedFileAccess.ReadWrite)
Do Until LoopForever = False
Thread.Sleep(10000)
Loop
End Sub
A sample Write is
Sub WriteGPS_To_Memory()
Dim GPS_MMF = MemoryMappedFile.OpenExisting(GPS_Memory_File_Name)
Dim Bytes As Byte()
' This is the format of the current gps memory message
outMessage = GPSSpeedIn & "," & GPSBearing & "," & GPSLongitude & ","
& GPSLatitude & "," & GarminMagDeviationText & "," & GPSMessageCount
& "," & GPSAltitude & ","
Bytes = StrToByteArray(outMessage)
Try
Using writer = GPS_MMF.CreateViewAccessor(0, Bytes.Length)
writer.WriteArray(Of Byte)(0, Bytes, 0, Bytes.Length)
' writer.Dispose()
End Using
Catch ex As Exception
MsgBox("mem write error = " & ex.ToString)
End Try
And a sample read is
Dim MMF = MemoryMappedFile.OpenExisting(MEMS_Memory_File_Name)
Using reader = MMF.CreateViewAccessor(0, 200,
MemoryMappedFileAccess.Read)
Dim NewByteString = New Byte(200) {}
reader.ReadArray(Of Byte)(0, NewByteString, 0,
NewByteString.Length)
InMessage = Convert.ToString(NewByteString)
teststring = ""
CycleCount = CycleCount + 1
teststring = BitConverter.ToString(NewByteString)
For i As Integer = 0 To NewByteString.Length - 1
AHRS_CommDataIn =
System.Text.Encoding.ASCII.GetString(NewByteString)
Next
End Using
MMF.Dispose()
Best outcome is to find a way to protect these files. I am in the US, the vendor is in Israel and not particularly responsive.
There is time pressure on this as my company uses this software to locate water bodies producing mosquitoes (hate those pests) which distribute West Nile Virus, Denge and Malaria. Today we scrubbed a 300 sq mi mission affecting about 500K persons.
The issue was apparently in the third party software - they issued a updated program the day we posted the issue to their support site - so we must not have been to only site with this issue

Get Unique identifier of a USB stick in VB.net

From what I have read and tried myself I am starting to think this is not possible; but if you don't don't ask you don't get...
I am making a tool that formats USB sticks for staff at work (it adds branding, instructions, handbooks etc). Whilst doing this I am attempting to store the "serial/Unique identifier" for the device in a database so that should I find a lost memory stick I can find out who the original owner was, even if it has been reformated!
I got this snippet from another answer on SO
Dim driveNames As New List(Of String)
For Each drive As DriveInfo In My.Computer.FileSystem.Drives
Try
Dim fso As Scripting.FileSystemObject
Dim oDrive As Scripting.Drive
fso = CreateObject("Scripting.FileSystemObject")
oDrive = fso.GetDrive(drive.Name)
ListBox1.Items.Add(drive.Name & " " & oDrive.SerialNumber)
Catch ex As Exception
End Try
Next
End Sub
This returns a number, but that changes when the drive is formatted.
I also tried modifying a snippet I got from online (CodeProject) I think.
'Check for valid drive letter argument.
ToolStripStatusLabel1.Text = "Fetching Device Serial ('" & DriveLetter & "' Validating drive letters)"
Dim ValidDriveLetters As String = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
If ValidDriveLetters.IndexOf(DriveLetter) <> -1 Then
If DriveLetter.Length = 1 Then
ToolStripStatusLabel1.Text = "Fetching Device Serial ('" & DriveLetter & "' Creating Disk Management Object)"
Dim Disk As New System.Management.ManagementObject("Win32_LogicalDisk.DeviceID=""" & DriveLetter & ":""")
ToolStripStatusLabel1.Text = "Fetching Device Serial ('" & DriveLetter & "' Creating Disk Property)"
Dim DiskProperty As System.Management.PropertyData
For Each DiskProperty In Disk.Properties
ToolStripStatusLabel1.Text = "Fetching Device Serial ('" & DriveLetter & "' Reading " & DiskProperty.Name & ": " & DiskProperty.Value & ")"
'Threading.Thread.Sleep(1000)
If DiskProperty.Name = "VolumeSerialNumber" Then
Return DiskProperty.Value.ToString '.ToString 'Return the volume serial number.
End If
Next DiskProperty
End If
End If
Return Nothing 'Invalid drive letter.
This currently returns the volume serial (best result I could get right now), that obviously changes when the drive is formatted.
I have looked through the property names but I am yet to find something to uniquely identify the drive itself rather than its volumes.
Is there a property that I can read that would be unique to each device? (even the same the manufacturer/model)
OR
Am I going about this the wrong way? I also considered partitioning the USBs with a hidden partition and then storing the volume serial of that. If an end user formats the drive via Explorer they are only going to wipe the visible partition rather than my secret hidden one...but this seems like a workaround rather than an actual solution?
Please note, I am not a VB.net wizard, web is more my thing (I may need some hand holding at times - but I try my best!)

Com Port doesn't work unless Hyperterminal Open and Closes Port First

So I am trying to connect to a piece of hardware. If I connect and disconnect with hyperterminal first. Then close the connection and the program. Everything works fine. If I don't I receive random characters back from the hardware. I use the same settings in hyperterminal as I do in the code.
baud=9600
parity=n
data=8
stop=1
Hardware flow controls "ON":
octs=on to=on dtr=on rts=hs
If I then disconnect the hardware and the serial port I will have the same problem again.
Is there anyway I can see how to comport is being configured after hyperterminal open and closes the port? I should note I am using a prolific serial to USB adapter.
Below is the code I use to open the com port.
Function OpenCom(PortNum As Integer, Baud As Long) As Long
Dim lpDCB As DCB
Dim ComTimeout As COMMTIMEOUTS
com$ = "COM" + Trim(Str(PortNum))
'open the communications port
hcomtemp& = CreateFile(com$, GENERIC_READ Or GENERIC_WRITE, 0, ByVal 0, OPEN_EXISTING, 0, ByVal 0)
'check for errors
If hcomtemp& < 0 Then
OpenCom = hcomtemp&
Exit Function
End If
r& = PurgeComm(hcomtemp&, 12) ' purge the comm RX and TX (RXCLEAR=0x08 and TXCLEAR=0x04)
' COMMAND LINE for "Hardware" flow control - mode com: baud=9600 parity=n data=8 stop=1 octs=on to=on dtr=on rts=hs
Build$ = "baud=" + Trim(str(Baud)) + " parity=N data=8 stop=1 octs=on to=on dtr=on rts=hs"
'build the data communications block
r& = BuildCommDCB(Build$, lpDCB)
'set the communications port's parameters with the DCB
r& = SetCommState(hcomtemp&, lpDCB)
ComTimeout.ReadIntervalTimeout = 100 'maximum time to wait between received bytes (milliseconds)
ComTimeout.ReadTotalTimeoutConstant = 1000 'maximum time to wait for receive data (milliseconds)
'set the timeouts
r& = SetCommTimeouts(hcomtemp&, ComTimeout)
'set the input buffer size to 4096 bytes and the output buffer size to 4096 bytes
r& = SetupComm(hcomtemp&, 4096, 4096)
'return the handle of the newly opened communications port
OpenCom = hcomtemp&
End Function
Please, try Advanced Serial Port Monitor -> Spy mode. http://www.aggsoft.com/serial-port-monitor.htm. It will show all actions that Hyperterminal does on the port. Then you can repeat these settings. It seems that the problem is related with the hardware flow control settings.
Below is the code I used to fix my problem. I only ever had to do it this way for one piece of equipment.
Function HandShakeBM5AS(ComPort As Integer) As Boolean
Dim Bm5ACom As Long
Dim x As Variant
Dim Path As String
comm$ = ComPort
Commands$ = "MODE COM" & comm$ & ": BAUD=9600 PARITY=N DATA=8 STOP=1 TO=ON XON=OFF ODSR=OFF OCTS=ON DTR=ON RTS=HS IDSR=OFF"
Call Shell("cmd.exe /S /C" & Commands$, vbNormalFocus)
'Shell (Commands$)
End Function
BuildCommDCB() fails if 'rts=hs' is included in the control string. This causes lpDCB to be not set correctly, and SetCommState is called with the wrong values.
You can set the RTS control flag in the lpDCB structure after calling BuildCommDCB. (I would include code but I'm not certain on the Basic syntax)