module1.bas

通过串口与手机模块收发短信。已经用sim100测试过

                    Mid(TimeDeCode, 3, 2) & "-" & _
                    Mid(TimeDeCode, 5, 2) & " " & _
                    Mid(TimeDeCode, 7, 2) & ":" & _
                    Mid(TimeDeCode, 9, 2) & ":" & _
                    Mid(TimeDeCode, 11, 2) & " " & _
                    Mid(TimeDeCode, 13, 2) & "时区   "

End Function


Function D7byCode(D7byTxt As String) As String   '转化成HEX字符串
     Dim Temp As Integer
     Dim mask As Integer
     Dim i1 As Integer
     Dim i2 As Integer
     Dim Tempstr1 As String
     Dim Tempstr2 As Integer
     
     D7byCode = ""
       
       
       Do While (Len(D7byTxt) >= 8)
        DoEvents
       mask = 0
          Tempstr1 = Mid(D7byTxt, 1, 8)
          D7byTxt = Mid(D7byTxt, 9)
       For i1 = 1 To 7
       Temp = Asc(Mid(Tempstr1, i1 + 1, 1))
       mask = 1 + 2 * mask
       Temp = Temp And mask
            For i2 = 1 To (8 - i1)
            Temp = Temp * 2
            Next i2
            Tempstr2 = Asc(Mid(Tempstr1, i1, 1))
            For i2 = 1 To i1 - 1
            Tempstr2 = Int(Tempstr2 \ 2)
            Next i2
       Temp = Temp + Tempstr2
       
       D7byCode = D7byCode & AscToHex(Temp)
       Next i1
       Loop
       
       If (Len(D7byTxt) < 8 And Len(D7byTxt) > 0) Then
       mask = 0
            For i1 = 1 To Len(D7byTxt) - 1
       Temp = Asc(Mid(D7byTxt, i1 + 1, 1))
       mask = 1 + 2 * mask
       Temp = Temp And mask
            For i2 = 1 To (8 - i1)
            Temp = Temp * 2
            Next i2
        Tempstr2 = Asc(Mid(D7byTxt, i1, 1))
        
        
            For i2 = 1 To i1 - 1
            Tempstr2 = Int(Tempstr2 \ 2)
            Next i2
       Temp = Temp + Tempstr2
       D7byCode = D7byCode & AscToHex(Temp)
       Next i1
       Tempstr2 = Asc(Mid(D7byTxt, i1, 1))
            For i2 = 1 To i1 - 1
            Tempstr2 = Int(Tempstr2 \ 2)
            Next i2
       End If
       D7byCode = D7byCode & AscToHex(Tempstr2)
End Function

Function D7byDeCode(D7byTxt As Variant) As String     '转化成ASC码字符串
     Dim Temp As Integer
     Dim mask As Integer
     Dim i1 As Integer
     Dim i2 As Integer
     Dim Tempstr1 As String
     Dim Tempstr2 As Variant
     
     D7byDeCode = ""
       
       
       Do While (UBound(D7byTxt) > 6)
       DoEvents
          mask = 0
          
         Tempstr2 = D7byTxt
        D7byDeCode = D7byDeCode & Chr(127 And D7byTxt(0))
        D7byTxt = ArrayMov(D7byTxt, 7)
       For i1 = 0 To 5
       Temp = Tempstr2(i1)
       mask = mask + 2 ^ (7 - i1)
       
       Temp = Temp And mask
       
            Temp = Int(Temp \ (2 ^ (7 - i1)))
         
           
            Tempstr1 = Tempstr2(i1 + 1)
            
            Tempstr1 = Tempstr1 * (2 ^ (i1 + 1))
            Tempstr1 = Tempstr1 And 127
       Temp = Temp + Tempstr1
       
       D7byDeCode = D7byDeCode & Chr(Temp)
       
       Next i1
       D7byDeCode = D7byDeCode & Chr(Int(Tempstr2(i1) \ 2))
       Loop
       
       If (UBound(D7byTxt) <= 6) Then
      mask = 0
        D7byDeCode = D7byDeCode & Chr(127 And D7byTxt(0))
       For i1 = 0 To UBound(D7byTxt) - 1
       Temp = D7byTxt(i1)
       mask = mask + 2 ^ (7 - i1)
       Temp = Temp And mask
       
            Temp = Int(Temp \ (2 ^ (7 - i1)))
         
           
            Tempstr1 = D7byTxt(i1 + 1)
            
            Tempstr1 = Tempstr1 * (2 ^ (i1 + 1))
            Tempstr1 = Tempstr1 And 127
           
       Temp = Temp + Tempstr1
       
       D7byDeCode = D7byDeCode & Chr(Temp)
       Next i1
    
       End If
