datatransmit.frm

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

Dim WhileTime1 As Integer
Dim Timcr As Integer
Const Tips1 = "系统待机..."
Const Tips2 = "握手不成功,请使抄表器复位！握手信号为:"
Const Tips3 = "系统正在生成下载数据，请稍候..."
Const Tips4 = "系统正在和抄表器通讯，请稍候..."
Const Tips4_1 = "抄表器正在和系统通讯，请稍候..."
Const Tips5 = "系统正在和下位机连接..."
Const Tips5_1 = "系统正在和下位机通信..."
Const Tips6 = "数据通信失败，原始文件找不到！"
Const Tips7 = "本次通讯失败!"
Const Tips8 = "本次数据通讯成功!"
Const Tips9 = "系统正在处理已接收的数据，请稍候..."
Const Tips10 = "系统正在把接收的数据送入数据库,请稍候..."
Const Tips11 = "单击“取消”退出，单击“确定”忽略。"
Const Tips12 = "本次通信收到错误后中止!"
Const Tips13 = "未知的错误或事件"
Const Tips14 = "传送缓冲区满"
Const Tips15 = "接收缓冲区溢出"
Const Tips16 = "帧错误"
Const Tips17 = "检索 DCB 错误"
Const Tips18 = "收到中断"


Private Sub Form_Load()
    Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2
    'DataTransmit.ZOrder
    PrBar1.Visible = False
    PrBar2.Visible = False
    Label9.Visible = False
    Label10.Visible = False
    Timer1.Enabled = False
    If UserSeek = "" Then
       SSTab1.TabEnabled(0) = False
       Call LoadPropertySettings
       Call pepr
    Else
       SSTab1.Tab = 0
       OpenMdb
       Set MdbR = NdMd.OpenRecordset("SELECT 用户电费.用户表码,用户电费.[" & AAA & "] AS 上期示数 From 用户电费 WHERE 用户电费.镇村代码='" & UserSeek & "' order by 用户电费.组合编码 asc")
       Call pepr
       MSComm1.OutBufferCount = 0
       MSComm1.InBufferCount = 0
       MSComm1.RThreshold = 0
       If MSComm1.PortOpen = True Then MSComm1.PortOpen = False
    End If
End Sub

Sub pepr()
    Dim CommPort As String, Settings As String, A As String
    Settings = GetSetting(App.EXEName, "属性", "设置", "")
    If Settings <> "" Then
        MSComm1.Settings = Settings
        If Err Then
           MsgBox error$, 48
           Exit Sub
        End If
    End If
    CommPort = GetSetting(App.EXEName, "属性", "通信端口", "")
    If CommPort <> "" Then MSComm1.CommPort = CommPort
    DataSetup = GetSetting(App.EXEName, "参数", "Mode", "")
End Sub

Private Sub Combo1_Click()
  cmdOK.Enabled = True
  Command2.Enabled = True
End Sub

Private Sub Combo2_Click()
  cmdOK.Enabled = True
  Command2.Enabled = True
End Sub

Private Sub Combo3_Click()
  cmdOK.Enabled = True
  Command2.Enabled = True
End Sub

Private Sub Combo4_Click()
  cmdOK.Enabled = True
  Command2.Enabled = True
End Sub

Private Sub Combo5_Click()
  cmdOK.Enabled = True
  Command2.Enabled = True
End Sub

Private Sub Combo6_Click()
  cmdOK.Enabled = True
  Command2.Enabled = True
End Sub

Private Sub Combo7_Click()
  cmdOK.Enabled = True
  Command2.Enabled = True
End Sub

Private Sub Command1_Click(Index As Integer)
   'On Error Resume Next
   Select Case Index
          Case 0
             Select Case SSTab1.Tab
                        Case 0    '下传
                        If DataSetup = "NX-1型" Then
                             Call Nx1X(1)
                        End If
                        If DataSetup = "NX-3型5Byte" Then
                             Call Nx1X(3)
                        End If
                        If DataSetup = "NX-3型32Byte" Then
                             Call Nx3X
                        End If
                    Case 1     '上传
                        If DataSetup = "NX-1型" Then
                            Call Nx1S
                        End If   'NX-2
                        If DataSetup = "NX-3型5Byte" Then
                            Call Nx1S
                        End If
                        If DataSetup = "NX-3型32Byte" Then
                            Call Nx3S
                        End If
                    Case 2     '配置
             End Select
          Case 1
               Unload Me
          Case 2
   End Select

End Sub

'//////////恢复系统初始值////////////////
Private Sub Command2_Click()
      Combo1.ListIndex = 1
      Combo2.ListIndex = 1
      Combo3.ListIndex = 1
      Combo4.ListIndex = 0
      Combo6.ListIndex = 1
      Combo7.ListIndex = 1
      Command2.Enabled = False
      DataTransmit.MSComm1.Settings = Trim$(Combo1.Text) & "," & Left$(Combo3.Text, 1) _
        & "," & Trim$(Combo2.Text) & "," & Trim$(Combo4.Text)
      SaveSetting App.EXEName, "属性", "设置", DataTransmit.MSComm1.Settings
      SaveSetting App.EXEName, "属性", "通信端口", DataTransmit.MSComm1.CommPort
      SaveSetting App.EXEName, "参数", "Mode", DataTransmit.Combo7.Text

End Sub

'应用
Private Sub cmdOK_Click()
Dim OldPort As Integer, ReOpen As Boolean, NewPort As Integer

'On Error Resume Next

OldPort = DataTransmit.MSComm1.CommPort
NewPort = Combo6.ListIndex + 1

If NewPort <> OldPort Then                   ' 如果端口号被更改, 关闭原来的端口。
    If DataTransmit.MSComm1.PortOpen Then
           DataTransmit.MSComm1.PortOpen = False
           ReOpen = True
    End If

    DataTransmit.MSComm1.CommPort = NewPort          ' 设置新的端口号。
        
    If Err Then
        MsgBox error$, 48
        DataTransmit.MSComm1.CommPort = OldPort
        Exit Sub
    End If
End If

DataTransmit.MSComm1.Settings = Trim$(Combo1.Text) & "," & Left$(Combo3.Text, 1) & "," & Trim$(Combo2.Text) & "," & Trim$(Combo4.Text)


'If Err Then
'    MsgBox error$, 48
'    Exit Sub
'End If

SaveSetting App.EXEName, "属性", "设置", DataTransmit.MSComm1.Settings
SaveSetting App.EXEName, "属性", "通信端口", Mid(Combo6.Text, 4, 1)     'DataSR.MSComm1.commport
SaveSetting App.EXEName, "参数", "Mode", DataTransmit.Combo7.Text
DataSetup = Combo7.Text
Command2.Enabled = True
End Sub

'///////////载入参数设置//////////////////
Sub LoadPropertySettings()
    Dim i As Integer, Settings As String, Offset As Integer
    
    Combo6.Clear
    For i = 1 To 4
        Combo6.AddItem "Com" & Trim$(Str$(i))
    Next i
    
    Combo1.Clear
    Combo1.AddItem "1200"
    Combo1.AddItem "2400"
    Combo1.AddItem "4800"
    Combo1.AddItem "9600"
    Combo1.AddItem "14400"
    Combo1.AddItem "19200"
    Combo1.AddItem "28800"
    Combo1.AddItem "38400"
    Combo1.AddItem "56000"
    Combo1.AddItem "57600"
    Combo1.AddItem "115200"
    Combo1.AddItem "128000"
    Combo1.AddItem "256000"
    
    Combo2.Clear
    Combo2.AddItem "7"
    Combo2.AddItem "8"
    
    Combo3.Clear
    Combo3.AddItem "Even"
    Combo3.AddItem "Odd"
    Combo3.AddItem "None"
    Combo3.AddItem "Mark"
    Combo3.AddItem "Space"
    
    Combo4.Clear
    Combo4.AddItem "1"
    Combo4.AddItem "1.5"
    Combo4.AddItem "2"
        
    Settings = DataTransmit.MSComm1.Settings
    Combo7.Clear
    Combo7.AddItem "NX-1型"
    Combo7.AddItem "NX-3型5Byte"
    Combo7.AddItem "NX-3型32Byte"
    Combo7.AddItem "NX-3型一表多村"
        
    ' 在大多数情况下，右边的大部分设置将为一个字符
    ' 除了可能出现的 1.5 停止位.
    If InStr(Settings, ".") > 0 Then
        Offset = 2
    Else
        Offset = 0
    End If
    
    Combo1.Text = Left$(Settings, Len(Settings) - 6 - Offset)
    Select Case Mid$(Settings, Len(Settings) - 4 - Offset, 1)
    Case "e"
        Combo3.ListIndex = 0
    Case "m"
        Combo3.ListIndex = 1
    Case "n"
        Combo3.ListIndex = 2
    Case "o"
        Combo3.ListIndex = 3
    Case "s"
        Combo3.ListIndex = 4
    End Select
    
    Combo2.Text = Mid$(Settings, Len(Settings) - 2 - Offset, 1)
    Combo4.Text = Right$(Settings, 1 + Offset)
    Combo6.ListIndex = DataTransmit.MSComm1.CommPort - 1
    DataSetup = GetSetting(App.EXEName, "参数", "Mode", "")
    Select Case DataSetup
    Case "NX-1型"
       Combo7.ListIndex = 0
    Case "NX-3型5Byte"
       Combo7.ListIndex = 1
    Case "NX-3型32Byte"
       Combo7.ListIndex = 2
    End Select
End Sub

'////////////NX-1型抄表器下传/////////////
Sub Nx1X(NXMode As Integer)
    Dim StrTemp, Strtx As String
    Dim itm As ListItem
    On Error Resume Next
    Label9.Caption = "系统正在生成下载数据，请稍候...."
    Label9.Visible = True
    Label9.Refresh
    If FileExists(App.Path & "\Tx.txt") Then
       Kill App.Path & "\Tx.txt"
       Kill App.Path & "\S.txt"
    End If
    Open App.Path & "\Tx.txt" For Output As #1
    Print #1, "000000" & Mid(UserSeek, 2, 2) & Mid(UserSeek, 5, 2)
    Print #1, "0000" & Mid(GzNian, 1, 4) & GzYue
    Dim intRecCount, intCounter As Integer
    Dim Bj1 As String, Bj2 As String, Bj3 As String
    PrBar2.Visible = True
    PrBar2.Max = MdbR.RecordCount - 1
    PrBar2.Min = 0
    MdbR.MoveFirst
    For intCounter = PrBar2.Min To PrBar2.Max
        Strtx = MdbR.Fields!用户表码 & IIf(Val(MdbR.Fields!上期示数) = 0, "000000", Right("000000" + MdbR.Fields!上期示数, 6))
        Print #1, Strtx
        MdbR.MoveNext
        If NXMode = 3 Then
            If intCounter + 2 = Int((PrBar2.Max + 1) / 4) Then
               Bj1 = MdbR.Fields!用户表码 & Right("000000" & Trim(Str(Int((PrBar2.Max + 1) / 4))), 6)
            End If
            If intCounter + 2 = Int((PrBar2.Max + 1) / 4) * 2 Then
               Bj2 = MdbR.Fields!用户表码 & Right("000000" & Trim(Str(Int((PrBar2.Max + 1) / 4) * 2)), 6)
            End If
            If intCounter + 2 = Int((PrBar2.Max + 1) / 4) * 3 Then
               Bj3 = MdbR.Fields!用户表码 & Right("000000" & Trim(Str(Int((PrBar2.Max + 1) / 4) * 3)), 6)
            End If
        End If
        PrBar2.Value = intCounter
        DoEvents
    Next intCounter
    PrBar2.Value = PrBar2.Min
    PrBar2.Visible = False
    If NXMode = 3 Then
        Print #1, Bj1
        Print #1, Bj2
        Print #1, Bj3
        Print #1, IIf(PrBar2.Max + 1 > 99, "0000000", "00000000") & Trim(Str(PrBar2.Max + 4))
    Else
        Print #1, IIf(PrBar2.Max + 1 > 99, "0000000", "00000000") & Trim(Str(PrBar2.Max + 1))
    End If
    Print #1, "**"
    Close
    Label9.Caption = "电脑正在和" & DataSetup & "抄表器通讯，请稍候..."
    Label9.Refresh
    Sleep (100)
    If FileExists(App.Path & "\Srtxt.exe") Then
       Dim handle As Long
