Howdy, Stranger!

It looks like you're new here. If you want to get involved, click one of these buttons!

Categories

Use Timer1 to Load Data to Form

Greetings

I am busy with a 'Reminder' programme.

My problem is in using the Timer1 control to auto load a form, ie when date and time in database equals system date and time.

My code is as follows :

Option Explicit
Dim CN As ADODB.Connection
Dim RS As ADODB.Recordset
Dim Temp As Long
Dim i As String
Dim MyDate As Date
Dim MyTime As Date

Private Sub OpenConnection()

'Open database to be used

Set CN = New ADODB.Connection
CN.ConnectionString = "Provider=Microsoft.jet.oledb.4.0;Data Source=" & App.Path & "diary.mdb;persist security info=false;Jet OLEDB:Database password="
CN.Open

End Sub

Private Sub ReturnRecords()

Set RS = New ADODB.Recordset

OpenConnection

RS.ActiveConnection = CN
RS.Source = "select * from [reminder] order by idate"
RS.CursorType = adOpenStatic
RS.LockType = adLockOptimistic
RS.Open

End Sub

Public Sub PopulateControls()

If RS.RecordCount > 0 Then
dtpDate.Value = RS!idate & ""
dtpTime.Value = RS!itime & ""
txtSubject.Text = RS!isubject & ""
txtNotes.Text = RS!inotes & ""

lblPosition.Caption = " Record : " & RS.AbsolutePosition & " of " & RS.RecordCount
lblPosition.ForeColor = vbBlack
chkSearch.Visible = True
txtSearch.Visible = True
txtSearch.Text = "<<Type Date Here>>"
cmdSearch.Visible = True
cmdRefresh.Visible = True
cmdDelete.Visible = True
cmdEdit.Visible = True

cmdFirst.Visible = True
cmdNext.Visible = True
cmdLast.Visible = True
cmdPrev.Visible = True

Else
lblPosition.Caption = " No Records in Database..."
lblPosition.ForeColor = vbRed
chkSearch.Visible = False
txtSearch.Visible = False
cmdSearch.Visible = False
cmdDelete.Visible = False
cmdEdit.Visible = False

cmdFirst.Visible = False
cmdNext.Visible = False
cmdLast.Visible = False
cmdPrev.Visible = False

End If

End Sub

Private Sub cmdSave_Click()

RS!idate = dtpDate.Value
RS!itime = dtpTime.Value
RS!isubject = txtSubject.Text & ""
RS!inotes = txtNotes.Text & ""

RS.Update 'Save changes New or Edited Record.

If txtSubject.Text = "" Then
MsgBox "You must enter text in the Subject Field...", vbOKOnly + vbCritical, "Warning..."
txtSubject.SetFocus
'Change Frame Color to Green.
EnableSave
cmdCancel.Enabled = False

Else
MsgBox "Record was Saved...", vbInformation, "Saved..."
DisableSave
NormalColors
End If

PopulateControls

cmdSearch.Enabled = False
txtSearch.Enabled = False

End Sub

Private Sub cmdMin_Click()

'To hide the form, but keep the application running.

frmMain.Visible = False

End Sub

Private Sub Form_Load()

DimX Me

dtpDate.Value = Date
dtpTime.Value = Time

ReturnRecords

PopulateControls

DisableSave

cmdSearch.Default = True

cmdSearch.Enabled = False
txtSearch.Enabled = False

'To start the monitoring process
'AlertShow

End Sub

Public Function AlertShow() ' as Boolean

'Function to populate the controls when the date and time in the database equals the system date and time.

'ReturnRecords

If (RS!idate.Value = MyDate) And (RS!itime.Value = MyTime) Then
frmAlert!lblDate.Caption = RS!Date.Value
frmAlert!lblTime.Caption = RS!itime.Value
frmAlert!lblSubject.Caption = RS!isubject.Value
frmAlert!lblNotes.Caption = RS!inotes.Value
frmMain.Hide
frmAlert.Show
End If

'AlertShow = True

End Function

Private Sub mnuExit_Click()

i = MsgBox("Are You Sure You Want To EXIT?", vbQuestion + vbYesNo, "Confirm Exit ...")

If i = vbYes Then
Unload Me
Me.Hide
End
Else:
Exit Sub
End If

End Sub

Private Sub tmrAlert_Timer()

'Call function with timer1 to auto load frmAlert.

AlertShow

End Sub

Private Sub tmrUpdate_Timer()

'Code from PSCode relating to the LED Clock.

