sms.frm

可以收发SMS的VB源码.需要支持COM口的GSM模块.可以进行收发的管理.

         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H8000000E&
      Height          =   285
      Left            =   3870
      TabIndex        =   14
      Top             =   2055
      Width           =   2055
   End
   Begin VB.Label Label4 
      BackStyle       =   0  'Transparent
      Caption         =   "闪烁"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H8000000E&
      Height          =   285
      Left            =   3750
      TabIndex        =   8
      Top             =   165
      Width           =   480
   End
   Begin VB.Label Label3 
      BackStyle       =   0  'Transparent
      Caption         =   "输入要发送的号码"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H8000000E&
      Height          =   285
      Left            =   225
      TabIndex        =   5
      Top             =   1245
      Width           =   2055
   End
   Begin VB.Label Label2 
      BackStyle       =   0  'Transparent
      Caption         =   "(最多160字符,70中文字)"
      ForeColor       =   &H8000000E&
      Height          =   285
      Left            =   1020
      TabIndex        =   2
      Top             =   180
      Width           =   2025
   End
   Begin VB.Label Label1 
      BackStyle       =   0  'Transparent
      Caption         =   "输入信息"
      BeginProperty Font 
         Name            =   "宋体"
         Size            =   10.5
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H8000000E&
      Height          =   285
      Left            =   165
      TabIndex        =   0
      Top             =   165
      Width           =   1170
   End
   Begin VB.Menu txtMenu 
      Caption         =   "文本框菜单"
      Visible         =   0   'False
      Begin VB.Menu txtCopy 
         Caption         =   "复制"
         Checked         =   -1  'True
      End
      Begin VB.Menu txtPaste 
         Caption         =   "粘帖"
         Checked         =   -1  'True
      End
      Begin VB.Menu txtCut 
         Caption         =   "剪切"
         Checked         =   -1  'True
      End
   End
End
Attribute VB_Name = "frmSMS"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Function TimeDelay(time As Long) As Boolean
Dim t As Integer


'TimeDelay = False
t = GetTickCount()
Do
DoEvents
Loop Until (GetTickCount() - t) > time
'TimeDelay = True
End Function

Private Sub Command4_Click()

If MSComm1.PortOpen = True Then
MSComm1.PortOpen = False
End If
Unload Me
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbRightButton Then
txtMenu.Visible = True
PopupMenu txtMenu
End If
End Sub

Private Sub MSComm1_OnComm()
Dim i%
Dim ins$, c$
Dim parity As Byte
Dim buf$

ins = ""

Const hexcode = "0123456789ABCDEF"

Select Case MSComm1.CommEvent
    Case comEvCD
        'If MSComm1.CDHolding Then
            'spCD.FillColor = RGB(255, 0, 0)
        'Else
        '    spCD.FillColor = RGB(0, 255, 0)
        'End If
   
   Case comEvCTS
    ' If MSComm1.CTSHolding Then
     '   spCTS.FillColor = RGB(255, 0, 0)
    'Else
     '   spCTS.FillColor = RGB(0, 255, 0)
   ' End If
   
   Case comEvDSR
    '    If MSComm1.DSRHolding Then
     '       spDSR.FillColor = RGB(255, 0, 0)
      '   Else
       '     spDSR.FillColor = RGB(0, 255, 0)
       ' End If
   
   Case comEvRing
        'If spRI.FillColor = RGB(0, 255, 0) Then
         '   spRI.FillColor = RGB(255, 0, 0)
         'Else
          '  If spRI.FillColor = RGB(255, 0, 0) Then
           '     spRI.FillColor = RGB(0, 255, 0)
            'End If
        'End If
  
  Case comEvReceive
        'Timer1.Enabled = False
        'MSComm1.InputLen = 1
       ' MSComm1.RThreshold = 0
  
  MSComm1.RThreshold = 0
  
        buf = MSComm1.Input
     
     'Select Case buf(0)
     'Case buf(0) = &H4
     ' Do
     ' Loop Until MSComm1.InBufferCount >= 1
      
      ' buf = MSComm1.Input
     
      'If buf(0) = &H60 Then
      '   MSComm1.Output = Chr(&H6)
      'End If
     ' If buf(0) = &H40 Then
      '  MSComm1.Output = Chr(&H4)
      'End If
        
      
       'MSComm1.RThreshold = 1
       'MSComm1.InputLen = 0
       'Timer1.Enabled = True
             
  'Case buf(0) = &H6
   '    MSComm1.Output = Chr(RCSU_END)
  '
   '    txdCorrect = True
    '   MSComm1.RThreshold = 1
     '  MSComm1.InputLen = 0
 ' Case buf(0) = &H2
    '    Do
        
     '    If MSComm1.InBufferCount >= 1 Then
      '    buf = MSComm1.Input
'          ins = ins + Chr(buf(0))
 '        End If
  '      Loop Until TimeDelay(100) Or buf(0) = &H3
   '
    '    If buf(0) <> &H3 Then
     '      MSComm1.Output = &H5
      '     MSComm1.RThreshold = 1
       '    MSComm1.InputLen = 0
        '   Exit Sub
      '  End If
      '   Do
      '   Loop Until MSComm1.InBufferCount >= 1 Or TimeDelay(40)
         
       '  buf = MSComm1.Input
       '  pariy = buf(0)
         
        
   '  If CheckSum(ins, parity) Then
   '       rxdCorrect = True
    '      MSComm1.Output = Chr(ACK)
          
     '     If InStr(1, ins, ENABLE_CONTROL) > 1 Then
      '       Control = True
      '       spRequest.FillColor = RGB(255, 0, 0)
       '   End If
        '  If InStr(1, ins, DISABLE_CONTROL) > 1 Then
       '      Control = False
       '      spRequest.FillColor = RGB(0, 255, 0)
       '   End If
          
        '  If InStr(1, ins, STATE) > 1 Then
       '      If Mid(ins, 20, 3) <> "292" Then
       '      MsgBox "ALARM"
       '      End If
       '
       '       c = Mid(ins, 25, 1)
       '       Select Case c
       '         Case "2"
       '            spTX1.FillColor = RGB(255, 0, 0)
       '         Case "4"
       '            spTX1.FillColor = RGB(0, 255, 0)
        '        Case "8"
       '            spTX1.FillColor = RGB(0, 0, 0)
        '        Case "0"
         '           spTX1.FillColor = RGB(255, 255, 255)
        '        End Select
                
        '      c = Mid(ins, 25, 1)
              
         '       Select Case c
         '       Case "2"
         '          spTX2.FillColor = RGB(255, 0, 0)
          '      Case "4"
          '         spTX2.FillColor = RGB(0, 255, 0)
          '      Case "8"
          '         spTX2.FillColor = RGB(0, 0, 0)
          '      Case "0"
           '         spTX2.FillColor = RGB(255, 255, 255)
           '     End Select
              
        '  End If
          
   
   txtReceive.SelStart = Len(txtReceive.Text)
   txtReceive.SelText = buf
   
    
  End Select

MSComm1.RThreshold = 1
MSComm1.InputLen = 0

End Sub