📄 datatools.frm
字号:
Private Sub Form_Load()
On Error Resume Next
OpenMdb
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 2 - 400
Text1.Visible = False
Text1.Enabled = False
Label1.Visible = True
Label2.Visible = False
Label3.Visible = False
Label4.Visible = False
Check1.Visible = False
Frame2.Visible = False
RegCode = GetSetting(App.EXEName, "RegPass", "DataPass", "")
If RegCode <> "" Then
Check1.Value = 2
Text1 = RegCode
Else
Check1.Value = 0
End If
Dim i As Integer
For i = 1 To 12
Combo1.AddItem Format(i, "0#") & "月份数据"
Combo2.AddItem Format(i, "0#") & "月份数据"
Next
Combo1.Text = Format(Month(Date) - 1, "0#月份数据")
Combo2.Text = Format(Month(Date), "0#月份数据")
Set MdbR = NdMd.OpenRecordset("SELECT * FROM 村档案 ORDER BY 镇村代码 ASC")
If MdbR.RecordCount <> 0 Then
With MdbR
.MoveLast
.MoveFirst
For i = 0 To .RecordCount - 1
List1.AddItem .Fields!镇村代码 & vbTab & .Fields!简称
.MoveNext
Next
End With
End If
List1.ListIndex = 0
MdbR.Close
NdMd.Close
End Sub
Sub cmd_begin_Click()
Dim errLoop As error
On Error Resume Next
MdbR.Close
NdMd.Close
On Error GoTo 0
On Error GoTo hander
Screen.MousePointer = 11
If FileExists(App.Path & "\temp.mdb") Then
Kill App.Path & "\temp.mdb"
End If
If RegCode = "" Then
DBEngine.CompactDatabase App.Path & "\Data\Eletricity.Mdb", App.Path & "\temp.mdb", , dbEncrypt + dbVersion30
Else
DBEngine.CompactDatabase App.Path & "\Data\Eletricity.Mdb", App.Path & "\temp.mdb", , dbEncrypt + dbVersion30, "" 'RegCode
End If
Kill App.Path & "\Data\Eletricity.Mdb"
CopyFile App.Path & "\temp.mdb", App.Path & "\Data\Eletricity.Mdb", True
Kill App.Path & "\temp.mdb"
MsgBox "数据库压缩成功!", vbInformation
Screen.MousePointer = 0
Exit Sub
hander:
For Each errLoop In DBEngine.Errors
MsgBox "数据库修压缩失败!" & vbCr & _
"Error number: " & errLoop.Number & _
vbCr & errLoop.Description
cmd_close.Visible = True
Screen.MousePointer = 0
Next errLoop
End Sub
Private Sub cmd_close_Click()
Unload Me
End Sub
Sub cmd_start_Click()
Dim mydb As Database
Dim errLoop As error
On Error Resume Next
MdbR.Close
NdMd.Close
cmd_close.Visible = False
If MsgBox("真的要修复数据库?", _
vbYesNo) = vbYes Then
Screen.MousePointer = 11
On Error GoTo Err_Repair
DBEngine.RepairDatabase App.Path & "\Data\Eletricity.Mdb"
On Error GoTo 0
If FileExists(App.Path & "\temp.mdb") Then
Kill App.Path & "\temp.mdb"
End If
'Dir(App.Path & "\temp.mdb")
DBEngine.CompactDatabase App.Path & "\Data\Eletricity.Mdb", App.Path & "\temp.mdb", , dbEncrypt + dbVersion30, ""
Kill App.Path & "\Data\Eletricity.Mdb"
CopyFile App.Path & "\temp.mdb", App.Path & "\Data\Eletricity.Mdb", True
'Set mydb = DBEngine.OpenDatabase(App.Path & "\data\temp.mdb", dbEncrypt + dbVersion30, , ";pwd=d^j&d*s!j~")
MsgBox "数据库修复成功!", vbInformation
End If
cmd_close.Visible = True
Screen.MousePointer = 0
Exit Sub
Err_Repair:
For Each errLoop In DBEngine.Errors
MsgBox "数据库修修复失败!" & vbCr & _
"Error number: " & errLoop.Number & _
vbCr & errLoop.Description
cmd_close.Visible = True
Screen.MousePointer = 0
Next errLoop
End Sub
Private Sub Command1_Click()
Select Case TabStrip1.SelectedItem.Index
Case 1
Call cmd_begin_Click
Case 2
Call cmd_start_Click
Case 3
Case 4
OpenMdb
Call SortRepl
End Select
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
SaveSetting App.EXEName, "RegPass", "DataPass", Text1.Text
If FileExists(App.Path & "\temp.mdb") Then
Kill App.Path & "\temp.mdb"
End If
End Sub
Private Sub List1_Click()
Dim j As Integer, k As Integer, l As Integer
For j = 0 To List1.ListCount - 1
If List1.Selected(j) Then
k = k + 1
If k > 0 Then
Command1.Enabled = True
Else
Command1.Enabled = False
End If
Else
If k > 0 Then
Command1.Enabled = True
Else
Command1.Enabled = False
End If
End If
Next
List1.ListIndex = 0
End Sub
Private Sub TabStrip1_Click()
Select Case TabStrip1.SelectedItem.Index
Case 1
Frame2.Visible = False
Check1.Visible = False
Label2.Visible = False
Label3.Visible = False
Label4.Visible = False
Text1.Visible = False
Label1.Visible = True
Image1.Visible = True
Command1.Enabled = True
Case 2
Frame2.Visible = False
Check1.Visible = False
Label2.Visible = False
Label4.Visible = False
Text1.Visible = False
Label1.Visible = False
Label3.Visible = True
Image1.Visible = True
Command1.Enabled = True
Case 3
Frame2.Visible = False
Image1.Visible = False
Label1.Visible = False
Label3.Visible = False
Check1.Visible = True
Label4.Visible = True
Label2.Visible = True
Text1.Visible = True
Command1.Enabled = True
Case 4
Image1.Visible = False
Label1.Visible = False
Label3.Visible = False
Check1.Visible = False
Label4.Visible = False
Label2.Visible = False
Frame2.Visible = True
Command1.Enabled = False
End Select
End Sub
Private Sub Check1_Click()
If Check1.Value Then
Text1.Enabled = True
Text1.SetFocus
Else
Text1 = ""
Text1.Enabled = False
End If
End Sub
Sub SortRepl()
Dim i As Integer
Dim ix As Long
On Error Resume Next
If Option1(0).Value Then '替换
If MsgBox("数据搬移可能会给数据带来破坏，请谨慎使用该功能,确定吗?", vbYesNo + vbInformation + vbDefaultButton2) = vbYes Then
If Check3.Value Then '全部
If Option2(0) Then '只覆盖本月为空的户
Call Staring(True, False, Left(List1.List(i), 3))
Else '不管全部覆盖
Call Staring(True, False, Left(List1.List(i), 3))
End If
Else
If List1.ListCount = 0 Then Exit Sub
Screen.MousePointer = 11
Command1.Enabled = False
ProgressBar1.Max = List1.ListCount - 1
ProgressBar1.Min = 0
ProgressBar1.Value = 0
For i = 0 To List1.ListCount - 1
If List1.Selected(i) Then
If Option2(0).Value Then '只覆盖本月为空的数字
Call Staring(False, False, Left(List1.List(i), 3))
Else '不管全部覆盖
Call Staring(False, True, Left(List1.List(i), 3))
End If
End If
ProgressBar1.Value = i
Next
End If
Command1.Enabled = True
Screen.MousePointer = 0
ProgressBar1.Value = 0
ProgressBar2.Value = 0
MsgBox "数据全部搬移完毕，请进行校对!", vbInformation
End If
Else '排序
If MsgBox("重排用户电表编码可能会给工作带来不便，确定吗?", vbYesNo + vbInformation + vbDefaultButton2) = vbYes Then
If List1.ListCount = 0 Then Exit Sub
Screen.MousePointer = 11
Command1.Enabled = False
ProgressBar1.Max = List1.ListCount - 1
ProgressBar1.Min = 0
ProgressBar1.Value = 0
For i = 0 To List1.ListCount - 1
If List1.Selected(i) Then
Set MdbR = NdMd.OpenRecordset("SELECT * FROM 用户电费 where 镇村代码 ='" & Left(List1.List(i), 6) & "' ORDER BY 用户编码")
If MdbR.RecordCount <> 0 Then
With MdbR
.MoveLast
.MoveFirst
ProgressBar2.Max = .RecordCount
ProgressBar2.Min = 0
ProgressBar2.Value = 0
For ix = 1 To .RecordCount
.Edit
.Fields!抄表码 = Format(Trim(Str(ix)), "00000#")
ProgressBar2.Value = ix
.Update
.MoveNext
Next
End With
End If
End If
ProgressBar1.Value = i
Next
Command1.Enabled = True
Screen.MousePointer = 0
ProgressBar1.Value = 0
ProgressBar2.Value = 0
MsgBox "全部排序完毕，您可能需要重新打印用户校对单和电表标签!", vbInformation
End If
End If
End Sub
Sub Staring(sAll As Boolean, sOve As Boolean, Scode As String)
Dim i As Integer
Dim ix As Long
On Error Resume Next
If sAll = True Then
If sOve = True Then '过滤本月为空的数据
Set MdbR = NdMd.OpenRecordset("SELECT 用户电费.[" & ConvMonth(Val(Left(Combo1.Text, 2))) & "] AS 上次, 用户电费.[" & ConvMonth(Val(Left(Combo2.Text, 2))) & "] AS 本次,用户电费.[" & ConvMonthjj(Val(Left(Combo2.Text, 2))) & "] AS 本次调整,用户电费.[" & ConvMonthjj(Val(Left(Combo1.Text, 2))) & "] AS 上次调整 FROM 用户电费 where ISNULL(用户电费.[" & AA & "]) <> True ORDER BY 用户编码")
Else '不过滤全部
Set MdbR = NdMd.OpenRecordset("SELECT 用户电费.[" & ConvMonth(Val(Left(Combo1.Text, 2))) & "] AS 上次, 用户电费.[" & ConvMonth(Val(Left(Combo2.Text, 2))) & "] AS 本次,用户电费.[" & ConvMonthjj(Val(Left(Combo2.Text, 2))) & "] AS 本次调整,用户电费.[" & ConvMonthjj(Val(Left(Combo1.Text, 2))) & "] AS 上次调整 FROM 用户电费 ORDER BY 用户编码")
End If
If MdbR.RecordCount <> 0 Then
Screen.MousePointer = 11
Command1.Enabled = False
With MdbR
.MoveLast
.MoveFirst
ProgressBar2.Max = .RecordCount
ProgressBar2.Min = 0
ProgressBar2.Value = 0
For ix = 1 To .RecordCount
.Edit
.Fields!本次 = .Fields!上次
.Fields!本次调整 = .Fields!上次调整
ProgressBar2.Value = ix
.Update
.MoveNext
Next
End With
End If
Else
Screen.MousePointer = 11
Command1.Enabled = False
ProgressBar1.Max = List1.ListCount - 1
ProgressBar1.Min = 0
ProgressBar1.Value = 0
For i = 0 To List1.ListCount - 1
If List1.Selected(i) Then
If sOve = True Then '只过滤符合条件的乡村代码 ,用户电费.[" & ConvMonthjj(Val(Left(Combo2.Text, 2))) & "] AS 本次调整,用户电费.[" & ConvMonthjj(Val(Left(Combo1.Text, 2))) & "] AS 上次调整
Set MdbR = NdMd.OpenRecordset("SELECT 用户电费.[" & ConvMonth(Val(Left(Combo1.Text, 2))) & "] AS 上次, 用户电费.[" & ConvMonth(Val(Left(Combo2.Text, 2))) & "] AS 本次,用户电费.[" & ConvMonthjj(Val(Left(Combo2.Text, 2))) & "] AS 本次调整,用户电费.[" & ConvMonthjj(Val(Left(Combo1.Text, 2))) & "] AS 上次调整 FROM 用户电费 where 镇村代码 ='" & Left(List1.List(i), 6) & "' AND ISNULL(用户电费.[" & AA & "]) <> True ORDER BY 用户编码")
Else '过滤符合条件的乡村代码和本月为空的数据
Set MdbR = NdMd.OpenRecordset("SELECT 用户电费.[" & ConvMonth(Val(Left(Combo1.Text, 2))) & "] AS 上次, 用户电费.[" & ConvMonth(Val(Left(Combo2.Text, 2))) & "] AS 本次,用户电费.[" & ConvMonthjj(Val(Left(Combo2.Text, 2))) & "] AS 本次调整,用户电费.[" & ConvMonthjj(Val(Left(Combo1.Text, 2))) & "] AS 上次调整 FROM 用户电费 where 镇村代码 ='" & Left(List1.List(i), 6) & "' ORDER BY 用户编码")
End If
If MdbR.RecordCount <> 0 Then
With MdbR
.MoveLast
.MoveFirst
ProgressBar2.Max = .RecordCount
ProgressBar2.Min = 0
ProgressBar2.Value = 0
For ix = 1 To .RecordCount
.Edit
.Fields!本次 = .Fields!上次
.Fields!本次调整 = .Fields!上次调整
ProgressBar2.Value = ix
.Update
.MoveNext
Next
End With
End If
End If
ProgressBar1.Value = i
Next
End If
Screen.MousePointer = 0
Command1.Enabled = True
End Sub
Function ConvMonth(sele_month As Integer) As String
ConvMonth = Choose(sele_month, "A月示数", "B月示数", "C月示数", "D月示数", "E月示数", "F月示数", "G月示数", "H月示数", "I月示数", "J月示数", "K月示数", "L月示数")
End Function
Function ConvMonthjj(sele_month As Integer) As String
ConvMonthjj = Choose(sele_month, "A月调整电量", "B月调整电量", "C月调整电量", "D月调整电量", "E月调整电量", "F月调整电量", "G月调整电量", "H月调整电量", "I月调整电量", "J月调整电量", "K月调整电量", "L月调整电量")
End Function
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -