modulemain.bas

是evb描写的教学管理代码,运行在windows mobile上的.

Attribute VB_Name = "ModuleMain"
Option Explicit
Public Declare Function PlaySound Lib "Coredll" Alias "PlaySoundW" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long

Const SND_LOOP = &H8         '  loop the sound until next sndPlaySound

Const SND_ASYNC = &H1         '  play asynchronously



Public cdbFile As String
Public conn As ADOCE.Connection
Public intType As Integer
Public UserSetupFiles As String
Public Username As String
Public strPath As String

Private Sub conn_Execute(strSQL As String)  '执行SQL语句
    On Error Resume Next
    Dim rs As ADOCE.Recordset
    Set rs = conn.Execute(strSQL)

    On Error GoTo 0
    
End Sub

Private Function CONN_Open() As Boolean '打开数据库
    Dim rs As ADOCE.Recordset
    Dim response As Integer
    Dim str As String
    Dim i As Integer
    CONN_Open = True '设置返回值
    On Error Resume Next
    If conn Is Nothing Then
        Set conn = CreateObject("ADOCE.Connection.3.0")
        conn.Open cdbFile '打开数据库
        If conn.Errors.Count > 0 Then '如果有错
            str = strPath & "\MOBILEMISBACKUP.cdb" '数据库文件备份
            If FileExists(str) Then
                FileSystem1.FileCopy str, cdbFile
                CONN_Open = False
            End If

        End If
    End If
    If Not CONN_Open Then
        Set conn = Nothing
        CONN_Open
    End If
    On Error GoTo 0

End Function
Private Sub CONN_Close() '关闭数据库
  
  On Error Resume Next
  conn.Close
  Set conn = Nothing
  On Error GoTo 0

End Sub
Private Sub CreateDatabase(str As String) '创建数据库
    Dim rs As ADOCE.Recordset
            On Error Resume Next
            Set rs = CreateObject("ADOCE.Recordset.3.0")
            rs.Open "CREATE DATABASE '" & str & "'" '创建数据库文件
            rs.Close
            Set rs = Nothing
            On Error GoTo 0
            CONN_Open '打开数据库
            conn_Execute ("CREATE TABLE [备忘录表] ([事件ID] TEXT, [地点]text,[开始时间] DATETIME, [结束时间] DATETIME, [约会类型] TEXT, [频率] TEXT, [提醒] text, [提醒时间] INT, [时间单位] TEXT,[相关人员]text,[类型]text,[备注]text)") '创建表
            
            conn_Execute ("CREATE TABLE [教室资料表] ([教室编号] TEXT, [教学楼] TEXT, [类型] TEXT, [座位] INT, [备注] TEXT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [教室资料表] ([教室编号])")
            conn_Execute ("CREATE TABLE [教学楼资料表] ([教学楼编号] TEXT, [教学楼] TEXT,[类型]TEXT, [管理员]text,[教室数] INT, [备注] TEXT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [教学楼资料表] ([教学楼编号])")
            
            conn_Execute ("CREATE TABLE [课程表] ([班级] TEXT, [课程名] TEXT, [教室编号] TEXT, [教师] TEXT, [星期] TEXT, [时间] TEXT, [备注] TEXT)")
            conn_Execute ("CREATE TABLE [班级资料表] ([班级] TEXT, [年届] TEXT, [入学时间] datetime, [学院]text,[系别]text,[人数] int, [辅导员] TEXT,[备注] TEXT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [班级资料表] ([班级])")
            conn_Execute ("CREATE TABLE [课程设置表] ([课程编号] TEXT, [课程名] TEXT, [课程类型] TEXT, [教科书] TEXT, [考试类型] TEXT, [总分] TEXT, [平时成绩比例] INT, [期中成绩比例] INT, [期末成绩比例] INT, [备注] TEXT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [课程设置表] ([课程编号])")
            conn_Execute ("CREATE TABLE [平时成绩设定表] ([课程名] TEXT, [出勤比例] INT, [作业比例] INT, [论文比例] INT, [其他比例] INT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [平时成绩设定表] ([课程名])")
            conn_Execute ("CREATE TABLE [平时情况表] ([学号] TEXT, [姓名] TEXT,[班级]text,[课程名] text,[日期] DATETIME, [时间] TEXT, [星期] TEXT, [类型] TEXT, [是否出席/完成] BIT, [原因]text,[分数] INT)")

           conn_Execute ("CREATE TABLE [学生成绩表] ([学号] TEXT, [姓名] TEXT, [课程名] TEXT, [成绩] INT,[教师评语]text)")
            
            conn_Execute ("CREATE TABLE [学生资料表] ([学号] TEXT, [姓名] TEXT, [性别] TEXT, [出生年月] DATETIME, [班级] TEXT, [电话] TEXT, [手机] TEXT, [地址] TEXT, [备注] TEXT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [学生资料表] ([学号])")
            conn_Execute ("CREATE TABLE [宿舍资料表] ([宿舍编号] TEXT, [宿舍楼] TEXT, [类型] TEXT, [管理员]text,[床位] INT, [柜子]int,[备注] TEXT)")
            conn_Execute ("CREATE TABLE [宿舍楼资料表] ([宿舍楼编号] TEXT, [宿舍楼] TEXT,[类型]TEXT, [管理员]text,[房间数] INT, [备注] TEXT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [宿舍楼资料表] ([宿舍楼编号])")
            conn_Execute ("CREATE TABLE [住宿资料表] ([学号] TEXT, [姓名] TEXT, [班级] TEXT, [宿舍楼]text,[宿舍编号] INT,[身份]TEXT, [贵重物品]text,[数量]text,[备注] TEXT)")
            conn_Execute ("CREATE INDEX [PrimaryKey] ON [住宿资料表] ([学号])")
            
            conn_Execute "CREATE TABLE StaUse (场馆名称 TEXT, 启用时间 TEXT, 占用时间 TEXT, 总费用 TEXT, 使用者 TEXT)"
            conn_Execute "CREATE INDEX PrimaryKey ON StaUse (场馆名称)"
        
            conn_Execute "CREATE TABLE Sta (场馆名称 TEXT, 场馆位置 TEXT, 场馆类型 TEXT, 资费标准 TEXT, 开馆时间 TEXT, 闭馆时间 TEXT)"
            conn_Execute "CREATE INDEX PrimaryKey ON Sta (场馆名称)"
        
            conn_Execute "CREATE TABLE StaFree (场馆名称 TEXT, 空闲时间 TEXT, 备注 TEXT)"
            conn_Execute "CREATE INDEX PrimaryKey ON StaFree (场馆名称)"
        
            conn_Execute "CREATE TABLE EquUse (器材名称 TEXT, 使用数量 TEXT, 场馆名称 TEXT)"
            conn_Execute "CREATE INDEX PrimaryKey ON EquUse (场馆名称)"
        
            conn_Execute "CREATE TABLE Equ (器材名称 TEXT, 器材价格 TEXT, 器材数量 TEXT, 备注 TEXT)"
            conn_Execute "CREATE INDEX PrimaryKey ON Equ (器材名称)"
            conn_Execute "CREATE TABLE [地址簿]([姓名]TEXT,[职业]TEXT,[地址]TEXT,[邮编]TEXT,[电话]TEXT,[手机]TEXT,[生日]TEXT,[QQ]TEXT,[昵称]TEXT,[E_MAIL]TEXT)"
            conn_Execute "CREATE INDEX [PrimaryKey] ON [地址簿] ([姓名])"
            conn_Execute "CREATE TABLE [日记] ([日期] text, [天气] TEXT, [内容] TEXT)"
            
            conn_Execute "CREATE TABLE [日记] ([日期] text, [天气] TEXT, [内容] TEXT)"
            
            conn_Execute "CREATE TABLE [选课表] ([学号] text, [姓名] TEXT, [班级]text,[课程名] TEXT)"
            
            CONN_Close '关闭数据库

