QBasic & Borland Pascal & C/Delphi5.iso/Basic/Visual Basic.60/COMMON/TOOLS/VB/OLEMSG/TIMECARD.CLI/SERVER/MAINSVR.FRM

Visual Basic Form | 1996-06-15 | 16.2 KB | 554 lines

VERSION 5.00
Begin VB.Form formmainsvr
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "Time Card Server"
   ClientHeight    =   6795
   ClientLeft      =   1410
   ClientTop       =   1515
   ClientWidth     =   8880
   Height          =   7200
   Left            =   1350
   LinkTopic       =   "Form2"
   ScaleHeight     =   6795
   ScaleWidth      =   8880
   Top             =   1170
   Width           =   9000
   Begin VB.ListBox lstUsers
      Height          =   4575
      Left            =   480
      TabIndex        =   7
      Top             =   720
      Width           =   3372
   End
   Begin VB.CommandButton btnAddUsr
      Caption         =   "&Add"
      Height          =   372
      Left            =   480
      TabIndex        =   6
      Top             =   5880
      Width           =   1212
   End
   Begin VB.CommandButton btnRemoveAllUsers
      Caption         =   "&Remove All"
      Height          =   372
      Left            =   2640
      TabIndex        =   5
      Top             =   5880
      Width           =   1212
   End
   Begin VB.TextBox txtCat
      Height          =   372
      Left            =   4920
      TabIndex        =   3
      Top             =   720
      Width           =   3372
   End
   Begin VB.ListBox lstCat
      Height          =   3795
      ItemData        =   "mainsvr.frx":0000
      Left            =   4920
      List            =   "mainsvr.frx":0007
      TabIndex        =   2
      Top             =   1500
      Width           =   3372
   End
   Begin VB.CommandButton btnAddCat
      Caption         =   "A&dd"
      Default         =   -1  'True
      Enabled         =   0   'False
      Height          =   372
      Left            =   4920
      TabIndex        =   1
      Top             =   5880
      Width           =   1212
   End
   Begin VB.CommandButton btnRemoveCat
      Caption         =   "Remo&ve"
      Enabled         =   0   'False
      Height          =   372
      Left            =   7080
      TabIndex        =   0
      Top             =   5880
      Width           =   1212
   End
   Begin VB.Label Label1
      Caption         =   "User List"
      Height          =   252
      Left            =   480
      TabIndex        =   8
      Top             =   240
      Width           =   1572
   End
   Begin VB.Label lblName
      Caption         =   "Category to add"
      Height          =   252
      Left            =   4800
      TabIndex        =   4
      Top             =   240
      Width           =   1572
   End
   Begin VB.Line Line1
      X1              =   4440
      X2              =   4440
      Y1              =   0
      Y2              =   6840
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuSave
         Caption         =   "&Save"
      End
      Begin VB.Menu mnus
         Caption         =   "-"
         Index           =   1
      End
      Begin VB.Menu mnuExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuReport
      Caption         =   "&Report"
      Begin VB.Menu mnuSend
         Caption         =   "&Send Requests"
      End
      Begin VB.Menu mnuGenerate
         Caption         =   "&Generate Report"
      End
      Begin VB.Menu mnuse
         Caption         =   "-"
      End
      Begin VB.Menu mnuCleanUp
         Caption         =   "&Clean Up Receiving Folder"
      End
   End
   Begin VB.Menu mnuHelp
      Caption         =   "&Help"
      Begin VB.Menu mnuAbout
         Caption         =   "&About"
      End
   End
Attribute VB_Name = "formmainsvr"
Attribute VB_Base = "0{CFF16A11-C697-11CF-A520-00A0D1003923}"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_TemplateDerived = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Attribute VB_Customizable = False
Option Explicit
Sub GetCategoryList()
ReDim CategoryList.aCats(lstCat.ListCount) As String
Dim ind As Integer
CategoryList.cCats = lstCat.ListCount
ind = 0
Do While ind < CategoryList.cCats
    CategoryList.aCats(ind) = lstCat.List(ind)
    ind = ind + 1
End Sub
Public Sub SendRequest(cCats As Integer, Cats() As String, PayPrd As Date, Reminder As Boolean)
'sends request message
On Error GoTo error_olemsg
Dim objmessage As Object
Dim prop As Object
Dim objRecip As Object
Dim objRecipCol As Object
Dim objFieldCol As Object
Dim objAttachmentCol As Object
Dim objAtt As Object
Dim ind As Integer
Dim msgBody As String
If UserList.cUsers = 0 Then
    MsgBox "User List is empty"
    Exit Sub
End If
If cCats = 0 Then
    MsgBox "Category list is empty"
    Exit Sub
End If
If Not Reminder Then
    If Not frmCalender.GetDate(PayPrd) Then
        Exit Sub
    End If
End If
If objSession Is Nothing Then
    MsgBox "Not logged on"
    Exit Sub
End If
'create new message in the outbox
Set objmessage = objSession.Outbox.Messages.Add
If objmessage Is Nothing Then
    MsgBox "Can't add a prop"
    Exit Sub
End If
If Not Reminder Then
    objmessage.Subject = "Time to fill out your time report"
    msgBody = ""
    objmessage.Subject = "SECOND NOTICE: Time to fill out your time report"
    msgBody = "Your time report has not been received. "
End If
msgBody = msgBody & "Please run the attached application (double click on the attachment) and fill out the form"
'set the body of the message
objmessage.Text = msgBody
'set the message class
objmessage.Type = RequestMsgType
'open recipients collection
Set objRecipCol = objmessage.Recipients
If objRecipCol Is Nothing Then
    MsgBox "Can't open msg's recipients"
    Exit Sub
End If
'add recipients
For ind = 0 To UserList.cUsers - 1
    If Not Reminder Then 'send to everybody
        Set objRecip = objRecipCol.Add(EntryID:=UserList.aUsers(ind).EntryID, _
                    Name:=UserList.aUsers(ind).DisplayName)

    Else 'if this is a reminder, send only to the people we don't have reports from
        If UserList.aUsers(ind).ReportIndex = E_NOT_FOUND Then
            Set objRecip = objRecipCol.Add(EntryID:=UserList.aUsers(ind).EntryID, _
                    Name:=UserList.aUsers(ind).DisplayName)
        Else
            GoTo continue
        End If

    End If
    If objRecip Is Nothing Then
        MsgBox "Can't add recipient"
        Exit Sub
    End If
continue:
Next ind
'open msg's field collection
Set objFieldCol = objmessage.Fields
If objFieldCol Is Nothing Then
    MsgBox "Can't open msg's fields collection"
    Exit Sub
End If
'set the report categories
'we can't write:
'Set prop = objFieldCol.Add(Name:=CatPropName, _
            Class:=vbString + vbArray, _
            Value:=Cats)
'because of the way VB passes array parameters
'so we first add a property and then set its value
Set prop = objFieldCol.Add(Name:=CatPropName, _
            Class:=vbString + vbArray)
If prop Is Nothing Then
        MsgBox "Can't add a prop"
        Exit Sub
    End If
prop.Value = Cats
'set the number of report categories
Set prop = objFieldCol.Add(Name:=NumCatPropName, _
            Class:=vbInteger, _
            Value:=cCats)
If prop Is Nothing Then
        MsgBox "Can't add a prop"
        Exit Sub
    End If

'set the report payperiod
Set prop = objFieldCol.Add(Name:=PayPeriodPropName, _
            Class:=vbDate, _
            Value:=PayPrd)
If prop Is Nothing Then
        MsgBox "Can't add a prop"
        Exit Sub
End If
'open msg's attachment collection
Set objAttachmentCol = objmessage.Attachments
If objAttachmentCol Is Nothing Then
    MsgBox "Can't open attachment collection"
    Exit Sub
End If
'create a new attachment
Set objAtt = objAttachmentCol.Add
If objAtt Is Nothing Then
    MsgBox "Can't add attachment"
    Exit Sub
End If
'send the client.exe as an attachment
objAtt.Type = mapiFileData      'means the file is contained withing the message
objAtt.position = 0             'no particular position
objAtt.ReadFromFile ClientExePath   'read in the file
objAtt.Name = ClientExeName      'set the file name
objmessage.Send showDialog:=False
Exit Sub
error_olemsg:
    MsgBox "Error " & Str(err) & ": " & Error$(err)
    Resume Next
End Sub
Private Sub btnAddCat_Click()
    lstCat.AddItem txtCat.Text  ' Add a client name to the list box.
    txtCat.Text = ""            ' Clear the text box.
    txtCat.SetFocus             ' Place focus back to the text box.
