Two Hoots Software Visual Basic System Tips

The following code uses the Microsoft Scripting Runtime library to receive information about all the available drives. Add a multiline textbox to the form and add the following code to the Form.Load event. You will require a reference to Microsoft Scripting Runtime Type Library.

Dim fso As New Scripting.FileSystemObject
Dim drv As Scripting.Drive
Dim info As String

For Each drv In fso.Drives
  ' display drive name and type
  info = "Drive " & drv.DriveLetter & vbCrLf
  info = info & "  Type: "
 ' we must decode this value
 Select Case drv.DriveType
   Case Removable: info = info & "Removable" & vbCrLf
   Case Fixed: info = info & "Fixed" & vbCrLf
   Case CDRom: info = info & "CDRom" & vbCrLf
   Case Remote: info = info & "Remote" & vbCrLf
   Case RamDisk: info = info & "RamDisk" & vbCrLf
   Case Else: info = info & "Unknown" & vbCrLf
 End Select

 If Not drv.IsReady Then
   ' if the drive isn't ready we can't do much more
   info = info & "  Not Ready" & vbCrLf
 Else
   ' retrieve all additional info
   info = info & "   File System: " & drv.FileSystem & vbCrLf
   info = info & "   Label: " & drv.VolumeName & vbCrLf
   info = info & "   Serial number: " & drv.SerialNumber & vbCrLf
   info = info & "   Total space: " & drv.TotalSize & vbCrLf
   info = info & "   Free space: " & drv.FreeSpace & vbCrLf
 End If

 ' do something with the gathered info
 ' (display in a textbox in this case)
 Text1.Text = Text1.Text & info
Next

The following code uses API calls to determine your computer's IP address and name. You will require a form and a .bas module.

'***************************put this in vb form*************

Private Sub Form_Load()
  MsgBox GetIPAddress
  MsgBox GetIPHostName
End Sub

'*********************in vb module ************************

Public Const MAX_WSADescription = 256
Public Const MAX_WSASYSStatus = 128
Public Const ERROR_SUCCESS As Long = 0
Public Const WS_VERSION_REQD As Long = &H101
Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD As Long = 1
Public Const SOCKET_ERROR As Long = -1

Public Type HOSTENT
  hName As Long
  hAliases As Long
  hAddrType As Integer
  hLen As Integer
  hAddrList As Long
End Type

Public Type WSADATA
  wVersion As Integer
  wHighVersion As Integer
  szDescription(0 To MAX_WSADescription) As Byte
  szSystemStatus(0 To MAX_WSASYSStatus) As Byte
  wMaxSockets As Integer
  wMaxUDPDG As Integer
  dwVendorInfo As Long
End Type

Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long

Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Public Declare Function gethostname Lib "WSOCK32.DLL" _
(ByVal szHost As String, ByVal dwHostLen As Long) As Long

Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal szHost As String) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Public Function GetIPAddress() As String

Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String

If Not SocketsInitialize() Then
  GetIPAddress = ""
  Exit Function
End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then
  GetIPAddress = ""
  MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
  " has occurred. Unable to successfully get Host Name."
  SocketsCleanup
  Exit Function
End If

sHostName = Trim$(sHostName)
lpHost = gethostbyname(sHostName)

If lpHost = 0 Then
  GetIPAddress = ""
  MsgBox "Windows Sockets are not responding. " & _
  "Unable to successfully get Host Name."
  SocketsCleanup
  Exit Function
End If

CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4

ReDim tmpIPAddr(1 To HOST.hLen)

CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen

For i = 1 To HOST.hLen
  sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next

GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
SocketsCleanup

End Function

Public Function GetIPHostName() As String

Dim sHostName As String * 256

If Not SocketsInitialize() Then
  GetIPHostName = ""
  Exit Function
End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then
  GetIPHostName = ""
  MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
  " has occurred. Unable to successfully get Host Name."
  SocketsCleanup
  Exit Function
End If

GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
SocketsCleanup

End Function

Public Function HiByte(ByVal wParam As Integer)

HiByte = wParam \ &H100 And &HFF&

End Function

Public Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function

Public Sub SocketsCleanup()

If WSACleanup() <> ERROR_SUCCESS Then
  MsgBox "Socket error occurred in Cleanup."