End Sub


Public Function FileExists(strFileName As String) As Boolean
    Dim FileSystem1 As FILECTL.FileSystem
    Set FileSystem1 = CreateObject("Filectl.fileSystem")
  '  MsgBox strFileName
    If FileSystem1.Dir(strFileName) <> "" Then
        FileExists = True
    Else
        FileExists = False
    End If
    Set FileSystem1 = Nothing
End Function

Public Function GetValues(UserSetupFiles As String, Group As String, SubItem As String)
    Dim str As String
    Dim i, j As Integer
    Dim FileSetup   As FILECTL.FileSystem
    Set FileSetup = CreateObject("Filectl.file")
    SubItem = UCase(SubItem)
    Group = UCase(Group)
        FileSetup.Open UserSetupFiles, fsModeInput, fsAccessRead
        While Not FileSetup.EOF
            str = FileSetup.LineInputString
            i = InStr(1, str, "[")
            j = InStr(1, str, "]")
            If i <> 0 And j <> 0 Then
                If Mid(str, i + 1, j - i - 1) = Group Then
                    While Not FileSetup.EOF
                        str = FileSetup.LineInputString
                        i = InStr(1, str, "=")
                        If Mid(str, 1, i - 1) = SubItem Then
                            GetValues = Mid(str, i + 1)
                            FileSetup.Close
                            Exit Function
                        End If
                    Wend
                End If
            End If
            
        Wend
        FileSetup.Close
        Set FileSetup = Nothing
End Function

