form1.frm

非常好的串口控件

VERSION 5.00
Object = "{37310E40-8B75-41D8-B6F5-B2BBB6549E4D}#11.0#0"; "scocomm.ocx"
Begin VB.Form Form1 
   Caption         =   "Form1"
   ClientHeight    =   4785
   ClientLeft      =   60
   ClientTop       =   450
   ClientWidth     =   9660
   LinkTopic       =   "Form1"
   ScaleHeight     =   4785
   ScaleWidth      =   9660
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command7 
      Caption         =   "Command7"
      Height          =   735
      Left            =   8640
      TabIndex        =   7
      Top             =   3720
      Width           =   855
   End
   Begin VB.CommandButton Command6 
      Caption         =   "Command6"
      Height          =   735
      Left            =   8520
      TabIndex        =   6
      Top             =   1320
      Width           =   855
   End
   Begin VB.CommandButton Command5 
      Caption         =   "Command5"
      Height          =   735
      Left            =   8640
      TabIndex        =   5
      Top             =   2280
      Width           =   855
   End
   Begin scoComm.scCOMM scCOMM1 
      Left            =   8820
      Top             =   360
      _ExtentX        =   847
      _ExtentY        =   847
      Port            =   3
      BaudRate        =   17
   End
   Begin VB.CommandButton Command4 
      Caption         =   "sendchnandeng"
      Height          =   435
      Left            =   6240
      TabIndex        =   4
      Top             =   180
      Width           =   1695
   End
   Begin VB.CommandButton Command3 
      Caption         =   "sendchn"
      Height          =   435
      Left            =   4500
      TabIndex        =   3
      Top             =   180
      Width           =   1515
   End
   Begin VB.TextBox Text2 
      Height          =   3795
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   840
      Width           =   8235
   End
   Begin VB.CommandButton Command2 
      Caption         =   "sendeng"
      Height          =   435
      Left            =   2220
      TabIndex        =   1
      Top             =   180
      Width           =   2055
   End
   Begin VB.CommandButton Command1 
      Caption         =   "open"
      Height          =   375
      Left            =   240
      TabIndex        =   0
      Top             =   240
      Width           =   855
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Public Dial_recv As String


Private Sub Command1_Click()
    If Me.scCOMM1.PortOpened Then
        Me.scCOMM1.PortClose
    Else
        Me.scCOMM1.PortOpen
    End If
    Me.Command1.Caption = IIf(Me.scCOMM1.PortOpened, "close", "open")
End Sub

Private Sub Command2_Click()
    Dim s As String
    Dim buf(0 To 1023) As Byte
    Dim nl As Long
    Dim bTmp() As Byte
    s = "AT+CMGS=""13959113180""" & vbCr
    nl = ChangeBytes(s, buf)
    bTmp = Cstr2bytes("This is an English message!")
    AddBytes buf, bTmp, nl
    nl = nl + UBound(bTmp) - LBound(bTmp) + 1
    'ReDim bTmp(0 To nL - 1) As Byte
    buf(nl) = 0
    buf(nl + 1) = 26
    ReDim bTmp(0 To nl + 1) As Byte
    AddBytes bTmp, buf, 0
    If Me.scCOMM1.PortOpened Then
        Me.scCOMM1.SendData bTmp
    End If
End Sub

Private Sub Command3_Click()
'    Dim S As String
'    S = "AT+CMGS=""13959113180""" & vbCr & fs_ToUniCodeChar("在电脑上通过ABCD") & Chr(0) & Chr(26)
    Dim buf(0 To 1023) As Byte
    Dim bTmp() As Byte
    Dim nl As Long
    nl = ChangeBytes("AT+CMGS=""13959113180""" & vbCr, buf)
    bTmp = Cstr2bytes("中兴集讯ABCD ")
    AddBytes buf, bTmp, nl
    nl = nl + UBound(bTmp) - LBound(bTmp) + 1
    buf(nl) = 0
    buf(nl + 1) = 26
    ReDim bTmp(0 To nl + 1) As Byte
    AddBytes bTmp, buf, 0
'    S = "AT+CMGS=""13959113180""" & vbCr & fs_ToUniCodeChar("在电脑上通过") & Chr(0) & Chr(26)
    If Me.scCOMM1.PortOpened Then
        Me.scCOMM1.SendDataByBytes bTmp
    End If
End Sub

Private Sub Command4_Click()
'    Dim S As String
    Dim buf(0 To 1023) As Byte
    Dim bTmp() As Byte
    Dim nl As Long
    'S = "AT+CMGS=""13609562630""" & vbCr & fs_ToUniCodeChar("这是中英文混合信息。This is an English & Chinese Message!") & Chr(0) & Chr(26)
    nl = ChangeBytes("AT+CMGS=""13609562630""" & vbCr, buf)
    bTmp = Cstr2bytes("这是中英文混合信息电脑打算法律界。This is an English & Chinese Message!")
    AddBytes buf, bTmp, nl
    nl = nl + UBound(bTmp) - LBound(bTmp) + 1
    buf(nl) = 0
    buf(nl + 1) = 26
    ReDim bTmp(0 To nl + 1) As Byte
    AddBytes bTmp, buf, 0
    If Me.scCOMM1.PortOpened Then
        Me.scCOMM1.SendData bTmp
    End If

End Sub

Private Sub Command5_Click()
'Dim s(1 To 4) As Byte
'Dim temp As String
'
's(1) = Val("&H" & " 4E")
's(2) = Val("&H" & " 2D")
's(3) = Val("&H" & " 51")
's(4) = Val("&H" & " 74")
'
'temp = fs_UniCodeToString(s)
End Sub

Private Sub Command6_Click()
Dim s As String
s = "AT+CMGR=1" & vbCr
If Me.scCOMM1.PortOpened Then
    Me.scCOMM1.SendData s
End If

End Sub

Private Sub Command7_Click()
Dim s, s1, s2 As String
Dim i, j, k, l As Integer
Dim mark As String
mark = " "
s = "12 34 56 1 567 2"
For i = 1 To Len(s)
 j = InStr(i, s, mark)
 If j > 0 Then
  s1 = Mid(s, 1, j)
  Debug.Print s1
  s = Mid(s, j + 1, Len(s) - j + 1)
  i = 0
 End If
 If j = 0 Then 'not found
 s1 = s
 Exit For
 End If
Next i
End Sub

Private Sub scCOMM1_OnComm()
Dim Dial_tip As String
Dim s As String
Dim nI As Integer
Dim temp As String

'sAnsi = StrConv(sUnicode, vbFromUnicode)  将unicode转为ansi
'sUnicode = StrConv(sAnsi, vbUnicode)  将Ansi转为Unicode
'串口端发过来的是vbunicode转好的unicode代码,unicode和ansi的英文和数字是一样的

Dial_recv = scCOMM1.ReadData '收到的数据
s = fs_AnsiToString(Dial_recv)
Dial_tip = Fun_gsm_rece(s) '所有收到的数据都放到这里处理，处理完返回

'For ni = LBound(s) To UBound(s)
'  temp = s(ni)
'  Debug.Print temp
' Next ni

'    buf(nl + 1) = 26
'    ReDim bTmp(0 To nl + 1) As Byte
'    AddBytes bTmp, buf, 0

'Dial_tip = Fun_gsm_rece(Dial_recv) '所有收到的数据都放到这里处理，处理完返回
'上面是unicode的

'Text1.Text = Text1.Text & Dial_recv
DealComm (Dial_tip) '返回处理
    
End Sub

Public Function Fun_gsm_rece(Source As String) As String
    '串口接收内容判定成帧
    Dim int_pos As Integer
    
    On Error GoTo doerrors
    
     If InStr(1, Source, "+CMGR:") <> 0 Then
     Fun_gsm_rece = "cmgr" & Source
     End If
    
    Exit Function
doerrors:
        MsgBox Err.Description, vbCritical, "错误"
End Function

Private Sub DealComm(str As String)
Dim RetrunValue As String
Dim s_number As String
Dim s_content As String
Dim s_time As String
Dim s_mark As Integer

RetrunValue = str

'AT CMGR信息逐条放入数据库(有时间)
If InStr(1, RetrunValue, "cmgr") Then
   readSim (RetrunValue)
End If

End Sub

Public Sub readSim(str As String)
Dim S_Value As String
Dim s_number As String
Dim s_index As String
Dim s_time As String
Dim s_mark As Integer
Dim s_cmgr As String
Dim s_content As String