End Function
Function ArrayMov(ArrayOld As Variant, Loca As Integer) As Variant

            Dim ArrLon As Integer
            Dim ArrNew() As Byte
            Dim i As Integer
            ArrLon = UBound(ArrayOld)
            ReDim ArrNew(ArrLon - Loca - 1)
            For i = 0 To ArrLon - Loca - 1
               ArrNew(i) = ArrayOld(Loca + i)
            Next i
            ArrayMov = ArrNew()
            
End Function
Public Function AddArrayTotal(Array1 As Variant, Array2 As Variant) As Variant
      Dim TempTotalArray() As Byte
      Dim TotalLen As Integer
      Dim TCount1 As Integer
        TotalLen = UBound(Array1) + UBound(Array2) + 1
        ReDim TempTotalArray(TotalLen)
        For TCount1 = 0 To UBound(Array1)
           TempTotalArray(TCount1) = Array1(TCount1)
        Next TCount1
        For TCount1 = UBound(Array1) + 1 To TotalLen
           TempTotalArray(TCount1) = Array2(TCount1 - UBound(Array1) - 1)
        Next TCount1
        
        AddArrayTotal = TempTotalArray()
End Function

Function DUcs2Code(DUxs2Txt As String) As String
           Dim Temp As String
           Dim TempH As String
           Dim TempL As String
           Dim i1 As Integer
           Dim a1 As String
           DUcs2Code = ""
           
           For i1 = 1 To Len(DUxs2Txt)
           
           Temp = Mid(DUxs2Txt, i1, 1)
           
           If Abs(AscW(Temp)) < 256 Then
           
               TempH = "00"
               TempL = AscToHex(AscW(Temp))
               Temp = TempH & TempL
           Else
           
               Temp = Hex(AscW(Temp))
               
           End If
           
           
           
           DUcs2Code = DUcs2Code & Temp
           
           Next i1
End Function
Function DUcs2DeCode(DUxs2Txt As String) As String

           Dim Temp As String
           Dim TempH As Long
           Dim TempL As Long
           Dim i1 As Integer
           
           DUcs2DeCode = ""
           
           For i1 = 1 To Len(DUxs2Txt)
           Temp = Mid(DUxs2Txt, i1, 2)
           TempH = HexToAsc(Temp)
           i1 = i1 + 3
           Temp = Mid(DUxs2Txt, i1 - 1, 2)
           TempL = HexToAsc(Temp)
           
           Temp = ChrW(TempH * 256 + TempL)
           DUcs2DeCode = DUcs2DeCode & Temp
           
           Next i1
           
End Function

Public Sub SerialInit()
On Error GoTo SerialError
    Dim SeriDataBase As Serial_Struct
        
  SeriDataBase.Ser_Rat = GetINI("serial", "byterate", App.Path & "\sysini\phisical.ini")
  SeriDataBase.Ser_Comport = GetINI("serial", "comport", App.Path & "\sysini\phisical.ini")
  SeriDataBase.Ser_Datalen = GetINI("serial", "datalen", App.Path & "\sysini\phisical.ini")
  SeriDataBase.Ser_Stoplen = GetINI("serial", "stoplen", App.Path & "\sysini\phisical.ini")
  SeriDataBase.Ser_Judge = GetINI("serial", "judge", App.Path & "\sysini\phisical.ini")
  SeriDataBase.Ser_Curcon = GetINI("serial", "curcon", App.Path & "\sysini\phisical.ini")
  
  If Frm_Main.MSComm1.PortOpen = True Then
       Frm_Main.MSComm1.PortOpen = False
  End If
    
  Select Case SeriDataBase.Ser_Comport
    Case "COM1"
    Frm_Main.MSComm1.CommPort = 1
     Case "COM2"
    Frm_Main.MSComm1.CommPort = 2
    Case "COM3"
    Frm_Main.MSComm1.CommPort = 3
     Case "COM4"
    Frm_Main.MSComm1.CommPort = 4
    Case "COM5"
    Frm_Main.MSComm1.CommPort = 5
     Case "COM6"
    Frm_Main.MSComm1.CommPort = 6
  End Select
  
  Frm_Main.MSComm1.Settings = SeriDataBase.Ser_Rat & "," _
                          & SeriDataBase.Ser_Judge & "," _
                        & SeriDataBase.Ser_Datalen & "," _
                        & SeriDataBase.Ser_Stoplen
  Frm_Main.MSComm1.DTREnable = True
  Frm_Main.MSComm1.RTSEnable = True
  Frm_Main.MSComm1.InBufferCount = 0
  Frm_Main.MSComm1.InBufferSize = 4096
  Frm_Main.MSComm1.OutBufferSize = 4096
  Frm_Main.MSComm1.InputLen = 1
  Frm_Main.MSComm1.InputMode = comInputModeBinary
  Frm_Main.MSComm1.OutBufferCount = 0
  Frm_Main.MSComm1.RThreshold = 1
  Frm_Main.MSComm1.SThreshold = 0
     
  If Frm_Main.MSComm1.PortOpen = False Then
       Frm_Main.MSComm1.PortOpen = True
  End If
  
  
  Call FlashMessage("串口初始化成功")
   
  Exit Sub
  