Public Sub ModifyValues(UserSetupFiles As String, Group As String, SubItem As String, Values As String)
    Dim str As String
    Dim i, j As Integer
    Dim boolFind As Boolean
    Dim strContext As String
    Dim FileSetup   As FILECTL.FileSystem
    Set FileSetup = CreateObject("Filectl.file")
    SubItem = UCase(SubItem)
    Group = UCase(Group)
    strContext = ""
        FileSetup.Open UserSetupFiles, fsModeInput, fsAccessRead
        Do While Not FileSetup.EOF
            str = FileSetup.LineInputString
            strContext = strContext & ";" & str
            i = InStr(1, str, "[")
            j = InStr(1, str, "]")
            If i <> 0 And j <> 0 And boolFind = False Then
                If Mid(str, i + 1, j - i - 1) = Group Then
                    Do While Not FileSetup.EOF
                        str = FileSetup.LineInputString
                        
                        i = InStr(1, str, "=")
                        If Mid(str, 1, i - 1) = SubItem Then
                            strContext = strContext & ";" & SubItem & "=" & Values
                            boolFind = True
                            Exit Do
                        End If
                        strContext = strContext & ";" & str
                    Loop
                End If
            End If
            
        Loop
        FileSetup.Close
        FileSetup.Open UserSetupFiles, fsModeOutput, fsAccessWrite
        j = 1
        i = 1
        Do While True
            strContext = Mid(strContext, i + 1)
            i = InStr(1, strContext, ";")
            If i <= 0 Then Exit Do
            str = Mid(strContext, 1, i - 1)
            
            
            FileSetup.LinePrint str
        Loop
        FileSetup.LinePrint strContext
        FileSetup.Close
        Set FileSetup = Nothing

End Sub
Public Function GetMemoEvent(strType As String)
    Dim rs As ADOCE.Recordset
    Dim str As String
    Dim timeleftday, timelefthour, timeleftminute As Integer
    Dim total As Integer


    str = ""
    total = 0
    Set rs = CreateObject("ADOCE.Recordset.3.0")
    rs.Open "select * from '备忘录表'", conn, adOpenDynamic, adLockOptimistic
    If Not rs.EOF Then
        rs.MoveFirst
        Select Case strType
            Case "day"
                While Not rs.EOF
                    If DateDiff("d", Now, rs("开始时间")) = 0 And rs("提醒") = "提醒" Then
                    
                        total = total + 1
                        If total > 1 Then
                            str = str & "******************************" + vbCrLf
                        End If
                                
                        str = str & "事件" & total & ":" & vbCrLf
                        str = str & "内容:" & rs("事件ID") & vbCrLf
                        str = str & "地点:" & rs("地点") & vbCrLf
                        str = str & "开始时间：" & rs("开始时间") & vbCrLf
                        str = str & "结束时间：" & rs("结束时间") & vbCrLf
                        str = str & "约会类型：" & rs("约会类型") & vbCrLf
                        str = str & "频率：" & rs("频率") & vbCrLf
                        str = str & "相关人员：" & rs("相关人员") & vbCrLf
                        str = str & "类型：" & rs("类型") & vbCrLf
                        str = str & "备注：" & rs("备注") & vbCrLf
                    End If
                    rs.MoveNext
                Wend
            Case "hour"
            Case "minute"
                While Not rs.EOF
                    Select Case rs("时间单位")
                        Case "天"
                            timeleftday = rs("提醒时间")
                            timeleftminute = timeleftday * 60 * 24
                        Case "小时"
                            timelefthour = rs("提醒时间")
                            timeleftminute = timelefthour * 60
                            
                        Case "分"
                            timeleftminute = rs("提醒时间")
                    End Select
                    If ((DateDiff("d", rs("开始时间"), Now) * 60 * 24) + (Hour(rs("开始时间")) - Hour(Now)) * 60 + (Minute(rs("开始时间")) - Minute(Now))) <= timeleftminute And rs("提醒") = "提醒" Then
                    
                        total = total + 1
                        If total > 1 Then
                            str = str & "**********************************************" + vbCrLf
                        End If
                                    
                        str = str & "事件" & total & ":" & vbCrLf
                        str = str & "内容:" & rs("事件ID") & vbCrLf
                        str = str & "地点:" & rs("地点") & vbCrLf
                        str = str & "开始时间：" & rs("开始时间") & vbCrLf
                        str = str & "结束时间：" & rs("结束时间") & vbCrLf
                        str = str & "约会类型：" & rs("约会类型") & vbCrLf
                        str = str & "频率：" & rs("频率") & vbCrLf
                        str = str & "相关人员：" & rs("相关人员") & vbCrLf
                        str = str & "类型：" & rs("类型") & vbCrLf
                        str = str & "备注：" & rs("备注") & vbCrLf
                        rs("提醒") = "不提醒"
                        rs.Update
                        
                    End If
                    rs.MoveNext
                Wend
        End Select
            

    End If
    rs.Close
    Set rs = Nothing
    If str = "" Then str = "今天没有约会"
    
    GetMemoEvent = str
    
End Function


Private Sub Main()

    Dim a As ListItems
    
    strPath = App.Path
    
    If strPath = "\" Then
        strPath = ""
    End If
 '   MsgBox strPath
    PlaySound "SystemStart", 0, SND_ASYNC
    cdbFile = strPath & "\MOBILEMIS.cdb"
    UserSetupFiles = strPath & "\User.dat"
    frmInitDatabase.Show

    
End Sub