travel agent project

CRecord.vb

Option Explicit

Private mlRecordID As Long
Private mlParentPtr As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
    (dest As Any, Source As Any, ByVal bytes As Long)

Private msDte As String
Private msClient As String
Private msName As String
Private msProject As String
Private miNumber As Integer
Private msnPrice As Single
Private msAppendFee As String
Private msReview As String
Private msStartDate As String
Private msEndDate As String
Private msReviewStatus As String
Private msMethod As String
Private msSituation As String
Private msPost As String
Private msOperator As String
Public Property Let Dte(ByVal sdte As String): msDte = sdte: End Property
Public Property Get Dte() As String: Dte = msDte: End Property
Public Property Let Client(ByVal sClient As String): msClient = sClient: End Property
Public Property Get Client() As String: Client = msClient: End Property
Public Property Let Name(ByVal sName As String): msName = sName: End Property
Public Property Get Name() As String: Name = msName: End Property
Public Property Let Project(ByVal sProject As String): msProject = sProject: End Property
Public Property Get Project() As String: Project = msProject: End Property
Public Property Let Number(ByVal iNumber As Integer): miNumber = iNumber: End Property
Public Property Get Number() As Integer: Number = miNumber: End Property
Public Property Let Price(ByVal snPrice As Single): msnPrice = snPrice: End Property
Public Property Get Price() As Single: Price = msnPrice: End Property
Public Property Let AppendFee(ByVal sAppendFee As String): msAppendFee = sAppendFee: End Property
Public Property Get AppendFee() As String: AppendFee = msAppendFee: End Property
Public Property Let Review(ByVal sReview As String): msReview = sReview: End Property
Public Property Get Review() As String: Review = msReview: End Property
Public Property Let StartDate(ByVal sStartDate As String): msStartDate = sStartDate: End Property
Public Property Get StartDate() As String: StartDate = msStartDate: End Property
Public Property Let EndDate(ByVal sEndDate As String): msEndDate = sEndDate: End Property
Public Property Get EndDate() As String: EndDate = msEndDate: End Property
Public Property Let ReviewStatus(ByVal sReviewStatus As String): msReviewStatus = sReviewStatus: End Property
Public Property Get ReviewStatus() As String: ReviewStatus = msReviewStatus: End Property
Public Property Let Method(ByVal sMethod As String): msMethod = sMethod: End Property
Public Property Get Method() As String: Method = msMethod: End Property
Public Property Let Situation(ByVal sSituation As String): msSituation = sSituation: End Property
Public Property Get Situation() As String: Situation = msSituation: End Property
Public Property Let Post(ByVal sPost As String): msPost = sPost: End Property
Public Property Get Post() As String: Post = msPost: End Property
Public Property Let Operator(ByVal sOperator As String): msOperator = sOperator: End Property
Public Property Get Operator() As String: Operator = msOperator: End Property
Public Property Let RecordID(ByVal lRecordID As Long): mlRecordID = lRecordID: End Property
Public Property Get RecordID() As Long: RecordID = mlRecordID: End Property
Public Property Get Parent() As CRecords: Set Parent = ObjFromPtr(mlParentPtr): End Property
Public Property Set Parent(obj As CRecords): mlParentPtr = ObjPtr(obj): End Property

Private Function ObjFromPtr(ByVal pObj As Long) As Object
    Dim obj As Object
    CopyMemory obj, pObj, 4
    Set ObjFromPtr = obj
    ' manually destroy the temporary object variable
    ' (if you omit this step you'll get a GPF!)
    CopyMemory obj, 0&, 4
End Function

CRecords.vb

Option Explicit

Private mcolRecords As Collection

Private Sub Class_Initialize()
    Set mcolRecords = New Collection
End Sub

Private Sub Class_Terminate()
    Set mcolRecords = Nothing
End Sub

Public Property Get NewEnum() As IUnknown
    Set NewEnum = mcolRecords.[_NewEnum]
End Property

Public Sub Add(clsRecord As CRecord)
    If clsRecord.RecordID = 0 Then
        clsRecord.RecordID = Me.Count + 1
    End If

    Set clsRecord.Parent = Me
    mcolRecords.Add clsRecord, CStr(clsRecord.RecordID)
End Sub

