datatransmit.frm

适合乡镇供电所使用电费处理系统v3 软件

      Loop
      Close #3
      Label10.Caption = "系统正在把接收的数据送入数据库......"
      Label10.Refresh
      DataTransmit.Refresh
      PrBar1.Max = II
      PrBar1.Min = 0
      Open App.Path & "\DATACH.TXT" For Input As #3
      Input #3, StrTemp
      Xcode = "0" & Mid(Trim(StrTemp), 5, 2)    '传输镇代码
      Ccode = "0" & Mid(Trim(StrTemp), 7, 2)    '传输村代码
      NQ = Mid(Trim(StrTemp), 1, 2) & "00"
      Yq = Mid(Trim(StrTemp), 3, 2)
      Close #3
      Open App.Path & "\TX.TXT" For Input As #3
      i = 1
      For i = 1 To II - 1
            Input #3, StrTemp
            '1
            'Set MdbR = NdMd.OpenRecordset("select * from 用户电费  where 年份='" & Trim(NQ) & "' and 月份='" & Trim(Yq) & "' and 组合编码='" & Xcode & Ccode & Mid(StrTemp1, 1, 4) & "'")
            Set MdbR = NdMd.OpenRecordset("select * from 用户电费  where 年份='" & Trim(NQ) & "' and 月份='" & Trim(Yq) & "' and 组合编码='" & Xcode & Ccode & Right("0000" + Trim(Str(i)), 4) & "'")
            If MdbR.RecordCount = 0 Then
               CSS = Val(StrTemp)
            Else
               MdbR.Edit
               MdbR.Fields!本期示数 = Mid(StrTemp, 13, 6)
               
               MdbR.Update
            End If
         PrBar1.Value = i
      Next
      Close #3
      Label10.Visible = False
      PrBar1.Value = 0
      PrBar1.Visible = False
      Screen.MousePointer = 0
      MsgBox "本次数据通讯成功!", vbInformation    '& vbCrLf & Xcode & Ccode & "村" & NQ & "年" & Yq & "月" & "共上载：" & (II * 4) - 8 & "户!", vbInformation
End Sub

'//////////////将3型数据写入数据库中//////////////
Sub WirteData1()
      Dim i As Integer, II As Integer, BJ As Integer, JH As Integer
      Dim StrTemp As String, StrTemp1 As String, BB As String, STRT As String, zbs As String, ychs As String
      On Error GoTo MiscError
      Open App.Path & "\Tx.TXT" For Input As #1
      Input #1, StrTemp1
      zbs = Mid(StrTemp1, 14, 3) '提取总户数
      ychs = Mid(StrTemp1, 22, 3) '提取已抄
      II = 0
      StrTemp = ""
      Do Until eof(1)
         Input #1, STRT
         StrTemp = StrTemp & STRT
         II = II + 1
      Loop
      Close #1
      II = 1
      If FileExists(App.Path & "\TX.txt") Then Kill App.Path & "\TX.txt"
      For II = 1 To Len(StrTemp) \ 18
          If II = 1 Then
             BB = Mid(StrTemp, 1, 18)
             Open App.Path & "\TX.TXT" For Append As #2
             Print #2, BB
             Close #2
          End If
          If II = 2 Then
             BB = Mid(StrTemp, 19, 18)
             Open App.Path & "\TX.TXT" For Append As #2
             Print #2, BB
             Close #2
             BJ = 65 + 18
             JH = 19
          End If
          If II > 2 Then
             BB = Mid(StrTemp, JH + 18, 18)
             Open App.Path & "\TX.TXT" For Append As #2
             Print #2, BB
             Close #2
             JH = JH + 18
          End If
      Next
      
      Close #1
      Open App.Path & "\TX.TXT" For Input As #3
      II = 1
      Do Until eof(3)
         Input #3, StrTemp
         II = II + 1
      Loop
      Close #3
      Label10.Caption = "系统正在把接收的数据送入用户档案库..."
      Label10.Refresh
      DataTransmit.Refresh
      PrBar1.Max = II
      PrBar1.Min = 0
      Xcode = "0" & Mid(Trim(StrTemp1), 5, 2)    '传输镇代码
      Ccode = "0" & Mid(Trim(StrTemp1), 7, 2)    '传输村代码
      NQ = Mid(Year(Date), 1, 2) & Mid(Trim(StrTemp1), 1, 2)
      GzYue = Mid(Trim(StrTemp1), 3, 2)
      Call sTruInfo
      Open App.Path & "\TX.TXT" For Input As #3
      i = 1
      For i = 1 To II - 1
            Input #3, StrTemp
            If Mid(StrTemp, 13, 6) <> "FFFFFF" Then
                Set MdbR = NdMd.OpenRecordset("select 用户电费.辅助号,用户电费.[" & aa & "] AS 本期示数 from 用户电费 where 辅助号='" & Mid(StrTemp, 1, 6) & "' AND 镇村代码='" & Xcode & Ccode & "'")
                If MdbR.RecordCount = 0 Then
                   CSS = Val(StrTemp)
                Else
                   MdbR.Edit
                      If Mid(Mid(StrTemp, 13, 6), 1, 2) <> "FF" Then
                         MdbR.Fields!本期示数 = Mid(StrTemp, 13, 6)
                         MdbR.Update
                      End If
                End If
            End If
         PrBar1.Value = i
         DoEvents
      Next
      Close #3
      Label10.Visible = False