Dim i, j, k, m, n As Integer
Dim mark, mark1, temp_vlue As String
Dim temp1, temp2, index_mark As Integer
Dim temp As String

S_Value = str

mark = ","

s_mark = 1 '接收的信息
k = 0 '记录,的位置
For i = 1 To Len(S_Value)
 k = k + 1
 j = InStr(i, S_Value, mark)
       If k = 1 Then
        s_number = Mid(S_Value, j + 2, 11)
       End If
       If k = 2 Then
        s_time = Mid(S_Value, j + 2, 19)
       End If
     If i < j Then
     i = j
     End If
Next i

'下面用到原始包，位置要以十进制数确定
'k = 0
'For n = 1 To Len(S_Value)
' k = k + 1
' m = InStr(n, S_Value, vbCrLf)
'  If k = 2 Then
'   temp1 = m '内容开始前的回车换行
'  End If
'  If k = 3 Then
'   temp2 = m  '内容结束前的回车换行
'task
   temp = Dial_recv
   s_content = fs_UniCodeToString(temp)
'   n = Len(S_Value)
'  End If
' If n < m Then
'        n = m
' End If
'Next n
      
'If s_number <> "" And s_time <> "" Then
'    strQ = "INSERT INTO SMSMNG(SMSNUMBER,SMSCONTENT,SMSTIME,SMSMARK) VALUES('" & s_number & "','" & s_content & "','" & s_time & "'," & s_mark & ")"
''  strQ = "UPDATE SIM SET SMSTIME='" & s_time & "' WHERE INDEXNUM =" & s_index & "  "
'  Set rs = cn.Execute(strQ)
'End If

Exit Sub

doError:
MsgBox "更新数据库失败"

End Sub
Public Function fs_AnsiToString(ByVal str As String) As String '为了判断标识
Dim nAscw As Long
Dim sRet As String
Dim sTemp As String
    
Dim buf() As Byte
Dim test As String
Dim hexvalue As String
    
    
Dim Str1 As String
Dim Str2 As String
Dim i, k As Long
Dim sresult As String

Dim sult As String
ReDim buf(0 To Len(str)) As Byte
buf = str
For i = LBound(buf) To UBound(buf)
  sTemp = buf(i)
'  Debug.Print sTemp
  sresult = Val(sTemp)
  sRet = ChrW(sresult)
  sult = sult & sRet
'  Debug.Print sult
Next i
 fs_AnsiToString = sult
End Function

Public Function fs_UniCodeToString(ByVal str As String) As String
Dim nAscw As Long
Dim sRet As String
Dim sTemp As String
Dim nPos, ipos As Integer
Dim buf() As Byte
Dim test As String
Dim hexvalue As String
    
    
Dim Str1 As String
Dim Str2 As String
Dim j, k, m, nCount As Long
Dim sresult As String
Dim sult, shex, scn As String
Dim cnbuf(0 To 1024) As String
Dim hbuf() As String

k = 0
buf = str

For j = LBound(buf) To UBound(buf)
 sTemp = buf(j)
 sult = sult & " " & sTemp
  
Next j
' Debug.Print sult

nCount = 0
m = 0
Dim b() As String, i%
b = Split(sult, " ")
For i = 0 To UBound(b)
     sresult = b(i)
     If sresult = "13" Then
      k = i
     End If
     If sresult = "10" And i = k + 1 Then
    '  endpos(ncount) = Chr(i)
      nCount = nCount + 1
     End If
     If nCount = 2 Then  '第二次发现回车换行,是短信内容,先放入hbuf()缓冲区
        m = m + 1
       cnbuf(m) = sresult
       Debug.Print cnbuf(m)
     End If
 Next i

ReDim hbuf(1 To m) As String
k = 0
For j = 1 To m
    hbuf(j) = cnbuf(j)
    If j > 1 And j < m Then
       hexvalue = Hex(Val(hbuf(j)))
            If Len(hexvalue) = 1 Then
              hexvalue = "0" & hexvalue
            End If
        k = k + 1
        If k = 1 Then
          Str1 = hexvalue
        Else
          Str2 = hexvalue
          test = Str1 & Str2
          nAscw = "&H" & test
          shex = Val(nAscw)
          sRet = ChrW(shex)
          scn = scn & sRet
          k = 0
       End If

    End If
Next j
          Debug.Print scn

 fs_UniCodeToString = sult
End Function