End Sub
Private Sub btnAddUsr_Click()
Dim objNewUsers As Object
Dim ind As Integer
On Error GoTo err_btnAdd_Click
If objSession Is Nothing Then
    MsgBox "must first create MAPI session and logon"
    Exit Sub
End If
Set objNewUsers = objSession.AddressBook( _
        Title:="Select Users", _
        forceResolution:=True, _
        recipLists:=1, _
        toLabel:="&New Users")  ' appears on button

ReDim Preserve UserList.aUsers(UserList.cUsers + objNewUsers.Count)
With objNewUsers
For ind = 0 To (objNewUsers.Count - 1) Step 1
    With .Item(ind + 1)
    UserList.aUsers(UserList.cUsers + ind).DisplayName = .Name
    UserList.aUsers(UserList.cUsers + ind).EntryID = .addressentry.id
    UserList.aUsers(UserList.cUsers + ind).ReportIndex = E_NOT_FOUND
    End With
Next ind
End With
UserList.cUsers = UserList.cUsers + objNewUsers.Count
PopulateUserList
Exit Sub
err_btnAdd_Click:
    If Not (err = 91) Then   ' object not set
           MsgBox "Unrecoverable Error:" & err
    End If
End Sub
Private Sub btnRemoveAllUsers_Click()
    lstUsers.Clear                                 ' Empty the list box.
    btnRemoveAllUsers.Enabled = False
    UserList.cUsers = 0
End Sub
Private Sub btnRemoveCat_Click()
Dim ind As Integer
    ind = lstCat.ListIndex              ' Get index.
    If ind >= 0 Then                    ' Make sure a list item is selected.
        lstCat.RemoveItem ind           ' Remove the item from the list box.
    Else
        Beep                            ' This should never occur, because Remove is always disabled if no entry is selected.
    End If
    ' Disable the Remove button if no entries are selected in the list box.
    btnRemoveCat.Enabled = (lstCat.ListIndex <> -1)
End Sub
Private Sub Form_Load()
Dim bFlag As Boolean
On Error GoTo error_olemsg
bFlag = Util_CreateSessionAndLogon()
If Not bFlag Then End
InitUserList
PopulateUserList
InitCategorylist
PopulateCatList
InitPayPeriod
Exit Sub
error_olemsg:
    If Not bFlag Then
        MsgBox "Error " & Str(err) & ": " & Error$(err)
        End
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
If Not objSession Is Nothing Then
        objSession.logoff
    End If

End Sub
Private Sub lstCat_Click()
    btnRemoveCat.Enabled = (lstCat.ListIndex <> -1)
End Sub
Private Sub lstUsers_Click()
    btnRemoveAllUsers.Enabled = (lstUsers.ListIndex <> -1)
End Sub
Private Sub lstUsers_DblClick()
On Error GoTo err
Dim ind As Integer
Dim AddrEntry As Object
    ind = lstUsers.ListIndex
    If ind >= 0 Then
        Set AddrEntry = objSession.GetAddressEntry(UserList.aUsers(ind).EntryID)
        If AddrEntry Is Nothing Then Exit Sub
        AddrEntry.details

    Else
        Beep
    End If
Exit Sub
    If Not (err = -2147221229) Then   ' object not set
           MsgBox "Unrecoverable Error:" & err
    End If
End Sub
Private Sub mnuAbout_Click()
    formAbout.Show 1
End Sub
Private Sub mnuCleanUp_Click()
On Error GoTo error_olemsg
Dim objReceivFolder As Object
Dim objmessages As Object
Dim objmessage As Object
If objSession Is Nothing Then
    MsgBox "Not logged on"
    Exit Sub
End If
GetReceivIPCFolder objReceivFolder
If objReceivFolder Is Nothing Then
    MsgBox "Can't open receive folder"
    Exit Sub
End If
Set objmessages = objReceivFolder.Messages
If objmessages Is Nothing Then
    MsgBox "Failed to open folder's Messages collection"
    Exit Sub
End If
Set objmessage = objmessages.getfirst(ReportMsgType)
Do While Not objmessage Is Nothing
    If Not objmessage.Unread Then
        objmessage.Delete
    End If
    Set objmessage = objmessages.getnext
Exit Sub
error_olemsg:
    MsgBox "Error " & Str(err) & ": " & Error$(err)
    Resume Next
End Sub
Private Sub mnuExit_Click()
    Unload Me
    'End
End Sub
Private Sub mnuGenerate_Click()
If formReport.CompileReport Then
    formReport.Show 1
End If
'user list may have changed
PopulateUserList
End Sub
Private Sub SaveCats()
On Error GoTo CheckError
Dim ind As Integer
Open CatsListFile For Output As #1
Write #1, CategoryList.cCats
ind = 0
Do While ind < CategoryList.cCats
    Print #1, CategoryList.aCats(ind)
    ind = ind + 1
Close #1
Exit Sub
CheckError:
MsgBox "Error saving user list"
End Sub
Private Sub SaveUsers()
On Error GoTo CheckError
Dim ind As Integer
'If UserList.cUsers = 0 Then Exit Sub
Open UserListFile For Output As #1
Write #1, UserList.cUsers
ind = 0
Do While ind < UserList.cUsers
    Print #1, UserList.aUsers(ind).DisplayName
    Print #1, UserList.aUsers(ind).EntryID
    ind = ind + 1
Close #1
Exit Sub
CheckError:
MsgBox "Error saving user list"
End Sub
Private Sub mnuSave_Click()
GetUserList
SaveUsers
GetCategoryList
SaveCats
End Sub
Private Sub mnuSend_Click()
GetUserList
GetCategoryList
MousePointer = WaitCursor
SendRequest CategoryList.cCats, CategoryList.aCats, PayPeriod, False
MousePointer = DefaultCursor
End Sub
Function Util_CreateSessionAndLogon() As Boolean
    On Error GoTo err_CreateSessionAndLogon
    Set objSession = CreateObject("MAPI.Session")
    If Not objSession Is Nothing Then
        objSession.Logon
    Else
        Util_CreateSessionAndLogon = False
        Exit Function
    End If
    Util_CreateSessionAndLogon = True
    Exit Function
err_CreateSessionAndLogon:
    Set objSession = Nothing
    If (err <> -2147221229) Then  ' VB4.0 uses "Err.Number"
        MsgBox "Unrecoverable Error:" & err
    End If
    Util_CreateSessionAndLogon = False
    Exit Function
error_olemsg:
    MsgBox "Error " & Str(err) & ": " & Error$(err)
    Resume Next
End Function
Sub GetUserList()
'empty for now
End Sub
Sub InitPayPeriod()
    PayPeriod = Date
End Sub
Sub InitUserList()
On Error GoTo CheckError
Dim ind As Integer
Dim cSavedUsers As Integer
Open UserListFile For Input As #1
Input #1, cSavedUsers
Debug.Print "found " & cSavedUsers & " saved users"
ReDim UserList.aUsers(cSavedUsers)
ind = 0
Do While ind < cSavedUsers
    Line Input #1, UserList.aUsers(ind).DisplayName
    Line Input #1, UserList.aUsers(ind).EntryID
    UserList.aUsers(ind).ReportIndex = E_NOT_FOUND
    ind = ind + 1
Close #1
UserList.cUsers = cSavedUsers
Exit Sub
CheckError:
UserList.cUsers = 0
End Sub
Sub InitCategorylist()
'Read saved cats from file
On Error GoTo CheckError
Dim ind As Integer
Dim cSavedCats As Integer
Open CatsListFile For Input As #1
Input #1, cSavedCats
Debug.Print "found " & cSavedCats & " saved categories"
ReDim CategoryList.aCats(cSavedCats)
ind = 0
Do While ind < cSavedCats
    Line Input #1, CategoryList.aCats(ind)
    ind = ind + 1
Close #1
CategoryList.cCats = cSavedCats
Exit Sub
CheckError:
CategoryList.cCats = 0
End Sub
Private Sub txtCat_Change()
    ' Enable the Add button if at least one character in the name is entered or changed.
    btnAddCat.Enabled = (Len(txtCat.Text) > 0)
End Sub
Sub PopulateUserList()
Dim ind As Integer
lstUsers.Clear
For ind = 0 To UserList.cUsers - 1
       lstUsers.AddItem UserList.aUsers(ind).DisplayName
Next ind
End Sub
Private Sub PopulateCatList()
Dim ind As Integer
lstCat.Clear
For ind = 0 To CategoryList.cCats - 1
    lstCat.AddItem CategoryList.aCats(ind)
Next ind
End Sub