'      AniGIF3.Visible = False
      PrBar1.Value = 0
      PrBar1.Visible = False
      Screen.MousePointer = 0
      MsgBox "本次上载数据" & Val(zbs) & "户,抄录户数" & Val(ychs) & "户,请计算电费!", vbInformation    '& vbCrLf & Xcode & Ccode & "村" & NQ & "年" & Yq & "月" & "共上载：" & (II * 4) - 8 & "户!", vbInformation
      Exit Sub

MiscError:
    MsgBox "Error " & Err.Number & _
        vbCrLf & Err.Description
    Exit Sub
End Sub


Sub DataCrea3()
    Dim Nd As Database, Md As Recordset    '全局库名，表名
    Dim i As Integer, II As Integer
    Dim Txstr As String, Sqltr As String, STRCD As Integer, A As String
    On Error GoTo MiscError
    Label9.Visible = True
    Label9.Caption = "电脑正在生成下载数据，请稍候..."
    Label9.Refresh
    PrBar2.Visible = True
    Set Md = NdMd.OpenRecordset("SELECT 用户电费.辅助号,用户电费.用户表码,用户电费.往期平均,用户电费.[" & AAA & "] AS 上期示数 From 用户电费 WHERE 用户电费.镇村代码='" & UserSeek & "' and 用户电费.辅助号<>'' order by 用户电费.组合编码 asc")
    If Not Md.eof Then
        Md.MoveFirst
    End If
    If Md.RecordCount <> 0 Then
        PrBar2.Min = 0
        PrBar2.Max = Md.RecordCount - 1
        Md.MoveFirst
        If FileExists(App.Path & "\Tx.txt") Then Kill App.Path & "\Tx.txt"
        Open App.Path & "\Tx.txt" For Append As #1
        Print #1, Mid(GzNian, 3, 2) & GzYue & Mid(XzCode, 2, 2) & Mid(XcCode, 2, 2) & "FFFF" & Format(Md.RecordCount, "0000") & Format(Md.RecordCount, "0000") & "0000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF"
        Close #1
        For i = PrBar2.Min To PrBar2.Max
           ' If i = 260 Then Stop
            If IsNull(Md.Fields!辅助号) = False Then
               Txstr = Txstr & Format(Md.Fields!辅助号, "000000") & IIf(IsNull(Md.Fields!上期示数) = True, "000000", Right("000000" + Md.Fields!上期示数, 6)) & "FF" & IIf(IsNull(Md.Fields!往期平均) = True, "0000", Right("000000" + IIf(IsNull(Md.Fields!上期示数) = True, "000000", Right("000000" + Md.Fields!上期示数, 6)), 4))
            End If
            Md.MoveNext
            PrBar2.Value = i
            DoEvents
        Next i
        STRCD = Len(Trim(Txstr))
        STRCD = STRCD \ 64
        PrBar2.Value = 0
        PrBar2.Min = 0
        PrBar2.Max = STRCD
        For i = PrBar2.Min To PrBar2.Max
            If i = 0 Then
               A = Mid(Txstr, 1, 64)
               Open App.Path & "\Tx.txt" For Append As #1
               Print #1, A
               Close #1
            End If
            If i = 1 Then
               A = Mid(Txstr, 65, 64)
               Open App.Path & "\Tx.txt" For Append As #1
               Print #1, A
               Close #1
            End If
            If i > 1 Then
               A = Mid(Txstr, 64 * i + 1, 64)
               If Len(A) <> 64 Then
                   A = Mid(A & "FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF", 1, 64)
               End If
               Open App.Path & "\Tx.txt" For Append As #1
               Print #1, A
               Close #1
            End If
            PrBar2.Value = i
            DoEvents
        Next
        
        Screen.MousePointer = 0
        PrBar2.Value = PrBar2.Min
        
    Else
        MsgBox "库中无数据，无法生成下传文件！", vbCritical
        PrBar2.Visible = False
        Label9.Visible = False
        Exit Sub
    End If
  Exit Sub

MiscError:
    MsgBox "Error " & Err.Number & _
        vbCrLf & Err.Description
    Exit Sub
End Sub


'///////////事件触发//////////////
Private Sub MSComm1_OnComm()
   Dim EVMsg, ERMsg, BuffStr, Txstr As String, SCTXT  As String
   Dim Arr() As Byte
   Dim rBuffer As Variant
   Dim i As Integer
   Dim PariCode As String, parM As String
   'Dim cl
   Select Case MSComm1.CommEvent
          Case comEvReceive
               MSComm1.InputMode = comInputModeBinary
               MSComm1.InputLen = 33
               rBuffer = MSComm1.Input
               Arr = rBuffer
               Txstr = ""
               For i = 0 To 33 - 1
                'DoEvents
                      If i = 32 Then
                         Txstr = Txstr + Trim(Str(Arr(i)))
                      Else
                         BuffStr = IIf(Len(Hex(Arr(i))) = 1, "0" + Hex(Arr(i)), Hex(Arr(i)))
                         Txstr = Txstr + BuffStr
                      End If
                Next
                If Mid(Txstr, 1, 6) = "CCCCCC" Then
                   Sleep (5)
                  ' Open App.Path & "\SCT.txt" For Append As #1
                  ' Print #1, Trim(Text1.Text)
                  ' Close
                   MSComm1.RThreshold = 0
                   MSComm1.SThreshold = 0
                   MSComm1.InBufferCount = 0
                   MSComm1.OutBufferCount = 0
                   If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
'                   AniGIF3.Visible = False
                   'MsgBox "上传完毕！本次接收数据:" & Proress & " 计:" & (Proress * 4) - 4 & "户", vbInformation, "成功!!!"
                   'MsgBox Tips8 & "接收时间:" & EndTime, vbInformation
                   '比较
                   'Call CompReceData
                   
                   Call WirteData1
                Else
                    parM = IIf(Len(Txstr) = 34, Mid(Txstr, 65, 2), Mid(Txstr, 65, 3))
                    PariCode = A32(Mid(Txstr, 1, 64))
                    'Text2 = Text2 & "接收:" & parM & "自计算:" & PariCode + vbCrLf
                    
                    If PariCode <> parM Then
                       '错
                       Arr(0) = &HEE
                       rBuffer = Arr
                       'Text1 = Text1 & Mid(Txstr, 1, 64) + " 错校验码:" & Mid(Txstr, 65, 3) + vbCrLf   'vbCrLf   ' Mid(Txstr, 65, 3) + vbCrLf
                       
                    Else
                       '对
                 '      On Error GoTo ep
                       Arr(0) = &HCC
                       rBuffer = Arr
                       MSComm1.Output = rBuffer
                       'Text1 = Text1 & Mid(Txstr, 1, 64) + " 校验码:" & Mid(Txstr, 65, 3) + vbCrLf
                       Open App.Path & "\Tx.txt" For Append As #1
                       Print #1, Mid(Txstr, 1, 64)   '+ Chr(13)
                       Close #1
                       Proress = IIf(Proress > Proress1, Proress1, Proress + 1)
                       PrBar1.Value = Proress - 1
                    End If
                End If
                'DoEvents
        Case comBreak
             ERMsg = Tips18
