frmmain.frm

星级酒店管理系统VB源代码

End Sub

' Show the name of the control's area under the mouse cursor.

Private Sub MonthView1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim areaName As String
    Select Case MonthView1.HitTest(X, Y, 0)
        Case mvwCalendarBack
            areaName = "mvwCalendarBack"
        Case mvwCalendarDate
            areaName = "mvwCalendarDate"
        Case mvwCalendarDateNext
            areaName = "mvwCalendarDateNext"
        Case mvwCalendarDatePrev
            areaName = "mvwCalendarDatePrev"
        Case mvwCalendarDay
            areaName = "mvwCalendarDay"
        Case mvwCalendarWeekNum
            areaName = "mvwCalendarWeekNum"
        Case mvwNoWhere
            areaName = "mvwNoWhere"
        Case mvwTitleBack
            areaName = "mvwTitleBack"
        Case mvwTitleBtnNext
            areaName = "mvwTitleBtnNext"
        Case mvwTitleBtnPrev
            areaName = "mvwTitleBtnPrev"
        Case mvwTitleMonth
            areaName = "mvwTitleMonth"
        Case mvwTitleYear
            areaName = "mvwTitleYear"
        Case mvwTodayLink
            areaName = "mvwTodayLink"
    End Select
End Sub

' Start a drag and drop operation.

Private Sub MonthView1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' Exit if the right button isn't clicked.
    If Button <> vbRightButton Then Exit Sub
    ' Exit if mouse isn't over a valid date
    If MonthView1.HitTest(X, Y, DraggedDate) = mvwCalendarDay Then Exit Sub
    ' Now DraggedDate contains the date to be dragged
    ' and we can start the drag operation
    MonthView1.OLEDrag
End Sub
Private Sub MonthView1_OLEStartDrag(Data As MSComCtl2.DataObject, AllowedEffects As Long)
    ' When this event fires DraggedDate contain a valid date
    Data.SetData Format(DraggedDate, "long date")
    AllowedEffects = vbDropEffectCopy
End Sub

' Refuse any selection that includes a Sunday or a Saturday.
' NOTE: it apparently works only if the user has selected
' at least three days (bug?)

'Private Sub MonthView1_SelChange(ByVal StartDate As Date, _
'    ByVal EndDate As Date, Cancel As Boolean)
'    Dim d As Date
'    For d = StartDate To EndDate
'        If Weekday(d) = vbSunday Or Weekday(d) = vbSaturday Then
'            Cancel = True
'            Exit For
'        End If
'    Next
'End Sub


Private Sub Picture2_GotFocus()
    Me.MSHFlexGrid1.Refresh
    tvwC.Refresh

End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "保存"
            mnuFileSave_Click
        Case "剪切"
            mnuEditCut_Click
        Case "复制"
            mnuEditCopy_Click
        Case "粘贴"
            mnuEditPaste_Click
        
        Case "粗体"
            ActiveForm.RTFText.SelBold = Not ActiveForm.RTFText.SelBold
            Button.Value = IIf(ActiveForm.RTFText.SelBold, tbrPressed, tbrUnpressed)
        Case "斜体"
            ActiveForm.RTFText.SelItalic = Not ActiveForm.RTFText.SelItalic
            Button.Value = IIf(ActiveForm.RTFText.SelItalic, tbrPressed, tbrUnpressed)
        Case "下划线"
            ActiveForm.RTFText.SelUnderline = Not ActiveForm.RTFText.SelUnderline
            Button.Value = IIf(ActiveForm.RTFText.SelUnderline, tbrPressed, tbrUnpressed)
        Case "左对齐"
            ActiveForm.RTFText.SelAlignment = rtfLeft
        Case "置中"
            ActiveForm.RTFText.SelAlignment = rtfCenter
        Case "右对齐"
            ActiveForm.RTFText.SelAlignment = rtfRight
        Case "Song"
        Case "Kai"
        Case "Hei"
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show vbModal, Me
End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer


    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hWnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub


Private Sub mnuToolsOptions_Click()
    frmOptions.Show vbModal, Me
End Sub



Private Sub mnuEditPaste_Click()
    On Error Resume Next
    ActiveForm.RTFText.SelRTF = Clipboard.GetText

End Sub

Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.RTFText.SelRTF

End Sub

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.RTFText.SelRTF
    ActiveForm.RTFText.SelText = vbNullString

End Sub



Private Sub mnuFileExit_Click()
    '卸载窗体
    Unload Me

End Sub

Private Sub mnuFileSend_Click()
    '应做:添加 'mnuFileSend_Click' 代码。
    MsgBox "添加 'mnuFileSend_Click' 代码。"
End Sub

Private Sub mnuFilePageSetup_Click()
    On Error Resume Next
    dlgCommonDialog.ShowPrinter

End Sub

Private Sub mnuFileSaveAll_Click()
    '应做:添加 'mnuFileSaveAll_Click' 代码。
    MsgBox "添加 'mnuFileSaveAll_Click' 代码。"
End Sub

Private Sub mnuFileSaveAs_Click()
    Dim sFile As String
    If TypeOf ActiveForm Is frmDocuments Then
        With dlgCommonDialog
            .DialogTitle = "另存为"
            .CancelError = False
            'ToDo: 设置 common dialog 控件的标志和属性
            .Filter = "所有文件 (*.*)|*.*"
            .ShowSave
            If Len(.FileName) = 0 Then
                Exit Sub
            End If
            sFile = .FileName
        End With
        ActiveForm.Caption = sFile
        ActiveForm.RTFText.SaveFile sFile
        frmDocuments.OLE1.SaveToFile dlgCommonDialog.FileName
        SaveSetting "wlf", "DM", "date", Date
    End If
End Sub

Private Sub mnuFileSave_Click()
    Dim sFile As String
    If TypeOf Me.ActiveForm Is frmDocuments Then
        With dlgCommonDialog
            .DialogTitle = "保存"
            .CancelError = False
            'ToDo: 设置 common dialog 控件的标志和属性
            .Filter = "所有文件 (*.*)|*.*"
            .ShowSave
            If Len(.FileName) = 0 Then
                Exit Sub
            End If
            sFile = .FileName
        End With
        frmDocuments.OLE1.SaveToFile dlgCommonDialog.FileName
        SaveSetting "wlf", "DM", "date", Date
    End If
End Sub

Private Sub mnuFileClose_Click()
    If Not ActiveForm Is Nothing Then
        Unload Me.ActiveForm
        Picture2.Visible = True
    End If
End Sub



Private Sub Timer1_Timer()
    If Time = AutoSaveTime Then
        AutoSave
    End If
End Sub

Public Function AutoSave()
    Dim FSO As New Scripting.FileSystemObject
    Dim fil As Scripting.File
    Dim bDate, eDate, fDate As Date
    Dim oldFolder As String
    Dim lngOffset As Long
    Dim lngLogoSize As Long
    Dim varLogo As Variant
    Dim varChunk As Variant
    Const conChunkSize = 100
        
    Data1.RecordSource = "自动归档表"
    Data1.DefaultType = 1
    Data1.Refresh
    Data1.Recordset.MoveFirst
    
    oldFolder = DEDocuments.rs自动归档表.Fields("原磁盘位置")
    If oldFolder = "" Then
        Exit Function
    End If
    
    bDate = DEDocuments.rs自动归档表.Fields("建立开始日期")
    eDate = DEDocuments.rs自动归档表.Fields("建立结束日期")
    
    For Each fil In FSO.GetFolder(oldFolder).Files
                
        
        If fil.DateLastModified >= bDate And fil.DateLastModified <= eDate Then
            DEDocuments.rs文档信息表.AddNew
            
            DEDocuments.rs文档信息表.Fields("标题") = DEDocuments.rs自动归档表.Fields("标题")
            DEDocuments.rs文档信息表.Fields("主题") = DEDocuments.rs自动归档表.Fields("主题")
            DEDocuments.rs文档信息表.Fields("作者") = DEDocuments.rs自动归档表.Fields("作者")
            DEDocuments.rs文档信息表.Fields("单位") = DEDocuments.rs自动归档表.Fields("单位")
            DEDocuments.rs文档信息表.Fields("类别") = DEDocuments.rs自动归档表.Fields("类别")
            DEDocuments.rs文档信息表.Fields("关键词") = DEDocuments.rs自动归档表.Fields("关键词")
            DEDocuments.rs文档信息表.Fields("内容简介") = DEDocuments.rs自动归档表.Fields("内容简介")
            DEDocuments.rs文档信息表.Fields("原磁盘位置") = fil.ParentFolder & "\" & fil.Name
            DEDocuments.rs文档信息表.Fields("完成日期") = fil.DateLastModified
            DEDocuments.rs文档信息表.Fields("版本号") = DEDocuments.rs自动归档表.Fields("版本号")
            DEDocuments.rs文档信息表.Fields("语言") = DEDocuments.rs自动归档表.Fields("语言")
            DEDocuments.rs文档信息表.Fields("编写目的") = DEDocuments.rs自动归档表.Fields("编写目的")
            DEDocuments.rs文档信息表.Fields("最后归档时间") = Now
            DEDocuments.rs文档信息表.Fields("使用频率") = DEDocuments.rs自动归档表.Fields("使用频率")
            DEDocuments.rs文档信息表.Fields("重要程度") = DEDocuments.rs自动归档表.Fields("重要程度")
            DEDocuments.rs文档信息表.Fields("文件格式") = fil.Type
            
            OLE1.CreateEmbed fil.ParentFolder & "\" & fil.Name
            OLE1.Update
            
            Data1.UpdateRecord
            
            DEDocuments.rs自动归档表.MoveFirst
            
            lngLogoSize = DEDocuments.rs自动归档表.Fields("内容").ActualSize
   
            Do While lngOffset < lngLogoSize
                varChunk = DEDocuments.rs自动归档表.Fields("内容").GetChunk(conChunkSize)
                varLogo = varLogo & varChunk
                lngOffset = lngOffset + conChunkSize
            Loop
   
           lngOffset = 0 ' Reset offset.
           Do While lngOffset < lngLogoSize
               varChunk = LeftB(RightB(varLogo, lngLogoSize - lngOffset), conChunkSize)
               DEDocuments.rs文档信息表.Fields("内容").AppendChunk varChunk
               lngOffset = lngOffset + conChunkSize
           Loop
           DEDocuments.rs文档信息表.UpdateBatch adAffectAllChapters
        End If
    Next
    MsgBox "自动归档已经完成！", vbOKOnly, "提示！"
