rgzlcx.frm

大学生生活普查程序,用vb开发的,调查大学生生活情况,并做出评价,给出建议,做出统计

    RichTextBox1.SelColor = &H0&
    RichTextBox1.SelText = "条件" & TjI & ":"
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    RichTextBox1.SelColor = &HFF&
    RichTextBox1.SelText = Xztj.Text
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    RichTextBox1.SelColor = &H8080FF
    RichTextBox1.SelText = "="
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    RichTextBox1.SelColor = &HFF0000
    RichTextBox1.SelText = Fhtj.Text
    TjMc.Caption = Trim(Xztj.Text & "='" & Fhtj.Text & "'")
    Exit Sub
Else
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    RichTextBox1.SelColor = &H0&
    RichTextBox1.SelText = Chr(13) & Chr(10) & "条件" & TjI & ":"
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    RichTextBox1.SelColor = &HFF&
    RichTextBox1.SelText = Xztj.Text
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    RichTextBox1.SelColor = &H8080FF
    RichTextBox1.SelText = "="
    RichTextBox1.SelStart = Len(RichTextBox1.Text)
    RichTextBox1.SelColor = &HFF0000
    RichTextBox1.SelText = Fhtj.Text
End If
Select Case Combo1.ListIndex
    Case 1
      TjMc.Caption = TjMc.Caption & " or " & Xztj.Text & "='" & Fhtj.Text & "'"
    'Case 2
    Case Else
      TjMc.Caption = TjMc.Caption & Left(Combo1.Text, 3) & " " & Xztj.Text & "='" & Fhtj.Text & "'"
End Select
End Sub
Sub Cxjg() '显示查询结果
If TjMc.Caption = "" Then
    MsgBox "请先确定查询的条件！"
    Exit Sub
End If
On Error GoTo a1:
Dim re As Recordset
If Cxzd1 = "" Then
    Set re = dbs.OpenRecordset("select " & Cxzd & " from " & BM & " where " & TjMc.Caption & " group by " & Cxzd & " order by " & Cxzd & "")
Else
    Set re = dbs.OpenRecordset("select " & Cxzd & "," & Cxzd1 & " from " & BM & " where " & TjMc.Caption & " group by " & Cxzd & "," & Cxzd1 & " order by " & Cxzd & "")
End If
List1.clear
If re.RecordCount <> 0 Then
    re.MoveLast: re.MoveFirst
    Do While Not re.EOF
        If Cxzd1 <> "" Then
            List1.AddItem re(Cxzd) & "    " & re(Cxzd1) '4.-->可增加新的要显示的字段
        Else
            List1.AddItem re(Cxzd) '4.-->可增加新的要显示的字段
        End If
        re.MoveNext
    Loop
End If
Exit Sub
a1:
   MsgBox "操作错误！" & Error
End Sub

Private Sub BackMenu_Click()
'FrmXbclsj.Show
'If Ctmc.Name <> "" Then
 '   Ctmc.Show
'End If
Unload Me
formcover1.Show
End Sub

Private Sub Command1_Click()
Call Ljtj
End Sub

Private Sub Command2_Click()
Call Zdtjjg
End Sub

Private Sub Command3_Click()
Call Cxjg
End Sub
Private Sub Command4_Click()
Call clear
Call Xstj
End Sub

Private Sub Command5_Click()
If List1.Text <> "" Then
    If Cxzdcd = 0 Then
        Cxtj = "select * from " & BM & " where " & Cxzd & " like '" & List1.Text & "'"
    Else
        Cxtj = "select * from " & BM & " where " & Cxzd & " like '" & Left(List1.Text, Cxzdcd) & "'"
    End If
Else
    MsgBox "请先选择小班名！"
    Exit Sub
End If
End Sub

Private Sub Command6_Click()
Call ClearTj
End Sub

Private Sub Command7_Click()
On Error Resume Next
Dim M As String
Dim dbpath As String

dbpath = App.Path + "\"
M = MsgBox("你是否需要保存到指定的路径！" & Chr(13) & Chr(10) & "指定的路径只能保存当天的一条记录！", 32 + vbOKCancel, "提示")
If M = vbOK Then
    Tjjg.SaveFile dbpath + "file\tj" & Date & ".rtf"
    MsgBox "已经成功保存!"
Else
    CommonDialog1.ShowSave
    Tjjg.SaveFile CommonDialog1.FileName
    MsgBox "已经成功保存!"
End If
End Sub

Private Sub Form_Load()
On Error GoTo a1:
Set dbs = OpenDatabase(datapath) '1.--->可改变数据库的名称及路径
BM = "custerms " '2.-->定义表名
Cxzd = "custernum" '2.-->定义关键字段
Cxzdcd = 0
Cxzd1 = ""
'BM = "custerms"
'Cxzd = "小班号" '2.-->定义关键字段
'Cxzdcd = 11 '3.-->定义关键字段的长度
'Cxzd1 = "自然村"
'Cxzd = "custernum" '2.-->定义关键字段
'Cxzdcd = 4 '3.-->定义关键字段的长度
'Cxzd1 = "smok"
Call clear
Call Xstj
Exit Sub
a1:
    MsgBox "没有设置好，请重新设置!" & Error
End Sub

Private Sub list1_Click()
Call Command5_Click
End Sub

Private Sub List1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
    PopupMenu PopuMenu
End If
End Sub

Private Sub list2_Click()
On Error Resume Next
Dim i As Integer
i = List2.ListIndex
List3.ListIndex = i
End Sub

