You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
760 lines
16 KiB
760 lines
16 KiB
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
|
|
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
|
|
Loop
|
|
|
|
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 = ""
|
|
Else
|
|
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
|
|
|
|
err:
|
|
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
|
|
Loop
|
|
|
|
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
|
|
Loop
|
|
|
|
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
|
|
Loop
|
|
|
|
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
|
|
Loop
|
|
|
|
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
|
|
Loop
|
|
|
|
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
|