Detecting Modems(Very Urgent!!!)

[sacnirmal]

Hi all,
I am devloping the dialer application in VB.In that I am facing one prob. that is I require the list of modems attached to a computer in a combo box.Any help in this is highly appreciated.

Thanx in Advance
Sachin...

[Chris]

there is 2 way you can do it.

1. detect the DTR with your MSComm32.OCX control
2. Juz open all the available serial port, send a "AT" & vbCrLf command to the opened port and juz wait for the OK response from the modem. If you can get a OK, mean the modem is present, else modem is not attached to the specific port.

regards,

[chrisjk]

There is an easier way; all modems are stored in the registry...

Paste this into a module

Option Explicit
 
Public Const HKEY_CLASSES_ROOT = &H80000000
Public Const HKEY_CURRENT_USER = &H80000001
Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const HKEY_USERS = &H80000003
Public Const HKEY_PERFORMANCE_DATA = &H80000004
Public Const HKEY_CURRENT_CONFIG = &H80000005
Public Const HKEY_DYN_DATA = &H80000006
Public Const REG_SZ = 1                         ' Unicode nul terminated string
Public Const REG_BINARY = 3                     ' Free form binary
Public Const REG_DWORD = 4                      ' 32-bit number
Public Const ERROR_SUCCESS = 0&
 
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function RegEnumKey Lib "advapi32.dll" Alias "RegEnumKeyA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, ByVal cbName As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
Public Function GetAllKeys(hKey As Long, strPath As String) As Variant
' Returns: an array in a variant of strings
 
Dim lRegResult As Long
Dim lCounter As Long
Dim hCurKey As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim strNames() As String
Dim intZeroPos As Integer
 
lCounter = 0
 
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
 
Do
 
  'initialise buffers (longest possible length=255)
  lDataBufferSize = 255
  strBuffer = String(lDataBufferSize, " ")
  lRegResult = RegEnumKey(hCurKey, lCounter, strBuffer, lDataBufferSize)
 
  If lRegResult = ERROR_SUCCESS Then
  
    'tidy up string and save it
    ReDim Preserve strNames(lCounter) As String
    
    intZeroPos = InStr(strBuffer, Chr$(0))
    If intZeroPos > 0 Then
      strNames(UBound(strNames)) = Left$(strBuffer, intZeroPos - 1)
    Else
      strNames(UBound(strNames)) = strBuffer
    End If
 
    lCounter = lCounter + 1
 
  Else
    Exit Do
  End If
Loop
 
GetAllKeys = strNames
 
End Function
Public Function GetSettingString(hKey As Long, strPath As String, strValue As String, Optional Default As String) As String
Dim hCurKey As Long
Dim lValueType As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim intZeroPos As Integer
Dim lRegResult As Long
 
' Set up default value
If Not IsEmpty(Default) Then
  GetSettingString = Default
Else
  GetSettingString = ""
End If
 
' Open the key and get length of string
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, ByVal 0&, lDataBufferSize)
 
If lRegResult = ERROR_SUCCESS Then
 
  If lValueType = REG_SZ Then
    ' initialise string buffer and retrieve string
    strBuffer = String(lDataBufferSize, " ")
    lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, ByVal strBuffer, lDataBufferSize)
    
    ' format string
    intZeroPos = InStr(strBuffer, Chr$(0))
    If intZeroPos > 0 Then
      GetSettingString = Left$(strBuffer, intZeroPos - 1)
    Else
      GetSettingString = strBuffer
    End If
 
  End If
 
Else
  ' there is a problem
End If
 
lRegResult = RegCloseKey(hCurKey)
End Function

Usage:

Dim SubKeys As Variant
Dim KeyLoop As Integer
Dim KeyName As String
Dim FullName As String
 
SubKeys = GetAllKeys(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Modem")
 
' Get Full names of all modems installed and put in user select box
If VarType(SubKeys) = vbArray + vbString Then
    For KeyLoop = 0 To UBound(SubKeys)
        KeyName = SubKeys(KeyLoop)
        FullName = GetSettingString(HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Modem\" & KeyName, "DriverDesc")
        Combo1.AddItem FullName
    Next
End If

[Jay Rogozinsky]

If you would rather use the API instead of accessing the registry, which is what a lot of API calls do anyways, look into TAPI. It is alive and well in Windows.

[jovton]

chrisjk, I have Win XP (SP1) with a two modems, and those registry entries does not even exists on me system. Are the paths different for different OS'es (i.e. 98 / NT 4.0)?

[Aaron Young]

Try something like this:

In a Standard Module:

Option Explicit
 
Private Const RAS_MaxDeviceType = 16
Private Const RAS_MaxDeviceName = 128
 
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
 
Private Const APINULL = 0&
 
Private Type RASDEVINFO
  dwSize As Long
  szDeviceType(RAS_MaxDeviceType) As Byte
  szDeviceName(RAS_MaxDeviceName) As Byte
End Type
 
Private Declare Function RasEnumDevices Lib "rasapi32.dll" Alias "RasEnumDevicesA" (lpRasDevInfo As Any, lpcb As Long, lpcDevices As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
 
Public Function GetRASDeviceList() As String()
  Dim sList() As String
  Dim tRasDevInfo As RASDEVINFO
  Dim lCb As Long
  Dim lDevices As Long
  Dim lBuff As Long
  Dim lRet As Long
  Dim lPtr As Long
  Dim lCount As Long
  
  lCb = 0
  
  tRasDevInfo.dwSize = LenB(tRasDevInfo) + (LenB(tRasDevInfo) Mod 4)
  
  lRet = RasEnumDevices(ByVal 0, lCb, lDevices)
  
  lBuff = GlobalAlloc(GPTR, lCb)
  
  CopyMemory ByVal lBuff, tRasDevInfo, LenB(tRasDevInfo)
  
  lRet = RasEnumDevices(ByVal lBuff, lCb, lCb)
  
  If lRet = 0 Then
    lPtr = lBuff
    
    Do While lDevices > 0
      CopyMemory tRasDevInfo, ByVal lPtr, LenB(tRasDevInfo)
      If StrComp(ByteToString(tRasDevInfo.szDeviceType), "Modem", vbTextCompare) = 0 Then
        ReDim Preserve sList(lCount)
        sList(lCount) = ByteToString(tRasDevInfo.szDeviceName)
        lCount = lCount + 1
      End If
      lPtr = lPtr + LenB(tRasDevInfo) + (LenB(tRasDevInfo) Mod 4)
      lDevices = lDevices - 1
    Loop
  End If
  
  If lBuff <> 0 Then GlobalFree (lBuff)
  
  GetRASDeviceList = sList
End Function
 
Private Function ByteToString(ByRef bByte() As Byte) As String
  Dim lCount As Long
  Dim sString As String
  
  Do While lCount < UBound(bByte) And bByte(lCount) <> 0
    sString = sString & Chr$(bByte(lCount))
    lCount = lCount + 1
  Loop
  ByteToString = sString
End Function

Example Usage:

Private Sub Form_Load()
  Dim sList() As String
  Dim lCount As Long
  
  sList = GetRASDeviceList()
  For lCount = 0 To UBound(sList)
    List1.AddItem sList(lCount)
  Next
End Sub