Public Property Get Record(vItem As Variant) As CRecord
    Set Record = mcolRecords.Item(vItem)
End Property

Public Property Get Count() As Long
    Count = mcolRecords.Count
End Property

travel-agent.vb

Option Explicit
Public Const gAPP_TITLE As String = "Demo"
Private Const msMODULE As String = "MAppFunctions()"

Sub ADOFromExcelToAccess()
' exports data from the active worksheet to a table in an Access database
' this procedure must be edited before use
Dim cn As ADODB.Connection, rs As ADODB.Recordset, lEndRow As Long, iEndCol As Integer
Dim rngRow As Range, rng As Range
On Error GoTo ErrorHandler:
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & ThisWorkbook.Path & "\Demo.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    rs.Open "汇总表", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    ' all records in a table
    lEndRow = wktSource.Range("A1").End(xlDown).Row ' the start row in the worksheet
    iEndCol = wktSource.Range("A1").End(xlToRight).Column
    Set rng = wktSource.Range("A2:" & Split(wktSource.Cells(1, iEndCol).Address, "$")(1) & lEndRow)
    For Each rngRow In rng.Rows
        If Len(rngRow.Cells(1, 1)) * Len(rngRow.Cells(1, 5)) * Len(rngRow.Cells(1, 6)) <> 0 Then
    ' repeat until first empty cell in column A
        With rs
            .AddNew ' create a new record
            ' add values to each field in the record
            .Fields("年") = rngRow.Cells(1, 1)
            .Fields("月") = rngRow.Cells(1, 2)
            .Fields("日") = rngRow.Cells(1, 3)
            .Fields("客户") = rngRow.Cells(1, 4)
            .Fields("项目") = rngRow.Cells(1, 5)
            .Fields("名称") = rngRow.Cells(1, 6)
            .Fields("数量") = rngRow.Cells(1, 7)
            .Fields("单价") = rngRow.Cells(1, 8)
            .Fields("附加费用用途") = rngRow.Cells(1, 9)
            .Fields("附加费用") = rngRow.Cells(1, 10)
            .Fields("资料预审") = rngRow.Cells(1, 11)
            .Fields("入签日期") = rngRow.Cells(1, 12)
            .Fields("出签日期") = rngRow.Cells(1, 13)
            .Fields("出签状态") = rngRow.Cells(1, 14)
            .Fields("结算方式") = rngRow.Cells(1, 15)
            .Fields("收款情况") = rngRow.Cells(1, 16)
            .Fields("邮寄") = rngRow.Cells(1, 17)
            .Fields("经办人") = rngRow.Cells(1, 18)

            ' add more fields if necessary...
            .Update ' stores the new record
        End With
'        r = r + 1 ' next row
        End If
    Next
'    rs.Close
    Set rs = Nothing
'    cn.Close
    Set cn = Nothing
    rng.ClearContents
    Exit Sub
ErrorHandler:
    MsgBox "数据处理出现问题，请联系Reed修复处理。不便之处，敬请谅解。", , gAPP_TITLE
End Sub

Sub AddLineToAccess()
Dim cn As ADODB.Connection, rs As ADODB.Recordset, lEndRow As Long, iEndCol As Integer
Dim rngRow As Range, rng As Range
Dim lRow As Long, vInput
On Error GoTo ErrorHandler:
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & ThisWorkbook.Path & "\Demo.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    rs.Open "汇总表", cn, adOpenKeyset, adLockOptimistic, adCmdTable
    lEndRow = wktSource.Range("A1").End(xlDown).Row ' the start row in the worksheet
    iEndCol = wktSource.Range("A1").End(xlToRight).Column
    vInput = InputBox("请选择需要增加到数据库的行： ", gAPP_TITLE)
    If Len(vInput) = 0 Then End