End If

End Sub

Public Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String

If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
  MsgBox "The 32-bit Windows Socket is not responding."
  SocketsInitialize = False
  Exit Function
End If

If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
  MsgBox "This application requires a minimum of " & _
  CStr(MIN_SOCKETS_REQD) & " supported sockets."
  SocketsInitialize = False
  Exit Function
End If

If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
  sHiByte = CStr(HiByte(WSAD.wVersion))
  sLoByte = CStr(LoByte(WSAD.wVersion))
  MsgBox "Sockets version " & sLoByte & "." & sHiByte & _
  " is not supported by 32-bit Windows Sockets."
  SocketsInitialize = False
  Exit Function
End If

'must be OK, so lets do it
SocketsInitialize = True

End Function

The following code uses a reference to 'Windows Script Host Object Model' to create an applications shortcut on your desktop.

  
Dim oShell As New IWshShell_Class

Set oShell = New IWshShell_Class
    
Dim sDesktop As String
sDesktop = oShell.SpecialFolders.Item("Desktop")
    
Dim MyShortcut As IWshShortcut_Class
Set MyShortcut = oShell.CreateShortcut(sDesktop & "\Shortcut to notepad.lnk")
With MyShortCut
  .TargetPath = oShell.ExpandEnvironmentStrings("%windir%\notepad.exe")
  .WorkingDirectory = oShell.ExpandEnvironmentStrings("%windir%")
  .WindowStyle = 4
  .Save
End With

Use the following routine to enhance the display of version numbers.

Public Function GetMyVersion() As String

' Change Version into 1.02.0001 form

Static strMyVer As String

If strMyVer = "" Then
  ' Only call once for performance
  strMyVer = Trim$(Str$(App.Major)) & "." & Format$(App.Minor, "##00") & "." & Format$(App.Revision, "000")
End If

GetMyVersion = strMyVer

End Function

Use the following code to show free memory.

Declare Sub GlobalMemoryStatus Lib "kernel32" (lpBuffer As MEMORYSTATUS)

Type MEMORYSTATUS
  dwLength As Long
  dwMemoryLoad As Long
  dwTotalPhys As Long
  dwAvailPhys As Long
  dwTotalPageFile As Long
  dwAvailPageFile As Long
  dwTotalVirtual As Long
  dwAvailVirtual As Long
End Type

Private Sub Form_Load()

Dim ms As MEMORYSTATUS

ms.dwLength = Len(ms)

GlobalMemoryStatus ms

MsgBox "Total Physical Memory:" & ms.dwTotalPhys & vbCr & "Available Physical Memory:" & ms.dwAvailPhys & vbCr & "Memory Load:" & ms.dwMemoryLoad

End Sub

The Code in the VB Setup kit project contains a number of useful routines which you can use in your own projects, these include routines to - .

Get the Windows directory
Get the Windows System directory
Determine if a file or directory exists
Determine which version of windows you are running
Determine drive type
Check disk space
Create a new path
Read from an INI file
Parse date and time
Retrieve the short path name of a file containing long file names
Code to log errors to an error file

Use the following code replace the Now() function as it's far more accurate.

Private Declare Function timeGetTime Lib "winmm.dll" () As Long

Function BetterNow() As Date

Static offset As Date
Static uptimeMSOld As Long

Dim uptimeMSNew As Long

Const OneSecond = 1 / (24# * 60 * 60)
Const OneMs = 1 / (24# * 60 * 60 * 1000)

uptimeMSNew = timeGetTime()

' check to see if it is first time function called or
' if timeGetTime rolled over (happens every 47 days)

If offset = 0 Or uptimeMSNew < uptimeMSOld Then
  offset = Date - uptimeMSNew * OneMs + CDbl(Timer) * OneSecond
  uptimeMSOld = uptimeMSNew
End If

BetterNow = uptimeMSNew * OneMs + offset

End Function

Use the following code to copy the current screen to the clipboard. You can then past the image into paintbrush.

'The declaration
Public Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan _
As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

'The call
Call keybd_event(VK_SNAPSHOT, FullScreen, 0, 0)

'constants for screen capture
Public Const VK_SNAPSHOT = &H2C
Public Const FullScreen = 0
Public Const AppScreen = 1