2017-2-28
14:31

root
root

[程序代码]端口检测--VB篇

Const DEBFLG = 1
Public COMX, BEEPNO, HANGUP, PNLOC As Integer
Public COMBUF, COMLIN As String

Private Sub Command1_Click() '检测串行口
Dim I, C As Integer
COMX = 0
COMBUF = ""
COMLIN = ""
BEEPNO = 0
HANGUP = 0
On Error GoTo ERROR_FORM_LOAD '检测可用串口

For C = 1 To 4
If MSComm1.PortOpen Then
 MSComm1.PortOpen = False
 MSComm1.CommPort = C
End If

If Not MSComm1.PortOpen Then
 MSComm1.PortOpen = True
End If
If COMX = 0 Then
  COMX = C
End If

FORM_LOAD_1: Next

If COMX = 0 Then
 End
 On Error GoTo 0
 Exit Sub
 ERROR_FORM_LOAD:
 Resume FORM_LOAD_1

End Sub

'初试化Modem
Private Sub INIT_MODEM()

If MSComm1.PortOpen Then
  MSComm1.PortOpen = False
End If
 MSComm1.CommPort = COMX

If Not MSComm1.PortOpen Then
 MSComm1.PortOpen = True
 MSComm1.Output = "AT+csq" + vbCr '检查Modem命令是否完成
 Call CHK_MODEM
End If
End Sub
 '检查Modem命令是否完成
Private Sub CHK_MODEM()
 Dim T As Single
 Dim L As Integer
 T = Timer
 Do
  COMBUF = COMBUF + MSComm1.Input
  L = InStr(1, COMBUF, "OK")
  Loop Until L <> 0 Or Timer - T > 1
  If L = 0 Then
    MsgBox "{MODEM未联机", vbOKOnly = vbCritical, "测试MODEM"
  Else
   frmsjcj.Show
  End If
 End Sub

Private Sub Command2_Click()
'COMX = 4
Call INIT_MODEM
 End Sub

以上代码中,虽然可以检测到串口1,但是不是我的设备所在的号

 

VB中自动检测串口输入


VB6.0中,通信控件在“工程” ――“部件”,选中 Microsoft Comm Control6.0

其文件为 mscomm32.ocx

该控件唯一的一个事件就是OnComm事件。随着CommEvent属性值的变化,其后的Case程序代码便被引发。如此就是自动检测了。
(区别于定时检测)

On comm事件中

Select case mscomm1.CommEvent

    Case  comEvCD    ‘CD线的状态发生变化

       If mscomm1.CDHolding then    ‘如果DCD脚位电位为高

       Else

        ….

       End if

    Case  comEvCTS   ‘CTS线的状态发生变化

    Case  comEvDSR   ‘DSR线的状态发生变化

    Case  comEvRing   ‘Ring Indicator 变化

    Case  comEvReceive ‘收到最小接受字符数个字符

    Case  comEvSend   ‘传输缓冲区有最小传输字符数个字符

    Case  comEvEOF   ‘输入数据流中发现EOF 字符

End Select

 

 

 