Dim Temp As Integer, Number As Integer, Count As Integer, Temp_Time As String
Temp_Time = Time
If Mid(Temp_Time, 2, 1) = ":" Then Temp_Time = "0" & Temp_Time
For Temp = 1 To Len(Temp_Time)
If IsNumeric(Mid(Temp_Time, Temp, 1)) Then
Count = Count + 1
Number = Val(Mid(Temp_Time, Temp, 1)) + 1
If Number > 10 Then Number = 1
imgNumber(Count).Picture = imlNumbers.ListImages(Number).Picture
End If
Next Temp

End Sub

Private Sub chkSearch_Click()

'If Checked box is Clicked some Buttons is Enabled & Some Disabled.
If chkSearch.Value = Checked Then
EnableSave

cmdSave.Enabled = False

txtSearch.Enabled = True
cmdSearch.Enabled = True

txtSearch.SetFocus
Else
DisableSave
txtSearch.Enabled = False
cmdSearch.Enabled = False
End If

End Sub

Private Sub cmdAdd_Click()

'When Add cmd is selected all Text Boxes will go blank to enter data into.
RS.AddNew
dtpDate.Value = Date
dtpTime.Value = Time
txtSubject.Text = ""
txtNotes.Text = ""

EnableSave 'Certain cmd Buttons will be disabled fo time being.

EditColors

lblPosition.Caption = " New Record..." 'Will be displayed to shows busy with a new Record.
lblPosition.ForeColor = vbBlack

End Sub

Private Sub cmdCancel_Click()

'If there are no Records in the database then the following will occur.
If RS.RecordCount < 0 Then
'Goto the BlankFields procedure

dtpDate.Value = Date
dtpTime.Value = Time
txtSubject.Text = ""
txtNotes.Text = ""

'If there are records in the Databse the following procedures occur.
Else

RS.CancelUpdate 'Use to cancel a action or command.

DisableSave 'Certain cmd Buttons will be disabled fo time being.

PopulateControls 'Return Records and fields to point before Changes.

NormalColors 'Change Green frame back to black.

'Enabeling and Value is False.
chkSearch.Value = False
cmdSearch.Enabled = False
txtSearch.Enabled = False
cmdRefresh.Enabled = True

NormalColors 'Change back Colors after Edited Text is Saved.

End If

End Sub

Private Sub cmdDelete_Click()

'Confirmation when Delete Button is selected.
Dim i As Integer

i = MsgBox("Are you sure you want to Delete the Current Record...?", vbQuestion + vbYesNo, "Deleting Confirmation...")

If i = vbYes Then
RS.Delete
MsgBox "Record was Deleted...", vbInformation, "Deleted..."
RS.MoveFirst
PopulateControls
End If

If RS.RecordCount = 0 Then
lblPosition.Caption = "Records Deleted... Click to return to other Records"
BlankFields
End If

lblPosition.Enabled = True

End Sub

Private Sub cmdEdit_Click()

EnableSave 'Certain cmd Buttons will be disabled fo time being.

EditColors

lblPosition.Caption = " Edit Mode..." 'Indicate Record id in Edit Mode.

End Sub

Private Sub cmdFirst_Click()

If RS.RecordCount > 0 Then
RS.MoveFirst 'Move to First Record.
End If

If cmdAdd.Visible = False Then
PopulateControls 'Show all Records.
DisableCommands
Else
PopulateControls
End If

End Sub

Private Sub cmdLast_Click()

If RS.RecordCount > 0 Then
RS.MoveLast 'Move to Last Record.
End If

If cmdAdd.Visible = False Then
PopulateControls 'Show all Records.
DisableCommands
Else
PopulateControls
End If

End Sub

Private Sub cmdNext_Click()

If RS.RecordCount > 0 Then
RS.MoveNext 'Move to Next Record.
End If

If RS.EOF = True Then 'If End Of File Goto Last Record.
RS.MoveLast
End If

If cmdAdd.Visible = False Then
PopulateControls 'Show all Records.
DisableCommands
Else
PopulateControls
End If

End Sub

Private Sub cmdPrev_Click()

If RS.RecordCount > 0 Then
RS.MovePrevious 'Move to Last Record.
End If

If RS.BOF = True Then 'If Beginning Of File Goto First Record.
RS.MoveFirst
End If

If cmdAdd.Visible = False Then
PopulateControls 'Show all Records.
DisableCommands
Else
PopulateControls
End If

End Sub

Public Sub EnableSave()

cmdAdd.Enabled = False

cmdEdit.Enabled = False

cmdDelete.Enabled = False

cmdSearch.Enabled = False
txtSearch.Enabled = False
chkSearch.Enabled = False

cmdSave.Enabled = True

cmdCancel.Enabled = True

dtpDate.Enabled = True
dtpTime.Enabled = True
txtSubject.Locked = False
txtNotes.Locked = False

cmdFirst.Enabled = False
cmdPrev.Enabled = False
cmdNext.Enabled = False
cmdLast.Enabled = False