'        Case comDCB
'             ERMsg = tips17
'        Case comFrame
'             ERMsg = Tips16
'        Case comRxOver
'             ERMsg = tips15
'        Case comTxFull
'             ERMsg = Tips14
        Case Else
             ERMsg = Tips13
    End Select
                 'cl = DoEvents()
       
    If Len(ERMsg) Then
        Dim ret
        ret = MsgBox(ERMsg, 1, Tips11)
        If ret = 2 Then
            On Error Resume Next
            MSComm1.OutBufferCount = 0
            MSComm1.InBufferCount = 0
            MSComm1.RThreshold = 0
            MSComm1.SThreshold = 0
            If MSComm1.PortOpen = True Then MSComm1.PortOpen = False    ' 关闭端口且退出。
            PrBar1.Max = 100
            PrBar1.Min = 0
            PrBar1.Visible = False
            Label10.Visible = False
            PrBar1.Visible = False
'            AniGIF3.Visible = False
            Exit Sub
        End If
    End If
Exit Sub

ep:
 ' MsgBox Err.Number
  Exit Sub

End Sub


'采用定时轮循法采集数据
Private Sub Timer1_Timer()
   Dim Arr(0) As Byte
   Dim rBuffer As Variant
   Dim arra() As Byte
   Dim Hands(0) As Byte
   Dim oData(0) As Byte
   Dim eBuffer As Variant
   Dim sBuffer As Variant
   Dim ed As Boolean
   Dim Txstr As String, BuffStr As String
   Dim ProMax As Integer, i As Integer
   Dim Rx_buff() As Byte
   Dim okstring As String
   Dim Rx_Buffverify As String, A32_verify As String
   Proress = IIf(Proress > Proress1, Proress1, Proress + 1)
   PrBar1.Value = Proress - 1
   Timer1.Enabled = False                       '关闭定时器
   If MSComm1.InBufferCount > 0 Then
             Rx_buff = MSComm1.Input
             For i = 0 To UBound(Rx_buff)
                 BuffStr = IIf(Len(Hex(Rx_buff(i))) = 1, "0" + Hex(Rx_buff(i)), Hex(Rx_buff(i)))
                 Txstr = Txstr + BuffStr
             Next
             If Mid(Txstr, 1, 4) = "CCCC" Then
                Timer1.Enabled = False
                MSComm1.InBufferCount = 0
                MSComm1.OutBufferCount = 0
                MSComm1.RThreshold = 0
                MSComm1.SThreshold = 0
                If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
'                Screen.MousePointer = 0
'                MsgBox "通讯结束,用时：" & Timer - WhileTime1 & "秒！", vbInformation
                Timer1.Enabled = False
                Call WirteData1
'                Exit Sub
             End If
             A32_verify = A32(Mid(Txstr, 1, 64))
             Rx_Buffverify = Rx_buff(32)
             If Rx_Buffverify = A32_verify Then ' 校验正确,返回CC通知，并存入文本
                Arr(0) = &HCC
                rBuffer = Arr
                MSComm1.Output = rBuffer
                Open App.Path & "\Tx.txt" For Append As #1
                Print #1, Mid(Txstr, 1, 64)
                Close #1
             Else               '错误则返回EE通知重新发，并显示。 另加限定次数中止接收
                Timcr = Timcr + 1
                If Timcr < 20 Then
                   Arr(0) = &HEE
                   rBuffer = Arr
                End If
             End If
     Else
            If Timcr < 20 Then
               Timcr = Timcr + 1
               Timer1.Enabled = True
            Else
                Timer1.Enabled = False
                MSComm1.InBufferCount = 0
                MSComm1.OutBufferCount = 0
                MSComm1.RThreshold = 0
                If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
                PrBar1.Visible = False
                Label10.Visible = False
                Screen.MousePointer = 0
                Close
                MsgBox "通讯中断,请检查设备是否连接正确！若仍需传输请将设备复位！", "错误", vbCritical
                Exit Sub
            End If
     End If
     Timer1.Enabled = True       ' 打开定时器
     Exit Sub

ErrorHandler:
      MsgBox Err.Number & Err.Description
      Exit Sub
End Sub