datatransmit.frm

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

         If i = 1 Then
         '第一行 村号
            StrTemp = Input(11, #3)
            StrTemp = Mid(StrTemp, 1, 10)
            Xcode = "0" + Mid(Trim(StrTemp), 7, 2)    '传输镇代码
            Ccode = "0" + Mid(Trim(StrTemp), 9, 2)    '传输村代码
         End If
         If i = 2 Then
          '第二行 日期
            StrTemp = Input(11, #3)
            StrTemp = Mid(Trim(StrTemp), 2, 10)
            NQ = Mid(Trim(StrTemp), 6, 2)
            Yq = Mid(Trim(StrTemp), 8, 2)
         End If
         If i > 2 Then
            On Error GoTo E:
            StrTemp = Input(11, #3)
            StrTemp = Mid(StrTemp, 1, 10)
      '     Input #1, TempStr
        
            If UserSeek = "" Then
               GzYue = Format(Month(Date), "0#")
               Call sTruInfo
            End If
            Set MdbR = NdMd.OpenRecordset("SELECT 用户电费.用户表码,用户电费.用户名称,用户电费.[" & AAA & "] AS 上期示数, 用户电费.[" & aa & "] AS 本期示数,用户电费.表损, 用户电费.倍率,用户电费.[" & BB & "] AS 调整电量,用户电费.[" & CC & "] AS 本次电量, 用户电费.[" & DD & "] AS 合计电量,用户电费.电价,用户电费.[" & EE & "] AS 调整金额, 用户电费.[" & FF & "] AS 滞纳金, 用户电费.[" & GG & "] AS 本次电费, 用户电费.[" & HH & "] AS 合计电费,用户电费.[" & II & "] AS 代扣信息,用户电费.[" & JJ & "] AS 发票打印,用户电费.[" & KK & "] AS 交费情况,用户电费.组合编码 From 用户电费 where 组合编码='" & Xcode & Ccode & Mid(StrTemp, 1, 4) & "'")
            If MdbR.RecordCount = 0 Then
               CSS = Val(StrTemp)
            Else
               MdbR.Edit
               MdbR.Fields!本期示数 = Mid(StrTemp, 5, 6)
               MdbR.Update
            End If
         End If
      i = i + 1
      Loop
   End If
E:
   Close #3
   Label10.Visible = False
'   AniGIF3.Visible = False
   MsgBox "本次数据通讯成功!" & vbCrLf & Xcode & Ccode & "共上载：" & CSS & "户!", vbCritical
End Sub

'///////////NX-3型抄表器下传///////////////
Sub Nx3X()
   Dim Tim As Integer
   Dim ed As Boolean
   Dim hAndBB(0) As Byte
   Dim zh(0) As Byte
   Dim arra() As Byte
   Dim rBuffer As Variant
   Dim zsj As Variant
   Dim WhileTime
   If FileExists(App.Path & "\Tx.txt") Then Kill App.Path & "\Tx.txt"
   Call DataCrea3
   On Error GoTo Err
   hAndBB(0) = &HBB
   rBuffer = hAndBB
   MSComm1.RThreshold = 0
   If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
   MSComm1.Output = rBuffer
   WhileTime = Timer + 3
'   AniGIF1.Visible = True
'   AniGIF1.AutoSize = True
'   AniGIF1.Transparent = True
'   AniGIF1.ReadGIF (App.Path & "\Bmp\Gif\0293.GIF")
'   AniGIF1.Play
   Label9.Visible = True
   Label9.Caption = "电脑正在和抄表器通讯，请稍候..."
   Label9.Refresh
   
   '/////////轮询端口//////////
   Do Until MSComm1.InBufferCount > 0 Or MSComm1.InBufferCount = 1 And Timer > WhileTime
      DoEvents
      If Timer > WhileTime Then
         MsgBox "错误，请检查：" + Chr(13) & "1.抄表器有未连接或连接正确！" + Chr(13) & "2.抄表器有未复位！" + Chr(13) & "3.抄表器端口参数是否设置正确！", vbCritical, "握手错误"
         If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
         Label9.Visible = False
         PrBar2.Visible = False
'         AniGIF1.Stop
'         AniGIF1.Visible = False
         ed = True
         Exit Do
      End If
   Loop
   If ed = False Then
      rBuffer = MSComm1.Input
      arra = rBuffer
      If Hex(arra(0)) = "BB" Then
         Call sData
      Else
         MsgBox "握手不成功！握手信号为:" & Hex(arra(0)) & " 请检查！", vbCritical
         Label9.Visible = False
         PrBar2.Visible = False
'         AniGIF1.Stop
'         AniGIF1.Visible = False
         MSComm1.OutBufferCount = 0
         MSComm1.InBufferCount = 0
         If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
         Exit Sub
      End If
   End If
Exit Sub

Err:
    MsgBox "端口不存在或被其他设备占用!", vbCritical
    Label9.Visible = False
    PrBar2.Visible = False
'    AniGIF1.Visible = False
    Screen.MousePointer = 0
    Exit Sub
End Sub

'///////////NX-3型抄表器上传///////////////
Sub Nx3S()
   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 WhileTime
   On Error GoTo Ety
   On Error Resume Next
   Proress = 0
   oData(0) = &HBB
   sBuffer = oData
   If FileExists(App.Path & "\Tx.txt") Then Kill App.Path & "\Tx.txt"
   If FileExists(App.Path & "\Sct.Txt") Then Kill App.Path & "\Sct.txt"
   If FileExists(App.Path & "\Datach.txt") Then Kill App.Path & "\Datach.txt"
   If FileExists(App.Path & "\Zstxt.txt") Then Kill App.Path & "\Zstxt.txt"
   If MSComm1.PortOpen = False Then MSComm1.PortOpen = True
   MSComm1.OutBufferCount = 0
   MSComm1.InBufferCount = 0
   Hands(0) = &HAA
   eBuffer = Hands
   MSComm1.Output = eBuffer
   WhileTime = Timer + 1
   Label10.Visible = True
   Label10.Caption = Tips5
   '/////////轮询端口//////////
   Do Until MSComm1.InBufferCount > 0 Or MSComm1.InBufferCount = 1 And Timer > WhileTime
      DoEvents
      If Timer > WhileTime Then
         Timer1.Enabled = False
         MsgBox "通讯超时，请检查：" + Chr(13) & "1.抄表器有未连接或连接正确！" + Chr(13) & "2.抄表器有未复位！" + Chr(13) & "3.抄表器端口参数是否设置正确！", vbCritical, "无法建立连接"
         If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
            ed = True
            Label10.Visible = False
         Exit Do
      End If
   Loop
   If ed = False Then
      eBuffer = MSComm1.Input
      arra = eBuffer
      If Hex(arra(0)) = "AA" Then
         MSComm1.Output = sBuffer
         MSComm1.RThreshold = 0
         WhileTime = Timer + 1
         Do Until MSComm1.InBufferCount > 0 Or MSComm1.InBufferCount = 1 And Timer > WhileTime
            DoEvents
            If Timer > WhileTime Then
               Timer1.Enabled = False
               MsgBox "错误，请检查：" + Chr(13) & "1.抄表器有未连接或连接正确！" + Chr(13) & "2.抄表器有未复位！" + Chr(13) & "3.抄表器端口参数是否设置正确！", vbCritical, "握手错误"
               Label10.Visible = False
               If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
               ed = True
               Exit Do
            End If
         Loop
         WhileTime1 = Timer
         MSComm1.InputLen = 1
         eBuffer = MSComm1.Input
         arra = eBuffer
         ProMax = Val(Str(arra(0)))
         PrBar1.Visible = True
         PrBar1.Max = ProMax
         Proress1 = ProMax
         PrBar1.Min = 0
         Label10.Visible = True
         Label10.Caption = Tips4
         Label10.Refresh
         If RevTF = False Then
'            AniGIF3.Visible = True
'            AniGIF3.AutoSize = True
'            AniGIF3.Transparent = True
'            AniGIF3.ReadGIF (App.Path & "\Bmp\Gif\0293.GIF")
'            AniGIF3.Play
            Screen.MousePointer = 11
            MSComm1.InputLen = 33
            Timer1.Enabled = True    '打开定时器接收
         Else
            MSComm1.RThreshold = 33   '触发事件接收
         End If
         'Call rData
      Else
         Timer1.Enabled = False
         MsgBox Tips2 & Hex(arra(0)) & " 请检查！", vbCritical
         MSComm1.OutBufferCount = 0
         MSComm1.InBufferCount = 0
         MSComm1.RThreshold = 0
         Label10.Visible = False
         If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
      End If
   End If
   Exit Sub
   
Ety:
   MsgBox "端口不存在或被其他设备占用！", vbCritical
   Timer1.Enabled = False
   Exit Sub
End Sub


'//////////从数据库读取数据////////////////
Sub ReadyData()
      Cod1.DialogTitle = "请选择数据库文件:"
      Cod1.Filter = "数据库文件 (*.Mdb)|*.Mdb|所有文件 (*.*)|*.*"
      Cod1.CancelError = True
      Cod1.Filename = ""
      Cod1.ShowOpen
      If Err = cdlCancel Then
         Cela = False
        Exit Sub
      Else
        Dbk = Cod1.Filename
        DataWIZ.Show vbModal
      End If
End Sub

'//////////发送数据///////////////
Static Sub sData()
    Dim TempStr As String, PariCode As String
    Dim i As Integer
    Dim II As Integer
    Dim III As Integer
    Dim Tim As Integer
    Dim zh(0) As Byte
    Dim eBuffer As Variant
    Dim rBuffer As Variant
    Dim zsj As Variant
    Static STP As Long
    Dim sHands(31) As Byte
    Dim WhileTime As Long
    Dim zhs As String
    Screen.MousePointer = 11
   ' On Error GoTo HandErr
    Open App.Path & "\Tx.txt" For Input As #1
    II = 0
    Do Until eof(1)
       Input #1, TempStr
       If II = 0 Then
          zhs = Mid(TempStr, 14, 3)
       End If
    II = II + 1
    Loop
    Close #1
    zh(0) = II
    zsj = zh
    MSComm1.Output = zsj
    Sleep (150)
    PrBar2.Visible = True
    PrBar2.Refresh
    PrBar2.Max = II
    PrBar2.Min = 0
    III = 1
    Open App.Path & "\Tx.txt" For Input As #1
    For III = 0 To II - 1
       Input #1, TempStr
       PariCode = A32(TempStr)
       STP = 0
       For i = 0 To 32 - 1
           Select Case i
                  Case 0
                       sHands(i) = "&H" + Mid(Trim(TempStr), 1, 2)
                  Case 1
                       sHands(i) = "&H" + Mid(Trim(TempStr), i + 2, 2)
                  Case Else
                       STP = STP + 1
                       sHands(i) = "&H" + Mid(Trim(TempStr), i + STP + 2, 2)
            End Select
       Next
       eBuffer = sHands
       Sleep (150)
       '数据
       MSComm1.Output = eBuffer
       '校验码
       zh(0) = PariCode
       zsj = zh
       MSComm1.Output = zsj

ReadData:
      WhileTime = Timer + 3

       Do Until MSComm1.InBufferCount > 0 Or MSComm1.InBufferCount = 1 And Timer > WhileTime
          DoEvents
            If Timer > WhileTime Then
               Timer1.Enabled = False
               MsgBox "错误，请检查：" + Chr(13) & "1.抄表器有未连接或连接正确！" + Chr(13) & "2.抄表器有未复位！" + Chr(13) & "3.抄表器端口参数是否设置正确！", vbCritical, "握手错误"
               MSComm1.InBufferCount = 0
               MSComm1.OutBufferCount = 0
               MSComm1.RThreshold = 0
               MSComm1.InputLen = 0
               If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
               PrBar2.Max = 100
               PrBar2.Min = 0
               PrBar2.Visible = False
               Label9.Visible = False
               Screen.MousePointer = 0
'               AniGIF1.Visible = False
               Close
               Exit Sub
            End If
       
       Loop
'       Do Until MSComm1.InBufferCount > 0 Or MSComm1.InBufferCount = 1
'          DoEvents
'       Loop
       rBuffer = MSComm1.Input
       zsj = rBuffer
       If Hex(zsj(0)) = "EE" Then
           MSComm1.Output = eBuffer
           MSComm1.Output = zsj
     '      If Timer < t Then
              GoTo ReadData
     '      Else
     '      End If
       End If
       PrBar2.Value = III
       DoEvents
   Next
   Close #1
   PrBar2.Visible = False
   PrBar2.Max = 100
   PrBar2.Min = 0
   MSComm1.InBufferCount = 0
   MSComm1.OutBufferCount = 0
   MSComm1.RThreshold = 0
   MSComm1.InputLen = 0
   Label9.Visible = False
   Screen.MousePointer = 0
'   AniGIF1.Visible = False
   If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
   MsgBox "本次下载用户" & Val(zhs) & "户,请与抄表器核对!", vbInformation, "成功！！！"
End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
   Select Case SSTab1.Tab
          Case 2
               LoadPropertySettings
   End Select
End Sub


'//////////////将数据写入数据库中//////////////
Sub WirteData()
      Dim i As Integer, II As Integer, BJ As Integer, JH As Integer
      Dim StrTemp As String, StrTemp1 As String, BB As String
      Screen.MousePointer = 11
      Open App.Path & "\SCT.TXT" For Input As #3
      Input #3, StrTemp
      Close #3
      Open App.Path & "\DATACH.TXT" For Append As #1
      Print #1, Mid(StrTemp, 1, 20)
      Close #1
      Open App.Path & "\ZSTXT.TXT" For Append As #1
      Print #1, Mid(StrTemp, 65, Len(StrTemp) - 64)
      Close #1
      Open App.Path & "\ZSTXT.TXT" For Input As #1
 '     Open App.Path & "\TX.TXT" For Input As #1
      Input #1, StrTemp
      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