'    If IsEmpty(lRow) Then End
    If Not IsNumeric(vInput) Then MsgBox "行数输入有错，请输入数字。", , gAPP_TITLE: End
    If vInput <= 1 Then MsgBox "行数不得小于或等于1", , gAPP_TITLE: End
    lRow = vInput
    If lRow > lEndRow Then MsgBox "输入行数大于当前数据表最大行数，请重新输入。", , gAPP_TITLE: End
    Set rngRow = wktSource.Rows(lRow)
    With rs
        .AddNew ' create a new record
        ' add values to each field in the record
        .Fields("年") = rngRow.Cells(1, 1)
        .Fields("月") = rngRow.Cells(1, 2)
        .Fields("日") = rngRow.Cells(1, 3)
        .Fields("客户") = rngRow.Cells(1, 4)
        .Fields("项目") = rngRow.Cells(1, 5)
        .Fields("名称") = rngRow.Cells(1, 6)
        .Fields("数量") = rngRow.Cells(1, 7)
        .Fields("单价") = rngRow.Cells(1, 8)
        .Fields("附加费用用途") = rngRow.Cells(1, 9)
        .Fields("附加费用") = rngRow.Cells(1, 10)
        .Fields("资料预审") = rngRow.Cells(1, 11)
        .Fields("入签日期") = rngRow.Cells(1, 12)
        .Fields("出签日期") = rngRow.Cells(1, 13)
        .Fields("出签状态") = rngRow.Cells(1, 14)
        .Fields("结算方式") = rngRow.Cells(1, 15)
        .Fields("收款情况") = rngRow.Cells(1, 16)
        .Fields("邮寄") = rngRow.Cells(1, 17)
        .Fields("经办人") = rngRow.Cells(1, 18)

        ' add more fields if necessary...
        .Update ' stores the new record
    End With
'    rs.Close
    Set rs = Nothing
'    cn.Close
    Set cn = Nothing
    wktSource.Rows(lRow).Delete
    Exit Sub
ErrorHandler:
    MsgBox "数据处理出现问题，请联系Reed修复处理。不便之处，敬请谅解。", , gAPP_TITLE
End Sub

Sub DeleteLineToAccess()
Dim cn As ADODB.Connection, rs As ADODB.Recordset, lEndRow As Long, iEndCol As Integer
Dim rngRow As Range, rng As Range
Dim lRow As Long, vInput
Dim sSql As String
On Error GoTo ErrorHandler:
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & ThisWorkbook.Path & "\Demo.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    lEndRow = wktSource.Range("A1").End(xlDown).Row ' the start row in the worksheet
    iEndCol = wktSource.Range("A1").End(xlToRight).Column
    vInput = InputBox("请选择需要数据库删除的行： ", gAPP_TITLE)
    If Len(vInput) = 0 Then End
'    If IsEmpty(lRow) Then End
    If Not IsNumeric(vInput) Then MsgBox "行数输入有错，请输入数字。", , gAPP_TITLE: End
    If vInput <= 1 Then MsgBox "行数不得小于或等于1", , gAPP_TITLE: End
    lRow = vInput
    If lRow > lEndRow Then MsgBox "输入行数大于当前数据表最大行数，请重新输入。", , gAPP_TITLE: End
    Set rngRow = wktSource.Rows(lRow)
    sSql = "Delete * FROM [汇总表] WHERE [汇总表].[年]= " & rngRow.Cells(1, 1) & _
            " and [汇总表].[月]= " & rngRow.Cells(1, 2) & _
            " and [汇总表].[日]= " & rngRow.Cells(1, 3) & _
            " and [汇总表].[客户]= '" & rngRow.Cells(1, 4) & "'"
    rs.Open sSql, cn
'    rs.Close
    Set rs = Nothing
'    cn.Close
    Set cn = Nothing
    wktSource.Rows(lRow).Delete
    Exit Sub
ErrorHandler:
    MsgBox "数据处理出现问题，请联系Reed修复处理。不便之处，敬请谅解。", , gAPP_TITLE
End Sub

Sub GenerateReport()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sSql As String
Dim lEndRow As Long, iEndCol As Integer
Dim arrTitle As Variant
On Error GoTo ErrorHandler:
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & ThisWorkbook.Path & "\Demo.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    wktResult.Range("E3") = ""
    wktResult.Range("H3") = ""
    wktResult.Range("K3") = ""
    lEndRow = IIf(wktResult.Range("A4").End(xlDown).Row = 65536, 5, wktResult.Range("A4").End(xlDown).Row)
    iEndCol = 20
    wktResult.Range(wktResult.Cells(5, 1), wktResult.Cells(lEndRow, iEndCol)).ClearContents
    arrTitle = Array("年", "月", "日", "客户", "项目", "名称", "数量", "单价", "附加费用用途", "附加费用", "资料预审", "入签日期", "出签日期", "出签状态", "结算方式", "收款情况", "邮寄", "经办人")
    wktResult.Range("A5:R5") = arrTitle
    sSql = "Select * FROM [汇总表] WHERE [汇总表].[年]= " & ThisWorkbook.Names("Year").RefersToRange.Value & _
            " and [汇总表].[月]= " & ThisWorkbook.Names("Month").RefersToRange.Value
    rs.Open sSql, cn
    wktResult.Range("A6").CopyFromRecordset rs
    
    sSql = "Select sum([汇总表].[单价] * [汇总表].[数量]) FROM [汇总表] WHERE [汇总表].[年]= " & ThisWorkbook.Names("Year").RefersToRange.Value & _
            " and [汇总表].[月]= " & ThisWorkbook.Names("Month").RefersToRange.Value
    rs.Close
    rs.Open sSql, cn
    wktResult.Range("E3").CopyFromRecordset rs
    
    sSql = "Select sum([汇总表].[附加费用]) FROM [汇总表] WHERE [汇总表].[年]= " & ThisWorkbook.Names("Year").RefersToRange.Value & _
            " and [汇总表].[月]= " & ThisWorkbook.Names("Month").RefersToRange.Value
    rs.Close
    rs.Open sSql, cn
    wktResult.Range("H3").CopyFromRecordset rs

    wktResult.Range("K3").Value = wktResult.Range("E3").Value + wktResult.Range("H3").Value
    Set rs = Nothing
'    cn.Close
    Set cn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox "数据处理出现问题，请联系Reed修复处理。不便之处，敬请谅解。", , gAPP_TITLE
End Sub

Sub ResetDB()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sSql As String
On Error GoTo ErrorHandler:
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & ThisWorkbook.Path & "\Demo.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    sSql = "Delete * FROM [汇总表]"
    rs.Open sSql, cn
'    rs.Close
    Set rs = Nothing
'    cn.Close
    Set cn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox "数据处理出现问题，请联系Reed修复处理。不便之处，敬请谅解。", , gAPP_TITLE
End Sub

Sub ExportFromDB()
Dim cn As ADODB.Connection, rs As ADODB.Recordset
Dim sSql As String
On Error GoTo ErrorHandler:
    ' connect to the Access database
    Set cn = New ADODB.Connection
    cn.Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _
        "Data Source=" & ThisWorkbook.Path & "\Demo.mdb;"
    ' open a recordset
    Set rs = New ADODB.Recordset
    sSql = "Select * FROM [汇总表]"
    rs.Open sSql, cn
    wktSource.Range("A2").CopyFromRecordset rs
'    rs.Close
    Set rs = Nothing
'    cn.Close
    Set cn = Nothing
    Exit Sub
ErrorHandler:
    MsgBox "数据处理出现问题，请联系Reed修复处理。不便之处，敬请谅解。", , gAPP_TITLE
End Sub

1.查询功能须设置时间段查询：
例如：2013-01-01至2013-02-27，查询这段时间记录，包括录入查询及成本支出查询都需要
2.查询记录须另外设置一个可以点击到今日出签的所有信息汇总，例如点击今天2013-02-26日出签记录可以包括到2013-02-26日前未出签的所有信息，查询后还需可以打印信息清单出来，方便核对
3.增加记录如果一条信息重复增加后可否有办法能否管理员删除或输入密码删除，或普通员工登陆不可更改数据里的：客户名称
4.查询记录汇总信息的页面可否改为简单化，查询出来后可否一页界面显示出来（不用左右拉），例如：日期可否不分年月日，只是普通年月日一齐显示（多框多界面），名称框可否增加到4-5个名字同时一行（因为名称框只是一个名字显示，太小了），数量、单价等或其它框可否设置窄些
5.增加记录：录入信息里的（附加费用用途、附加费用、资料预审、收款情况、邮寄）须改为可选择，不是每次要输入，类似：客户、项目等输入
6.账单输出时账单须固定财务账户3-4个，如果需要更换再输入
7.账单保存后格式需要一页显示（不用左右拉）
8.由于我们护照出签后需要出签确认，等于之前每一笔录入的信息作为一个出签确认，可否另外设置一个：已出签（点击） 选择提供
9.数据源保存及万一软件瘫痪的可以复原