📄 frmdeal.frm
字号:
VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form frmdeal
BorderStyle = 3 'Fixed Dialog
Caption = "分房及相关处理"
ClientHeight = 4035
ClientLeft = 45
ClientTop = 330
ClientWidth = 7260
Icon = "frmdeal.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 4035
ScaleWidth = 7260
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command5
Caption = "<--"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3840
TabIndex = 14
Top = 1920
Width = 495
End
Begin VB.CommandButton Command4
Caption = "-->"
BeginProperty Font
Name = "宋体"
Size = 9
Charset = 134
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 375
Left = 3840
TabIndex = 13
Top = 1200
Width = 495
End
Begin VB.CommandButton Command3
Caption = "关闭(&C)"
Height = 375
Left = 4440
TabIndex = 12
Top = 3480
Width = 975
End
Begin VB.CommandButton Command2
Caption = "确定分房(&S)"
Height = 375
Left = 1440
TabIndex = 11
Top = 3480
Width = 1335
End
Begin VB.Frame Frame3
Caption = "申请人－→拟分房号"
Height = 2415
Left = 4440
TabIndex = 8
Top = 720
Width = 2655
Begin VB.ListBox List3
Height = 2040
Left = 120
Sorted = -1 'True
TabIndex = 10
Top = 240
Width = 2415
End
End
Begin VB.Frame Frame2
Caption = "可分配的房号："
Height = 2415
Left = 2160
TabIndex = 7
Top = 720
Width = 1575
Begin VB.ListBox List2
Height = 2040
Left = 120
Sorted = -1 'True
TabIndex = 9
Top = 240
Width = 1335
End
End
Begin VB.Frame Frame1
Height = 2415
Left = 120
TabIndex = 5
Top = 720
Width = 1815
Begin VB.ListBox List1
Height = 2040
Left = 120
TabIndex = 6
Top = 240
Width = 1575
End
End
Begin VB.CommandButton Command1
Caption = "确定(&O)"
Height = 375
Left = 3480
TabIndex = 4
Top = 120
Width = 855
End
Begin MSComCtl2.UpDown UpDown1
Height = 270
Left = 1920
TabIndex = 3
Top = 195
Width = 240
_ExtentX = 423
_ExtentY = 476
_Version = 393216
Value = 1
AutoBuddy = -1 'True
BuddyControl = "Text1"
BuddyDispid = 196620
OrigLeft = 1680
OrigTop = 120
OrigRight = 1920
OrigBottom = 375
Max = 50
Min = 1
Enabled = -1 'True
End
Begin VB.TextBox Text1
Height = 300
Left = 1440
TabIndex = 2
Text = "1"
Top = 195
Width = 495
End
Begin VB.Image Image1
Height = 180
Left = 240
Picture = "frmdeal.frx":0CCA
Top = 240
Width = 210
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "名进行分房："
Height = 180
Left = 2160
TabIndex = 1
Top = 240
Width = 1080
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "选取总分前"
Height = 180
Left = 480
TabIndex = 0
Top = 240
Width = 900
End
End
Attribute VB_Name = "frmdeal"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 教师住房管理系统 Version 1.0 '''
''' （VB6.0 源代码） '''
''' '''
''' 俊彦软件工作室出品 '''
''' '''
''' （浦口校区科技节“电子杯”程序设计大赛参赛作品） '''
''' '''
''' 程序设计：东南大学土木工程学院 周曹俊 '''
''' '''
''' CopyRight AllRights Reserved (c)2003 '''
''' '''
''' 2003年5月15日 '''
''' '''
''' '''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Option Explicit
Dim strtmp As String
Private Sub Command1_Click()
'选择总分前n名进行分房
Dim rs As Recordset
On Error GoTo errhdl
Set db2 = OpenDatabase(App.Path & "\data\applyinfo.db")
Set rs = db2.OpenRecordset("select top " & Text1.Text & " id,name from " & CStr(Asc(strtmp) - 65) & " order by zf desc")
rs.MoveFirst
Do Until rs.EOF
List1.AddItem rs!id & Space(2) & rs!Name
rs.MoveNext
Loop
Command1.Enabled = False
Exit Sub
errhdl:
MsgBox Err.Description, vbCritical + vbOKOnly, SYSTITLE
End Sub
Private Sub Command2_Click()
Me.Hide
Load frmtime
frmtime.Show
End Sub
Private Sub Command3_Click()
Unload Me
End Sub
Private Sub Command4_Click()
Dim strlist1 As String, strlist2 As String, max As Integer, alpha As String, newmax As String
strlist1 = List1.List(List1.ListIndex)
If List2.ListIndex = List2.ListCount - 1 Then
max = Val(Mid$(List2.List(List2.ListIndex), 2, 3))
alpha = Left(List2.List(List2.ListIndex), 1)
newmax = IIf(Len(CStr(max + 1)) = 1, "00" & CStr(max + 1), IIf(Len(CStr(max + 1)) = 2, "0" & CStr(max + 1), CStr(max + 1)))
strlist2 = Left(List2.List(List2.ListIndex), 4)
List3.AddItem strlist1 & "－→" & strlist2
List2.List(List2.ListIndex) = alpha & newmax & "及以上"
Else
strlist2 = List2.List(List2.ListIndex)
List3.AddItem strlist1 & "－→" & strlist2
List2.RemoveItem List2.ListIndex
End If
List1.RemoveItem List1.ListIndex
If List1.ListIndex = -1 Or List2.ListIndex = -1 Then
Command4.Enabled = False
Else
Command4.Enabled = True
End If
End Sub
Private Sub Command5_Click()
Dim strlist1 As String, strlist2 As String, strlist3 As String, intlist2 As Integer
strlist3 = List3.List(List3.ListIndex)
strlist1 = Left(strlist3, Len(strlist3) - 6)
strlist2 = Right(strlist3, 4)
intlist2 = Val(Mid$(List2.List(List2.ListCount - 1), 2, 3))
If Val(Right(strlist2, 3)) + 1 = intlist2 Then
List2.List(List2.ListCount - 1) = strlist2 & "及以上"
Else
List2.AddItem strlist2
End If
List3.RemoveItem List3.ListIndex
List1.AddItem strlist1
If List3.ListIndex <> -1 Then
Command5.Enabled = True
Else
Command5.Enabled = False
End If
End Sub
Private Sub Form_Load()
Dim strnum As String, max As Integer, i As Integer
Dim rs As Recordset
strtmp = Chr(Val(Right(frmtree2.TreeView1.SelectedItem.Key, 1)) + 65)
Set db = OpenDatabase(App.Path & "\data\basicinfo.db")
Set rs = db.OpenRecordset("select id from host where id like '" & strtmp & "*' order by id")
'找出空房号，以便分房
If Not rs.EOF Then
rs.MoveLast
max = Val(Right(rs!id, 3))
rs.MoveFirst
For i = 1 To max
If Val(Right(rs!id, 3)) = i Then
rs.MoveNext
Else
strnum = IIf(Len(CStr(i)) = 1, "00" & CStr(i), IIf(Len(CStr(i)) = 2, "0" & CStr(i), CStr(i)))
List2.AddItem strtmp & strnum
End If
Next
strnum = IIf(Len(CStr(max + 1)) = 1, "00" & CStr(max + 1), IIf(Len(CStr(max + 1)) = 2, "0" & CStr(max + 1), CStr(max + 1)))
List2.AddItem strtmp & strnum & "及以上"
Else
List2.AddItem strtmp & "001" & "及以上"
End If
Command4.Enabled = False
Command5.Enabled = False
End Sub
Private Sub List1_Click()
If List1.ListIndex >= 0 And List2.ListIndex >= 0 Then
Command4.Enabled = True
Else
Command4.Enabled = False
End If
End Sub
Private Sub List2_Click()
If List1.ListIndex >= 0 And List2.ListIndex >= 0 Then
Command4.Enabled = True
Else
Command4.Enabled = False
End If
End Sub
Private Sub List3_Click()
If List3.ListIndex <> -1 Then
Command5.Enabled = True
Else
Command5.Enabled = False
End If
End Sub
Private Sub Text1_Change()
'有效性检查
If Text1.Text = "" Or Val(Text1.Text) <= 0 Then
Command1.Enabled = False
Else
Command1.Enabled = True
End If
End Sub
Private Sub UpDown1_Change()
Text1.Text = UpDown1.Value
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -