frmnx5trim.frm

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

         .LockType = adLockOptimistic
         .Open sqlStr2, cn
         If .RecordCount <> 0 Then
            .MoveLast
            .MoveFirst
            ProgressBar1.Visible = True
            ProgressBar1.Value = 0
            ProgressBar1.Max = .RecordCount
            For I = 0 To .RecordCount - 1
                sqlrec = "SELECT 用户电费.[" & AA & "] AS BYC,用户电费.[" & BB & "] AS TB,用户电费.[" & VV & "] AS CBSJ FROM 用户电费 WHERE 镇村代码='" & Mid(.Fields!检索ID, 2, 3) & Mid(.Fields!检索ID, 6, 3) & "' AND 抄表码='" & Right(.Fields!检索ID, 6) & "'"    '     & Mid(.Fields!检索ID, 5, 4) & " WHERE cbm='" & Right(.Fields!检索ID, 4) & "'"
                Set MdbR = NdMd.OpenRecordset(sqlrec)
                If MdbR.RecordCount <> 0 Then
                   If .Fields!抄表情况 = True Then
                      MdbR.Edit
                      MdbR.Fields!byc = Format(.Fields!本月数, "000000")
                      MdbR.Fields!tb = .Fields!退补电量
                      MdbR.Fields!CBSJ = .Fields!抄表时间
                      MdbR.Update
                   End If
                End If
                ProgressBar1.Value = I + 1
               .MoveNext
            Next
         Else
            MsgBox "本次上传数据为空！请检查抄表情况。", vbInformation, "提示"
            Screen.MousePointer = 0
            rstA.Close
            Exit Sub
         End If
    End With
    Screen.MousePointer = 0
    rstA.Close
    MsgBox "数据处理完毕!", vbInformation, "成功"
    Exit Sub
DerrOr:
    MsgBox Err.Description, vbCritical, "提示"
    Exit Sub
End Sub

'配置
Private Sub Command4_Click()
    Dim retval
    
    If Fso.FileExists(App.Path & "\dbf_load.exe") Then
       retval = Shell(App.Path & "\dbf_load.exe -C", 1)
    Else
      MsgBox "数据通信失败，原始文件找不到！", vbCritical
      Exit Sub
    End If

End Sub

Private Sub Command1_Click(Index As Integer)
     Select Case Index
            Case 0
                 Call DownData
            Case 1
                 Call DownNote
            Case 2
                 Call UpData
            Case 3
                 Unload Me
     End Select
End Sub

'上载数据
Sub UpData()
    Dim Retuinfo As String
    Dim pId As Long, pHnd As Long
    If FileExists(App.Path & "\DownDbf\Result.Txt") Then
       Kill App.Path & "\DownDbf\Result.Txt"
    End If
    
    If FileExists(PpathStr & "\Result.Txt") Then
       Kill PpathStr & "\Result.Txt"
    End If
    
    If FileExists(App.Path & "\UpDbf\Result.Txt") Then
       Kill App.Path & "\UpDbf\Result.Txt"
    End If
    
    If Fso.FileExists(App.Path & "\UpDbf\线路台区信息表.dbf") Then
       Fso.DeleteFile App.Path & "\UpDbf\线路台区信息表.dbf", True
    End If
    
    If Fso.FileExists(App.Path & "\UpDbf\普通用户信息表.dbf") Then
       Fso.DeleteFile App.Path & "\UpDbf\普通用户信息表.dbf", True
    End If
    
    If FileExists(PpathStr & "\dbf_load.exe") Then
       pId = Shell(PpathStr & "\dbf_load.exe -R", 1)
    Else
      MsgBox "数据通信失败，原始文件找不到！", vbCritical
      Exit Sub
    End If
    '等待程序执行完毕，然后执行下面程序
    pHnd = OpenProcess(SYNCHRONIZE, 0, pId)     '取得 Process Handle
    If pHnd <> 0 Then
       Call WaitForSingleObject(pHnd, INFINITE) '等待程序结束
       Call CloseHandle(pHnd)                   '关闭
    End If

    If FileExists(PpathStr & "\Result.Txt") Then
       Open PpathStr & "\Result.Txt" For Binary As #1
       Retuinfo = Input(LOF(1), 1)
       Close #1
    End If
    
    If FileExists(App.Path & "\DownDbf\Result.Txt") Then
       Open App.Path & "\DownDbf\Result.Txt" For Binary As #1
       Retuinfo = Input(LOF(1), 1)
       Close #1
    End If
    
    If FileExists(App.Path & "\UpDbf\Result.Txt") Then
       Open App.Path & "\UpDbf\Result.Txt" For Binary As #1
       Retuinfo = Input(LOF(1), 1)
       Close #1
    End If
    
    If Left(Retuinfo, 2) = "成功" Then
       If MsgBox("数据上载完毕，是否写入文件?", vbYesNo + vbQuestion, "提示") = vbYes Then
          Call DataTrim
       End If
    End If
   
End Sub

'下载便签
Sub DownNote()
    Dim retval
    If Fso.FileExists("d:\DownDbf\dbf_load.exe") Then
       retval = Shell("d:\DownDbf\dbf_load.exe -T", 1)
    Else
      MsgBox "数据通信失败，原始文件找不到！", vbCritical
      Exit Sub
    End If

End Sub

'下载数据
Sub DownData()
   On Error GoTo DownErr
   Dim sqlString As String
   Dim I As Integer, iii As Integer, iiii As Integer
   For I = 0 To List2.ListCount - 1
       If List2.Selected(I) = True Then
          iii = iii + Val(Right(List2.List(I), 8))
       End If
   Next
   If iii > 2000 Then
      MsgBox "所选数据超出！", vbExclamation, "提示"
      Exit Sub
   End If
   If iii = 0 Then
      MsgBox "请选择选数据后再执行下载抄表数据！", vbExclamation, "提示"
      Exit Sub
   End If
   
   Screen.MousePointer = 11
   Set cn = New ADODB.Connection
   Set rst = New ADODB.Recordset
   If FileExists(PpathStr & "\Downdbf\" & PfileD) Then
      Kill PpathStr & "\Downdbf\" & PfileD
      FileCopy PpathStr & "\Cbj\Line.Dat", PpathStr & "\Downdbf\" & PfileD
   Else
      FileCopy PpathStr & "\Cbj\Line.Dat", PpathStr & "\Downdbf\" & PfileD
   End If
   
   If FileExists(PpathStr & "\Downdbf\" & PfileA) Then
      Kill PpathStr & "\Downdbf\" & PfileA
      FileCopy PpathStr & "\Cbj\General.Dat", PpathStr & "\Downdbf\" & PfileA
   Else
      FileCopy PpathStr & "\Cbj\General.Dat", PpathStr & "\Downdbf\" & PfileA
   End If
   
   If FileExists(PpathStr & "\Downdbf\" & PfileC) Then
      Kill PpathStr & "\Downdbf\" & PfileC
      FileCopy PpathStr & "\Cbj\Price.Dat", PpathStr & "\Downdbf\" & PfileC
   Else
      FileCopy PpathStr & "\Cbj\Price.Dat", PpathStr & "\Downdbf\" & PfileC
   End If
   
   If FileExists(PpathStr & "\Downdbf\" & PfileB) Then
      Kill PpathStr & "\Downdbf\" & PfileB
      FileCopy PpathStr & "\Cbj\BigFile.Dat", PpathStr & "\Downdbf\" & PfileB
   Else
      FileCopy PpathStr & "\Cbj\BigFile.Dat", PpathStr & "\Downdbf\" & PfileB
   End If
   
   cn.Open "Provider=MSDASQL.1;Persist Security Info=false;Extended Properties=Driver={Microsoft Visual FoxPro Driver};UID=;SourceDB=" & (App.Path & "\DownDbf") & ";SourceType=DBF;Exclusive=No;BackgroundFetch=Yes;Collate=Machine;Null=Yes;Deleted=Yes;"

   With rst
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic
        .Open SqlStr1, cn
   End With

'导入线路台区信息
    For I = 0 To List2.ListCount - 1
        If List2.Selected(I) = True Then
               With rst
               .AddNew
               .Fields!线路编码 = Right("0000" & Left(List1.Text, 3), 4)
               .Fields!线路名称 = Trim(Mid(List1.Text, 5, 8))
               .Fields!台区编码 = Format(Trim(Left(List2.List(I), 4)), "0000")
               .Fields!台区名称 = Trim(Mid(List2.List(I), 5, 9))
               .Fields!突变n值 = 0.25
               .Fields!负责人 = ""
               .Fields!备注 = ""
               .Update
           End With
        End If
    Next
    rst.Close
    
'导入用户信息
    ProgressBar1.Visible = True
    With rst
         .CursorType = adOpenStatic
         .LockType = adLockOptimistic
         .Open sqlStr2, cn
    End With
    
    OpenMdb
    For I = 0 To List2.ListCount - 1
        If List2.Selected(I) = True Then
           Set MdbR = NdMd.OpenRecordset("SELECT 用户电费.用户名称,用户电费.地址,用户电费.镇村代码,用户电费.抄表码,用户电费.电价类别,用户电费.倍率,用户电费.表损,用户电费.用户类型,用户电费.辅助号,用户电费.[" & AAA & "] AS 上期示数,用户电费.[" & BBB & "] AS 上月电量,用户电费.[" & CCC & "] AS 上月电费,用户电费.往期平均 FROM 用户电费 WHERE 镇村代码='" & Trim(Left(List1.Text, 4)) & Trim(Left(List2.List(I), 4)) & "' order by 抄表码")
           Dim II As Integer
           With MdbR
           If .RecordCount <> 0 Then
              .MoveLast
              .MoveFirst
              ProgressBar1.Max = .RecordCount
              For II = 0 To .RecordCount - 1
                 rst.AddNew
                 rst.Fields!检索ID = Right("0000" & Left(List1.Text, 3), 4) & Format(Trim(Left(List2.List(I), 4)), "0000") & Right("000000" & .Fields!抄表码, 6)
                 rst.Fields!户号 = Right("000000" & .Fields!抄表码, 6)
                 rst.Fields!表号 = .Fields!辅助号 & ""
                 rst.Fields!名称 = .Fields!用户名称 & ""
                 rst.Fields!地址 = Mid(.Fields!地址, 1, 10) & ""
                 rst.Fields!用户性质 = .Fields!用户类型
                 rst.Fields!上月数 = .Fields!上期示数 & 0
                 'rst.Fields!上月电量 = Val(.Fields(("M" & Trim(Str(Month(Date))) & "D")))
                 rst.Fields!上月电量 = .Fields!上月电量
                 rst.Fields!电价类别 = .Fields!电价类别
                 rst.Fields!倍率 = .Fields!倍率
                 rst.Fields!表损 = .Fields!表损
                 rst.Fields!表位 = 6
                 rst.Fields!欠费金额 = 0
                 rst.Fields!抄表情况 = False
                 rst.Fields!本月数 = 0
                 rst.Fields!本月电量 = 0
                 rst.Fields!本月电费 = 0
                 rst.Fields!电表翻转 = False
                 rst.Fields!电表性能 = True
                 rst.Fields!旧表止度 = 0
                 rst.Fields!新表起度 = 0
                 rst.Fields!退补电量 = 0
                 rst.Fields!抄表时间 = Date
                 rst.Fields!收费情况 = False
                 rst.Update
                 ProgressBar1.Value = II + 1
                 .MoveNext
              Next
           End If
           End With
        End If
    Next
    rst.Close
    
'导入电价
    With rst
         .CursorType = adOpenStatic
         .LockType = adLockOptimistic
         .Open sqlStr3, cn
    End With
    Set MdbR = NdMd.OpenRecordset("SELECT * FROM  电价档案 WHERE 状态 =true order by 价区代码")
    
    With MdbR
    If .RecordCount <> 0 Then
       .MoveLast
       .MoveFirst
       For II = 0 To .RecordCount - 1
           rst.AddNew
           rst.Fields!电价编码 = .Fields!电价ID
           rst.Fields!电价类别 = .Fields!价区类别 & ""
           rst.Fields!电价 = .Fields!电价 & 0
           rst.Update
           .MoveNext
       Next
     End If
     End With
    rst.Close
    cn.Close
    Set rst = Nothing
    Set cn = Nothing
    Screen.MousePointer = 0
    ProgressBar1.Visible = False
    Dim retval
    If Fso.FileExists(App.Path & "\dbf_load.exe") Then
       retval = Shell(App.Path & "\dbf_load.exe -s", 1)
    Else
       MsgBox "数据通信失败，原始文件找不到！", vbCritical
       Exit Sub
    End If
    Exit Sub
    
DownErr:
    MsgBox Err.Description, vbCritical, "错误"
    Screen.MousePointer = 0
    Exit Sub
    
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next
    rst.Close
    rstA.Close
    cn.Close
    Set rst = Nothing
    Set rstA = Nothing
    Set cn = Nothing
    Set FrmNx5Trim = Nothing
End Sub

Private Sub List1_Click()
    Dim intRecCount, intCounter As Integer
    Dim Nd As Recordset
    On Error Resume Next
    Set MdbR = NdMd.OpenRecordset("SELECT 村代码,简称 FROM 村档案 WHERE 村档案.镇代码 ='" & Mid(Trim(List1.Text), 1, 3) & "'")
    MdbR.MoveLast
    intCounter = MdbR.RecordCount
    MdbR.MoveFirst
    List2.Clear
    For intRecCount = 0 To intCounter - 1
        Set Nd = NdMd.OpenRecordset("SELECT count(*)as zsh FROM 用户电费 WHERE 用户电费.镇村代码= '" & Mid(Trim(List1.Text), 1, 3) & Trim(MdbR.Fields("村代码")) & "'")
        List2.AddItem MdbR.Fields("村代码") & Space(1) & Left(Trim(MdbR.Fields("简称")) & Space(16), 16 - convert_str(Trim(MdbR.Fields("简称")))) & Space(2) & Right(Space(3) & Nd.Fields!zsh, 4) & "户"    ' & Space(1) & "已开:" & Right(Space(3) & PrintTrue, 3) & "户." & "  " & .Fields("cby")     '& Space(2) & .Fields!CBY & Space(2) & .Fields!XDM & .Fields!Cdm & ".dbf"
        MdbR.MoveNext
    Next intRecCount
    List2.ListIndex = 0
End Sub

Private Sub List2_Click()
   Dim j As Integer, k As Integer, l As Integer
   For j = 0 To List2.ListCount - 1
      If List2.Selected(j) Then
         k = k + 1
         If k > 0 Then
            Command1(0).Enabled = True
         Else
            Command1(0).Enabled = False
         End If
      Else
         If k > 0 Then
            Command1(0).Enabled = True
         Else
            Command1(0).Enabled = False
         End If
      End If
   Next
  ' List2.ListIndex = 0
End Sub