Private Sub List2_DblClick()
On Error Resume Next
List2.RemoveItem List2.ListIndex
List3.RemoveItem List3.ListIndex
End Sub

Private Sub List3_Click()
Dim i As Integer
i = List3.ListIndex
List2.ListIndex = i
End Sub

Private Sub List3_DblClick()
List3.RemoveItem List3.ListIndex
List2.RemoveItem List2.ListIndex
End Sub

Private Sub PopuMenu_Click()
If Len(Trim(Left(List1.Text, 11))) = 11 Then
    strSendXbbh = Trim(Left(List1.Text, 11))
End If
End Sub
Private Sub PrintTjjgmenu_Click()
    
    '设置打印标志
    CommonDialog1.Flags = cdlPDReturnDC + cdlPDNoPageNums
    
    If Tjjg.SelLength = 0 Then
        '打印所有文本
        CommonDialog1.Flags = CommonDialog1.Flags + cdlPDAllPages
    Else
        '打印选择的文本
        CommonDialog1.Flags = CommonDialog1.Flags + cdlPDSelection
    End If
    
    On Error GoTo Errstr
    CommonDialog1.CancelError = True
    
    '显示打印窗口
    CommonDialog1.ShowPrinter
    '初始化打印设备环境
    Printer.Print " "
   
    '开始打印
    Tjjg.SelPrint Printer.hDC
    
Errstr:

End Sub

Private Sub SSTab1_Click(PreviousTab As Integer)
Select Case SSTab1.Tab
    Case 1
        If Cxtj = "" Then
            MsgBox "请先选择查询条件！"
            SSTab1.Tab = 0
            Exit Sub
        End If
        On Error Resume Next
        Data1.DatabaseName = datapath
        Dim re As Recordset
        Set re = dbs.OpenRecordset(Cxtj)
        If re.RecordCount <> 0 Then
            re.MoveLast: re.MoveFirst
        End If
        Data1.Caption = BM & "共有" & re.RecordCount & "条记录"
        Set Data1.Recordset = re
        Dim Re_i As Integer
        Re_i = 0
        Dim S As Integer
        For S = 1 To Tjlr.UBound
            Unload Tjm(S)
            Unload Tjlr(S)
        Next S
        If Tjlr.UBound = re.Fields.Count - 1 Then
            Exit Sub
        End If
        For Re_i = 0 To re.Fields.Count - 1
            If Re_i = 0 Then
                Tjm(Re_i).Visible = True
                Tjm(Re_i).Caption = re.Fields(Re_i).name & ":"
                Tjlr(Re_i).Visible = True
                Tjlr(Re_i).Caption = re(re.Fields(Re_i).name)
                Tjlr(Re_i).Left = Tjm(0).Left + Tjm(0).Width
            Else
                Load Tjm(Re_i)
                Tjm(Re_i).Visible = True
                Tjm(Re_i).Caption = re.Fields(Re_i).name & ":"
                Tjm(Re_i).Top = Tjm(Tjm.UBound - 1).Top + Tjm(Tjm.UBound - 1).Height
                Load Tjlr(Re_i)
                Tjlr(Re_i).Visible = True
                Tjlr(Re_i).Caption = re(re.Fields(Re_i).name)
                Tjlr(Re_i).Top = Tjlr(Tjlr.UBound - 1).Top + Tjlr(Tjlr.UBound - 1).Height
                Tjlr(Re_i).Left = Tjm(Tjm.UBound - 1).Left + Tjm(Tjm.UBound - 1).Width
            End If
            'Tjlr(Re_i).DataSource = Data1
            'Tjlr(Re_i).DataField = RE.Fields(Re_i).Name
        Next Re_i
    Case 2
        If Cxtj = "" Then
            MsgBox "请先选择查询条件！"
            SSTab1.Tab = 0
            Exit Sub
        End If
        Dim ARE As Recordset
        Set ARE = dbs.OpenRecordset(Cxtj)
        If ARE.RecordCount <> 0 Then
            ARE.MoveLast: ARE.MoveFirst
        End If
        Adodc1.Caption = BM & "共有" & ARE.RecordCount & "条记录"
        strk = datapath
        Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;Data Source=" & strk & "" 'd:\中德原程序1.17\滇渝造林项目管理系统\DATABASE\林业基本信息库.mdb"
        Adodc1.CommandType = adCmdUnknown
        Adodc1.RecordSource = Cxtj
        Adodc1.Refresh
        DataGrid1.Refresh
End Select
End Sub

Private Sub Tjfh_Click()
If List3.ListCount <> List2.ListCount Then
    List3.AddItem Tjfh.Text
Else
    MsgBox "请先定义统计的字段！"
    Exit Sub
End If
End Sub

Private Sub Tjjg_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
    PopupMenu PrintMenu
End If
End Sub

Private Sub Xztj_Click()
On Error GoTo a1:
'显示可选条件
Dim re As Recordset
Set re = dbs.OpenRecordset("select " & Xztj.Text & " from " & BM & " group by " & Xztj.Text & "")
Fhtj.clear
If re.RecordCount <> 0 Then
    re.MoveLast: re.MoveFirst
    Do While Not re.EOF
        Fhtj.AddItem re(Xztj)
        re.MoveNext
    Loop
End If
Exit Sub
a1:
    MsgBox "操作有误" & Error
End Sub

Private Sub Zdtj_Click()
If List2.ListCount = List3.ListCount Then
    List2.AddItem Zdtj.Text
Else
    MsgBox "请先定义统计的方法！"
    Exit Sub
End If
End Sub