End Sub

Public Sub DisableSave()

cmdAdd.Enabled = True

cmdEdit.Enabled = True

cmdSearch.Enabled = True
txtSearch.Enabled = True
chkSearch.Enabled = True

cmdDelete.Enabled = True

cmdSave.Enabled = False

cmdCancel.Enabled = False

dtpDate.Enabled = False
dtpTime.Enabled = False
txtSubject.Locked = True
txtNotes.Locked = True


cmdFirst.Enabled = True
cmdPrev.Enabled = True
cmdNext.Enabled = True
cmdLast.Enabled = True

If RS.RecordCount > 0 Then
lblPosition.Caption = " Record : " & RS.AbsolutePosition & " of " & RS.RecordCount
End If

End Sub

Private Sub Form_Unload(Cancel As Integer)

Unload Me
Set frmMain = Nothing

End Sub

Private Sub lblSurname_DblClick()

'Sort Records by Name.
Dim st As String

st = dtpDate.Value

RS.Close
RS.Source = "SELECT * FROM [reminder] ORDER BY idate"
RS.Open

RS.MoveFirst
RS.Find "idate LIKE '" & st & "'"
cmdFirst_Click

PopulateControls

End Sub

'Private Sub txtCel_LostFocus()

'txtCel.Text = Format(txtCel.Text, "000 000 0000") 'Sets date format to be displayed.

'End Sub

Private Sub txtSearch_Change()

cmdSearch.Default = True 'Search Command button becomes Default button.

End Sub

Private Sub txtSearch_GotFocus()

txtSearch.SelStart = 0 'Start at beginning of field.
txtSearch.SelLength = Len(txtSearch.Text) 'Type over highlighted text.
txtSearch.BackColor = vbYellow

End Sub

Private Sub CmdRefresh_Click()

If cmdAdd.Visible = False Then
chkSearch.Value = Unchecked
txtSearch.Text = "<<Type Date Here>>"
DisableCommands
Else
chkSearch.Value = Unchecked
txtSearch.Text = "<<Type Date Here>>"
txtSearch.BackColor = vbWhite
End If

End Sub

Private Sub NormalColors()

'When Cancel is Selected Shape4 Border change back to Black.
Shape1.BorderColor = vbBlack
Shape1.BorderWidth = 3
dtpDate.CalendarBackColor = vbWhite
dtpTime.CalendarBackColor = vbWhite
txtSubject.BackColor = vbWhite
txtNotes.BackColor = vbWhite

End Sub

Private Sub EditColors()

'When Cancel is Selected Shape4 Border change back to Black.
Shape1.BorderColor = vbBlue
Shape1.BorderWidth = 3
dtpDate.CalendarBackColor = vbYellow
dtpTime.CalendarBackColor = vbYellow
txtSubject.BackColor = vbYellow
txtNotes.BackColor = vbYellow

End Sub

Private Sub NoRecords()

Dim Q As Integer

If RS.RecordCount < 1 Then
'frmGeneralTelephoneNumbers.Show
Q = MsgBox("No Records in Database, Do you want to Add a Record...?", vbQuestion + vbYesNo, "Adding Confirmation...")
End If

If Q = vbYes Then
cmdAdd_Click
ElseIf Q = vbNo Then
'frmGeneralTelephoneNumbers.Hide
frmMain.Show
End If
End Sub

Private Sub BlankFields()

dtpDate.Value = Date
dtpTime.Value = Time
txtSubject.Text = ""
txtNotes.Text = ""

End Sub

Private Sub DisableCommands()

cmdAdd.Visible = False
cmdEdit.Visible = False
cmdDelete.Visible = False
cmdSave.Visible = False

cmdFirst.Enabled = False
cmdNext.Enabled = False
cmdLast.Enabled = False
cmdPrev.Enabled = False

End Sub

Private Sub ClearText()

For i = 1 To Me.Controls.Count - 1
If TypeOf Me.Controls(i) Is TextBox Then
Me.Controls(i).Text = ""
End If
Next i

End Sub

Private Sub Form_Paint()

'Code from PSCode to tile pic on form

Dim x As Single, y As Single
Dim Pheight As Single, Pwidth As Single

Pwidth = Picture1.ScaleWidth
Pheight = Picture1.ScaleHeight
y = 0
Do While y < ScaleHeight
x = 0
Do While x < ScaleWidth
PaintPicture Picture1.Picture, _
x, y, Pwidth, Pheight
x = x + Pwidth
Loop
y = y + Pheight
Loop

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)

mnuExit_Click

End Sub

Could someone please help? I am still a novice programmer.

Thanking You in Advance
Julian
Sign In or Register to comment.