SerialError:  MsgBox Err.Description
  Call FlashMessage("串口初始化失败")
End Sub
Public Sub FlashMessage(Message As String)
  
   Dim i1 As Integer
   Dim i2 As Integer
   Dim i3 As Integer
   Dim i4 As Integer
   i3 = 0
   i4 = -1
    
     For i1 = 0 To UBound(MessaArray)  '寻找最大的队列号
          i2 = MessaArray(i1).MesOrd
          If i3 < i2 Then
            i3 = i2
          End If
     Next i1
   
   For i1 = 0 To UBound(MessaArray)   '寻找队列空位
      If MessaArray(i1).MesVal = False Then
          i4 = i1
          Exit For
      End If
   Next i1
   
  If i4 = -1 Then                     '找不到空位则添加空位
   ReDim Preserve MessaArray(UBound(MessaArray) + 1)
       i4 = UBound(MessaArray)
  End If
  
  
    'i4为空位号
    'i3为队列号
    MessaArray(i4).MesOrd = i3 + 1
    MessaArray(i4).Message = Message
    MessaArray(i4).MesVal = True
    
    MesArray = MesArray + 1
      
    Frm_Main.TimerMessa.Enabled = True
      
End Sub


Public Sub TotalSenStr()
  Select Case TransWay
     Case "direct"
     Case "gsm"
     Case "gprs"
  End Select
End Sub


Private Sub GsmMesSend()
  Static GsmMesSend_proloc As Boolean
   If Not GsmMesSend_proloc Then
     GsmMesSend_proloc = True
   Dim GsmMesSend_i11 As Integer
   Dim GsmMesSend_i12 As Integer
   Dim GsmMesSend_i13 As Integer
   Dim GsmMesSend_i15 As Integer
   Dim GsmMesSend_i16 As Integer
   Dim GsmMesSend_Temp As Integer
   
   Dim GsmMesRev_i11 As Integer
   Dim GsmMesRev_i12 As Integer
   Dim GsmMesRev_i13 As Integer
   Dim GsmMesRev_i15 As Integer
   Dim GsmMesRev_i16 As Integer
   Dim GsmMesRev_Temp As Integer
   
     Do While (RevArray > 0 Or SenArray > 0)
        DoEvents
        Frm_Main.ShockwaveFlash1.Play
        If RevArray = 0 Then
             
                GsmMesSend_i13 = 1
                
                    For GsmMesSend_i11 = 0 To UBound(GsmSenArray)  '寻找一个有效的队列号
                    
                         GsmMesSend_i12 = GsmSenArray(GsmMesSend_i11).Sen_Order
                         
                        If GsmMesSend_i12 >= GsmMesSend_i13 Then
                           GsmMesSend_i15 = GsmMesSend_i12
                           GsmMesSend_i16 = GsmMesSend_i11
                           Exit For
                        End If
                        
                    Next GsmMesSend_i11
                    
                    For GsmMesSend_i11 = 0 To UBound(GsmSenArray)  '寻找最小的队列号
                    
                         GsmMesSend_i12 = GsmSenArray(GsmMesSend_i11).Sen_Order
                         
                       If GsmMesSend_i12 < GsmMesSend_i15 And GsmMesSend_i12 > 0 Then
                         GsmMesSend_i15 = GsmMesSend_i12
                         GsmMesSend_i16 = GsmMesSend_i11
                       End If
                    
                        
                    Next GsmMesSend_i11
                                                           
        
                        Gsm_CommonRev_Way = "Gsm_MesSenCmd"
                        GSM_Cmd_ResWaitSuc = False
                        GSM_Cmd_ProcessOver = False
             If Frm_Main.MSComm1.PortOpen Then
                Frm_Main.MSComm1.Output = "at+cmgs=" & GsmSenArray(GsmMesSend_i16).Sen_len & Chr(13)
             End If
                    
                    Frm_Main.T_GSM_CmdSenPro = True