form1.frm

该程序是不占用资源的串口数据捕捉.同一台计算机中,再有其他应用程序或设备同时占用一个或多个串口的情况下,捕捉这些串口的通信数据

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   5745
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   8190
   LinkTopic       =   "Form1"
   ScaleHeight     =   5745
   ScaleWidth      =   8190
   StartUpPosition =   3  'Windows Default
   Begin VB.OptionButton Option2 
      Caption         =   "COM2:"
      Height          =   495
      Left            =   4680
      TabIndex        =   7
      Top             =   2520
      Width           =   1215
   End
   Begin VB.OptionButton Option1 
      Caption         =   "COM1:"
      Height          =   495
      Left            =   4680
      TabIndex        =   6
      Top             =   1980
      Value           =   -1  'True
      Width           =   1215
   End
   Begin VB.CommandButton Command5 
      Caption         =   "关闭COM1"
      Height          =   495
      Left            =   4620
      TabIndex        =   5
      Top             =   4680
      Width           =   1215
   End
   Begin VB.CommandButton Command4 
      Caption         =   "打开COM1"
      Height          =   495
      Left            =   4620
      TabIndex        =   4
      Top             =   4140
      Width           =   1215
   End
   Begin VB.CommandButton Command3 
      Caption         =   "串口配置"
      Height          =   495
      Left            =   6120
      TabIndex        =   3
      Top             =   2220
      Width           =   1635
   End
   Begin VB.CommandButton Command2 
      Caption         =   "取第一个可用串口"
      Height          =   495
      Left            =   4620
      TabIndex        =   2
      Top             =   1080
      Width           =   3195
   End
   Begin VB.CommandButton Command1 
      Caption         =   "取所有串口"
      Height          =   495
      Left            =   4620
      TabIndex        =   1
      Top             =   420
      Width           =   3195
   End
   Begin VB.ListBox List1 
      Height          =   4935
      Left            =   300
      TabIndex        =   0
      Top             =   360
      Width           =   3975
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ?1996-2007 VBnet, Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce
'               or publish this code on any web site,
'               online service, or distribute as source
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'端口句柄,关闭程序记得释发
Private hFakePort As Long

Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const OPEN_EXISTING = 3
Private Const FILE_ATTRIBUTE_NORMAL = &H80

Private Type SECURITY_ATTRIBUTES
   nLength As Long
   lpSecurityDescriptor As Long
   bInheritHandle As Long
End Type

Private Declare Function CreateFile Lib "kernel32" _
   Alias "CreateFileA" _
  (ByVal lpFileName As String, _
   ByVal dwDesiredAccess As Long, _
   ByVal dwShareMode As Long, _
   lpSecurityAttributes As SECURITY_ATTRIBUTES, _
   ByVal dwCreationDisposition As Long, _
   ByVal dwFlagsAndAttributes As Long, _
   ByVal hTemplateFile As Long) As Long
   
Private Declare Function CloseHandle Lib "kernel32" _
  (ByVal hObject As Long) As Long

Private Declare Function ConfigurePort Lib "winspool.drv" _
   Alias "ConfigurePortA" _
  (ByVal pName As Any, _
   ByVal hwnd As Long, _
   ByVal pPortName As String) As Long

Private Sub Form_Unload(Cancel As Integer)

   If hFakePort > 0 Then
      CloseHandle hFakePort
   End If
   
End Sub


Private Sub Command1_Click()
   '取所有串口
   List1.Clear
   Call GetInstalledCOMPorts(List1)
   
End Sub


Private Sub Command2_Click()
   '取第一个可用串口
   Dim nPort As Long
   
   List1.Clear
   nPort = GetFirstAvailableCOMPort()
   
   If nPort > 0 Then
      List1.AddItem "COM" & nPort & "  是第一个可用串口"
   End If
   
End Sub


Private Sub Command3_Click()
   '配置串口(COM1,COM2)
   Dim Port As Long
   Dim result As Boolean
   
   List1.Clear
   
   Port = GetSelectedOptionIndex()
   
   If COMConfigPort(Port) = 1 Then
      List1.AddItem "COM" & Port & "  - 用户按 OK"
   Else
      List1.AddItem "COM" & Port & "  - 用户按 Cancel"
   End If

End Sub


Private Sub Command4_Click()

   '打开串口1
   Call OpenPort("COM1:")

   Command4.Enabled = hFakePort = 0
   Command5.Enabled = hFakePort <> 0

End Sub


Private Sub Command5_Click()
'关闭串口
   If hFakePort <> 0 Then
      CloseHandle hFakePort
      hFakePort = 0
   End If
   
   Command4.Enabled = hFakePort = 0
   Command5.Enabled = hFakePort <> 0
   
End Sub


Private Function COMCheckPort(Port As Long) As Boolean

  '端口句柄
   Dim hPort As Long
   
  '端口名称
   Dim sPort As String
   Dim sa As SECURITY_ATTRIBUTES
  
   If Val(Port) > 0 Then

     '注意名称写法 (e.g. not COM1:)
      sPort = "\\.\COM" & Port
      
     '尝试打开
      hPort = CreateFile(sPort, _
                         0, _
                         FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                         sa, _
                         OPEN_EXISTING, _
                         FILE_ATTRIBUTE_NORMAL, _
                         0)
       
     '及时关闭
      If hPort Then CloseHandle hPort
      
      '若串口可用,返回true
      COMCheckPort = hPort > 0
       
   Else
      COMCheckPort = False
   End If
   
End Function


Private Function COMConfigPort(Port As Long) As Boolean

   Dim sPort As String
   
   If Val(Port) > 0 Then
       
     '打开串口参数配置对话框
     
     '第一个参数主机名,空串或 ByRef 0& 代表本机
     '第三个参数必须类似 "COM<数字>:" 格式
      sPort = "COM" & Port & ":"
      COMConfigPort = ConfigurePort(vbNullString, Me.hwnd, sPort)
            
   End If

End Function


Private Function GetFirstAvailableCOMPort() As Long

   Dim Port As Long
   
   '取第一个可用串口
   For Port = 1 To 16

      If COMCheckPort(Port) = True Then
         GetFirstAvailableCOMPort = Port
         Exit Function
      End If
   
   Next Port
   
  '没有可用串口
   GetFirstAvailableCOMPort = 0

End Function


Private Function GetInstalledCOMPorts(lst As ListBox) As Long

   Dim Port As Long
   
   '取所有可能的串口
   For Port = 1 To 16
   
      If COMCheckPort(Port) Then
         lst.AddItem "COM" & Port & "  可用"
      Else
         lst.AddItem "COM" & Port & "  (不可用或不存在)"
      End If
      
   Next

End Function


Private Function GetSelectedOptionIndex() As Long

  '返回选择的单选按钮序号

   GetSelectedOptionIndex = Option1.Value * -1 Or _
                            Option2.Value * -2
                            
End Function

'打开串口
Private Function OpenPort(sPort As String) As Boolean

   Dim sa As SECURITY_ATTRIBUTES
  
   hFakePort = CreateFile(sPort, _
                          0, _
                          FILE_SHARE_READ Or FILE_SHARE_WRITE, _
                          sa, _
                          OPEN_EXISTING, _
                          FILE_ATTRIBUTE_NORMAL, _
                          0)
    
   OpenPort = hFakePort <> -1
    
End Function