End Function

Private Sub tvwC_NodeClick(ByVal Node As MSComctlLib.Node)
    Label1.Caption = IIf(IsNull(Node.Tag), "(该项目没有详细描述信息，请您补充。)", Node.Tag)
End Sub


Private Sub tvwCRefresh()
    Dim rsa As New ADODB.Recordset
    Dim rootNode As Node, nd As Node
    Dim diffB, diffE As Integer
    
    On Error Resume Next
        
    cn.Open "DSN=DM;UID=;PWD=;"
    
    ' Open the Authors recordset.
    rsa.Open "项目信息", cn, adOpenForwardOnly, adLockReadOnly
    
    If Err Then
        MsgBox "Unable to open aaa table", vbCritical
        End
    End If
    
    ' Add the "Publishers" root (expanded).
    Set rootNode = tvwC.Nodes.Add(, , "\\Projects", "项目信息", 2)
    rootNode.Expanded = True
    
    ' Add all the publishers, with a plus sign.
    Do Until rsa.EOF
        Set nd = tvwC.Nodes.Add(rootNode.Key, tvwChild, , rsa.Fields("客户"), 1)
        ' We can't use PubID as the Key, because it is a number.
        nd.Tag = rsa.Fields("客户")
        
        diffB = rsa.Fields("项目开始日期") - Date
        diffE = rsa.Fields("项目结束日期") - Date
        
        If diffB < 0 And diffE > 0 Then
            nd.ForeColor = vbBlue
        End If
        
        If diffB > 0 And diffB < 30 Then
            nd.ForeColor = vbGreen
        End If
        
        If diffE < 0 Then
            nd.ForeColor = vbRed
        End If
        
        AddDummyChild nd
        rsa.MoveNext
    Loop
    rsa.Close
    
End Sub

Sub AddDummyChild(nd As Node)
    ' add a dummy child node, if necessary
    If nd.children = 0 Then
        ' dummy nodes' Text property is "***"
        tvwC.Nodes.Add nd.Index, tvwChild, , "***"
    End If
End Sub

Private Sub tvwC_Expand(ByVal Node As MSComctlLib.Node)
    ' a node if being expanded
    Dim nd As Node
    
    ' exit if the node had been already expanded in the past
    If Node.children = 0 Or Node.children > 1 Then Exit Sub
    ' also exit if it doesn't have a dummy child node
    If Node.Child.Text <> "***" Then Exit Sub
    ' remove the dummy child item
    tvwC.Nodes.Remove Node.Child.Index
    ' add all the titles for this Node object
    AddTitles Node
End Sub

Private Sub AddTitles(ByVal Node As MSComctlLib.Node)
    Dim nd As Node
    Dim diff As Integer
    
    Dim rsb As New ADODB.Recordset
    
    rsb.Open "select * from 项目信息 where trim(客户) = '" & Trim(Node.Tag) & "'", cn, adOpenForwardOnly, adLockReadOnly
    
    Do Until rsb.EOF
        Set nd = tvwC.Nodes.Add(Node, tvwChild, , rsb.Fields("项目名称") & "：" & FormatDateTime(rsb.Fields("项目开始日期"), vbLongDate) & "至" & FormatDateTime(rsb.Fields("项目结束日期"), vbLongDate), 1)
        
        diff = rsb.Fields("项目结束日期") - rsb.Fields("项目开始日期")
        nd.Tag = "项目情况：" & vbCrLf & "工期：" & Str(diff) & " 天" & vbCrLf & rsb.Fields("项目说明")
        rsb.MoveNext
    Loop
    rsb.Close
End Sub