'       AniGIF1.Visible = True
'       AniGIF1.AutoSize = True
'       AniGIF1.Transparent = True
'       AniGIF1.ReadGIF (App.Path & "\Bmp\Gif\0293.GIF")
'       AniGIF1.Play
       handle = Shell(App.Path & "\SRtxt.exe", vbHide)
       While StillRun(handle)
          DoEvents
       Wend
    Else
       MsgBox "数据通信失败，原始文件找不到！", vbCritical
       Exit Sub
    End If
    Open App.Path & "\S.TXT" For Input As #2
    Input #2, StrTemp
    If StrTemp = "下传失败！" Then
       Label9.Visible = False
'       AniGIF1.Visible = False
       Input #2, StrTemp
       MsgBox "本次数据通讯失败！" & vbCrLf & "错误原因：" & StrTemp, vbCritical
       Close
       Image1.Visible = True
       Label7.Visible = True
    Else
       Close
       Label9.Visible = False
'       AniGIF1.Visible = False
       Image1.Visible = True
       Label7.Visible = True
       MsgBox "本次数据通讯成功!" & vbCrLf & XzName & XcName & "共下载：" & Trim(Str(PrBar2.Max + 1)) & "户!", vbInformation
    End If
End Sub

'////////////////NX-1型抄表器上传//////////////////
Sub Nx1S()
   Dim StrTemp, Strtx As String
   Dim handle
   Label10.Visible = True
   Label10.Caption = "抄表器正在和电脑通讯，请稍候...."
   Label10.Refresh
   If FileExists(App.Path & "\S.txt") Then
      Kill App.Path & "\S.txt"
   End If
   If FileExists(App.Path & "\Srtxt.exe") Then
'      AniGIF3.Visible = True
'      AniGIF3.AutoSize = True
'      AniGIF3.Transparent = True
'      AniGIF3.ReadGIF (App.Path & "\Bmp\Gif\0293.GIF")
'      AniGIF3.Play
      handle = Shell(App.Path & "\SRtxt.exe -R", vbHide)
      While StillRun(handle)
         DoEvents
      Wend
   Else
      MsgBox "数据通信失败，原始文件找不到！", vbCritical
      Label10.Visible = False
      Exit Sub
   End If
   Open App.Path & "\S.TXT" For Input As #2
   Input #2, StrTemp
   If StrTemp = "上传失败！" Then
      Label10.Visible = False
'      AniGIF3.Visible = False
      Input #2, StrTemp
      MsgBox "本次数据通讯失败！" & vbCrLf & "错误原因：" & StrTemp, vbCritical
      Close
      Image1.Visible = True
      Label7.Visible = True
      Exit Sub
   Else
      Close
      Label10.Caption = "系统正在处理已接收的数据，请稍候..."
      Image1.Visible = False
      Label7.Visible = False
      Open App.Path & "\TX.TXT" For Input As #3
      Dim i As Integer
      i = 1
      Do Until eof(3)