''''''''''''''''''''''''''端口检测
Option   Explicit  
  Private   Declare   Function   RegOpenKey   Lib   "advapi32.dll"   Alias   "RegOpenKeyA"   (ByVal   hKey   As   Long,   ByVal   lpSubKey   As   String,   phkResult   As   Long)   As   Long  
  Private   Const   HKEY_LOCAL_MACHINE   =   &H80000002  
  Private   Declare   Function   RegCloseKey   Lib   "advapi32.dll"   (ByVal   hKey   As   Long)   As   Long  
  Private   Declare   Function   RegEnumValue   Lib   "advapi32.dll"   Alias   "RegEnumValueA"   (ByVal   hKey   As   Long,   ByVal   dwIndex   As   Long,   ByVal   lpValueName   As   String,   lpcbValueName   As   Long,   ByVal   lpReserved   As   Long,   lpType   As   Long,   lpData   As   String,   lpcbData   As   Long)   As   Long  
   
  Private   Sub   Command3_Click()  
          Const   ERROR_NO_MORE_ITEMS   =   259&  
          Const   BUFFER_SIZE   As   Long   =   255  
          Dim   hKey   As   Long,   Cnt   As   Long,   sName   As   String,   sData   As   String,   Ret   As   Long,   RetData   As   Long  
          Ret   =   BUFFER_SIZE  
          Cnt   =   0  
          If   RegOpenKey(HKEY_LOCAL_MACHINE,   "HardWare\DeviceMap\SerialComm",   hKey)   =   0   Then  
                  sName   =   Space(BUFFER_SIZE)  
                  sData   =   Space(BUFFER_SIZE)  
                  Ret   =   BUFFER_SIZE  
                  RetData   =   BUFFER_SIZE  
                  While   RegEnumValue(hKey,   Cnt,   sName,   Ret,   0,   ByVal   0&,   ByVal   sData,   RetData)   <>   ERROR_NO_MORE_ITEMS  
                          If   RetData   >   0   Then  
                                  List1.AddItem   Left$(sData,   RetData   -   1)  
                          End   If  
                          Cnt   =   Cnt   +   1  
                          sName   =   Space(BUFFER_SIZE)  
                          sData   =   Space(BUFFER_SIZE)  
                          Ret   =   BUFFER_SIZE  
                          RetData   =   BUFFER_SIZE  
                  Wend  
                  RegCloseKey   hKey  
          Else  
                  MsgBox   "     错误"  
          End   If  
  End   Sub  
 


''''''''''''''''''''''''''''''
临时写了个例子,你新建一个工程,把以下代码复制进去就行了,该程序连MODEM的端口都检测出来了,你可根据你的要求把它去掉也行。  
   
  WIN2000+VB6+SP5   测试通过。  
   
  Option   Explicit  
   
  Const   HKEY_CURRENT_CONFIG   =   &H80000005  
  Const   HKEY_LOCAL_MACHINE   =   &H80000002  
  Const   REG_SZ   =   1  
  Private   Declare   Function   RegCloseKey   Lib   "advapi32.dll"   (ByVal   hKey   As   Long)   As   Long  
  Private   Declare   Function   RegOpenKey   Lib   "advapi32.dll"   Alias   "RegOpenKeyA"   (ByVal   hKey   As   Long,   ByVal   lpSubKey   As   String,   phkResult   As   Long)   As   Long  
  Private   Declare   Function   RegEnumKeyEx   Lib   "advapi32.dll"   Alias   "RegEnumKeyExA"   (ByVal   hKey   As   Long,   ByVal   dwIndex   As   Long,   ByVal   lpName   As   String,   lpcbName   As   Long,   ByVal   lpReserved   As   Long,   ByVal   lpClass   As   String,   lpcbClass   As   Long,   lpftLastWriteTime   As   Any)   As   Long  
  Private   Declare   Function   RegEnumValue   Lib   "advapi32.dll"   Alias   "RegEnumValueA"   (ByVal   hKey   As   Long,   ByVal   dwIndex   As   Long,   ByVal   lpValueName   As   String,   lpcbValueName   As   Long,   ByVal   lpReserved   As   Long,   lpType   As   Long,   lpData   As   Byte,   lpcbData   As   Long)   As   Long  
  Private   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  
  Private   Sub   Form_Paint()  
          Dim   hKey   As   Long,   Cnt   As   Long,   sSave   As   String  
          Dim   strRet   As   String  
          Dim   lRet   As   Long  
          Me.Cls  
          Me.Print   "RegEnumValue:"  
          RegOpenKey   HKEY_LOCAL_MACHINE,   "HARDWARE\DEVICEMAP\SERIALCOMM",   hKey  
          Cnt   =   0  
          Do  
                  sSave   =   String(255,   0)  
                  If   RegEnumValue(hKey,   Cnt,   sSave,   255,   0,   ByVal   0&,   ByVal   0&,   ByVal   0&)   <>   0   Then   Exit   Do  
                  strRet   =   StripTerminator(sSave)  
                  Me.Print   strRet   &   vbTab;  
                  sSave   =   String(255,   0)  
                  If   RegQueryValueEx(hKey,   strRet,   0,   REG_SZ,   ByVal   sSave,   255)   =   0   Then  
                          strRet   =   StripTerminator(sSave)  
                          Me.Print   strRet  
                  End   If  
                  Cnt   =   Cnt   +   1  
          Loop  
          RegCloseKey   hKey  
  End   Sub  
  Private   Function   StripTerminator(sInput   As   String)   As   String  
          Dim   ZeroPos   As   Integer  
          ZeroPos   =   InStr(1,   sInput,   vbNullChar)  
          If   ZeroPos   >   0   Then  
                  StripTerminator   =   Left$(sInput,   ZeroPos   -   1)  
          Else  
                  StripTerminator   =   sInput  
          End   If  
  End   Function  

 

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
枚举注册表下的值:  
  HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM  
  ,用API也行,但他会列出所有的端口(包括并口)。  
  【VB声明】  
      Private   Declare   Function   EnumPorts   Lib   "winspool.drv"   Alias   "EnumPortsA"   (ByVal   pName   As   String,   ByVal   Level   As   Long,   ByVal   lpbPorts   As   Long,   ByVal   cbBuf   As   Long,   pcbNeeded   As   Long,   pcReturned   As   Long)   As   Long  
   
  【别名】  
      EnumPortsA  
   
  【说明】  
      枚举一个系统可用的端口    
   
  【返回值】  
      Long,非零表示成功,零表示失败。会设置GetLastError    
   
  【备注】  
      参考AddPort函数,了解进一步的情况  
   
  【参数表】  
      pName   ----------     String,指定服务器的名字。用vbNullString指定本地系统  
   
      Level   ----------     Long,1或2(1用于NT   3.51),分别指定PORT_INFO_1   或   PORT_INFO_2  
   
      lpbPorts   -------     Long,包含PORT_INFO_1   或   PORT_INFO_2结构的缓冲区  
   
      cbBuf   ----------     Long,lpbPorts缓冲区中的字符数量  
   
      pcbNeeded   ------     Long,指向一个Long型变量的指针,该变量用于保存请求的缓冲区长度,或者实际读入的字节数量  
   
      pcReturned   -----     Long,载入缓冲区的结构数量(用于那些能返回多个结构的函数)  
   
  '==============================================  
  Private   Type   PORT_INFO_2  
          pPortName   As   String  
          pMonitorName   As   String  
          pDescription   As   String  
          fPortType   As   Long  
          Reserved   As   Long  
  End   Type  
  Private   Type   API_PORT_INFO_2  
          pPortName   As   Long  
          pMonitorName   As   Long  
          pDescription   As   Long  
          fPortType   As   Long  
          Reserved   As   Long  
  End   Type  
  Private   Declare   Function   EnumPorts   Lib   "winspool.drv"   Alias   "EnumPortsA"   (ByVal   pName   As   String,   ByVal   Level   As   Long,   ByVal   lpbPorts   As   Long,   ByVal   cbBuf   As   Long,   pcbNeeded   As   Long,   pcReturned   As   Long)   As   Long  
  Private   Declare   Function   lstrlenW   Lib   "kernel32"   (ByVal   lpString   As   Long)   As   Long  
  Private   Declare   Sub   CopyMem   Lib   "kernel32"   Alias   "RtlMoveMemory"   (pTo   As   Any,   uFrom   As   Any,   ByVal   lSize   As   Long)  
  Private   Declare   Function   HeapAlloc   Lib   "kernel32"   (ByVal   hHeap   As   Long,   ByVal   dwFlags   As   Long,   ByVal   dwBytes   As   Long)   As   Long  
  Private   Declare   Function   GetProcessHeap   Lib   "kernel32"   ()   As   Long  
  Private   Declare   Function   HeapFree   Lib   "kernel32"   (ByVal   hHeap   As   Long,   ByVal   dwFlags   As   Long,   lpMem   As   Any)   As   Long  
  Dim   Ports(0   To   100)   As   PORT_INFO_2  
  Public   Function   TrimStr(strName   As   String)   As   String  
          'Finds   a   null   then   trims   the   string  
          Dim   x   As   Integer  
          x   =   InStr(strName,   vbNullChar)  
          If   x   >   0   Then   TrimStr   =   Left(strName,   x   -   1)   Else   TrimStr   =   strName  
  End   Function  
  Public   Function   LPSTRtoSTRING(ByVal   lngPointer   As   Long)   As   String  
          Dim   lngLength   As   Long  
          'Get   number   of   characters   in   string  
          lngLength   =   lstrlenW(lngPointer)   *   2  
          'Initialize   string   so   we   have   something   to   copy   the   string   into  
          LPSTRtoSTRING   =   String(lngLength,   0)  
          'Copy   the   string  
          CopyMem   ByVal   StrPtr(LPSTRtoSTRING),   ByVal   lngPointer,   lngLength  
          'Convert   to   Unicode  
          LPSTRtoSTRING   =   TrimStr(StrConv(LPSTRtoSTRING,   vbUnicode))  
  End   Function  
  'Use   ServerName   to   specify   the   name   of   a   Remote   Workstation   I.e.   "//WIN95WKST"  
  'or   leave   it   blank   ""   to   get   the   ports   of   the   local   Machine  
  Public   Function   GetAvailablePorts(ServerName   As   String)   As   Long  
          Dim   ret   As   Long  
          Dim   PortsStruct(0   To   100)   As   API_PORT_INFO_2  
          Dim   pcbNeeded   As   Long  
          Dim   pcReturned   As   Long  
          Dim   TempBuff   As   Long  
          Dim   I   As   Integer  
          'Get   the   amount   of   bytes   needed   to   contain   the   data   returned   by   the   API   call  
          ret   =   EnumPorts(ServerName,   2,   TempBuff,   0,   pcbNeeded,   pcReturned)  
          'Allocate   the   Buffer  
          TempBuff   =   HeapAlloc(GetProcessHeap(),   0,   pcbNeeded)  
          ret   =   EnumPorts(ServerName,   2,   TempBuff,   pcbNeeded,   pcbNeeded,   pcReturned)  
          If   ret   Then  
                  'Convert   the   returned   String   Pointer   Values   to   VB   String   Type  
                  CopyMem   PortsStruct(0),   ByVal   TempBuff,   pcbNeeded  
                  For   I   =   0   To   pcReturned   -   1  
                          Ports(I).pDescription   =   LPSTRtoSTRING(PortsStruct(I).pDescription)  
                          Ports(I).pPortName   =   LPSTRtoSTRING(PortsStruct(I).pPortName)  
                          Ports(I).pMonitorName   =   LPSTRtoSTRING(PortsStruct(I).pMonitorName)  
                          Ports(I).fPortType   =   PortsStruct(I).fPortType  
                  Next  
          End   If  
          GetAvailablePorts   =   pcReturned  
          'Free   the   Heap   Space   allocated   for   the   Buffer  
          If   TempBuff   Then   HeapFree   GetProcessHeap(),   0,   TempBuff  
  End   Function  
  Private   Sub   Form_Load()  
          'KPD-Team   2000  
          'URL:   http://www.allapi.net/  
          'E-Mail:   KPDTeam@Allapi.net  
          Dim   NumPorts   As   Long  
          Dim   I   As   Integer  
          'Get   the   Numbers   of   Ports   in   the   System  
          'and   Fill   the   Ports   Structure  
          NumPorts   =   GetAvailablePorts("")  
          'Show   the   available   Ports  
          Me.AutoRedraw   =   True  
          For   I   =   0   To   NumPorts   -   1  
                  Me.Print   Ports(I).pPortName  
          Next  
  End   Sub  

文章如需转载请注明:转载自: 紫灵幽梦
« 上一篇 下一篇 »

发表留言: