How to add auto date based on date entered in another box 2

[suddu]

Hi Everybody. Thanks for all the wonderful and most helpful forum for access.
Here is my problem and I hope somebody will be able to help me.

I have a form and a subform, there is a field anmed Date Enrolled on the subform and then there are 3 more date fields like threemonthappointment and ninemonthappointment and oneyearappointment. All these three fields should be able to populate themselves based on the entry in Date Enrolled field on the form.

Here is the kicker , all these was working fine when the date enrolled field was on the main form and rest of the fields were on the subform. Then I was using in the default value for all three boxes the query which worked fine. It was Forms!Demographics![Date Enrolled]+90 for 3 months and so on. And I was able to get my values. But when the structure was modified to put the Date Enrolled field on the subform and modifying the expresion accordingly it didnot work . I have also tried various other suggestions on this forum but may be I am not able to apply them correctly or do not fit what i need.

Any and all the help will be greatly appreciated.

 

[THWatson]

suddu
In spite of the fact that the command button is to post the values to Outlook, could you run the code I gave you ahead of the code that posts the values to Outlook?

In other words...
Dim dteTemp As Date
Dim dteTemp2 As Date
Dim dteTemp3 As Date
Dim dteTemp4 As Date
dteTemp = Me.YourComboBoxName
Me.Date_Enrolled = dteTemp
Me.threemonthappointment = DateAdd("m", 3, dteTemp)
Me.ninemonthappointment = DateAdd("m", 9, dteTemp)
Me.oneyearappointment = DateAdd("yyyy", 1, dteTemp)

then follow with your code to post to Outlook.

Tom

 

[suddu]

It still doesnot work

 

[CajunCenturion]

Following up with THWatson's suggestion, is the command button on the subform or on the main form. Tom's code is assuming the command button is on the subform.

What happens if you step through Tom's code line by line?

Good Luck
--------------
As a circle of light increases so does the circumference of darkness around it. - Albert Einstein

 

[THWatson]

suddu
Obviously, we're overlooking something here.

Please check something for me...
Right click on each of the 4 Date fields, check their Properties, and give the Names for each.

Also, if the names are correct as we have them now, you might try this...
Make an additional command button on the subform, and put in the code I supplied, and see if it works to populate the 4 controls. If it does that will indicate we are on the right track.

I have to go now for a few hours. Will check back later.

Tom

 

[suddu]

Hi there, This is the complete code i have presently on my subform:

Option Compare Database
Dim cboOriginator As ComboBox

Private Sub AddAppt_Click()
On Error GoTo AddAppt_Err
' Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt
.Start = Me!Threemonthappointment & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!SSN

.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub

End Sub

Private Sub AddAppt1_Click()
On Error GoTo AddAppt1_Err
' Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook1 = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt
.Start = Me!Ninemonthappointment & " " & Me!ApptTime1
.Duration = Me!ApptLength1
.Subject = Me!SSN

.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook1 = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
Private Sub DateEnrolled_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set cboOriginator = DateEnrolled
' Unhide the calendar and give it the focus
Calendar4.Visible = True
Calendar4.SetFocus
' Match calendar date to existing date if present or today's date
If Not IsNull(cboOriginator) Then
Calendar4.Value = cboOriginator.Value
Else
Calendar4.Value = Date
End If
End Sub
Private Sub Date_of_call_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set cboOriginator = Date_of_call
' Unhide the calendar and give it the focus
Calendar4.Visible = True
Calendar4.SetFocus
' Match calendar date to existing date if present or today's date
If Not IsNull(cboOriginator) Then
Calendar4.Value = cboOriginator.Value
Else
Calendar4.Value = Date
End If
End Sub
Private Sub Form_Load()
Me.Calendar4.Today
End Sub
Private Sub Calendar4_Click()
cboOriginator.Value = Calendar4.Value
' Return the focus to the combo box and hide the calendar and
cboOriginator.SetFocus
Calendar4.Visible = False
' Empty the variable
Set cboOriginator = Nothing
End Sub
Private Sub Date_of_call_at_9_month_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set cboOriginator = Date_of_call_at_9_month
' Unhide the calendar and give it the focus
Calendar4.Visible = True
Calendar4.SetFocus
' Match calendar date to existing date if present or today's date
If Not IsNull(cboOriginator) Then
Calendar4.Value = cboOriginator.Value
Else
Calendar4.Value = Date
End If
End Sub
Private Sub Date_of_f_u_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set cboOriginator = Date_of_f_u
' Unhide the calendar and give it the focus
Calendar4.Visible = True
Calendar4.SetFocus
' Match calendar date to existing date if present or today's date
If Not IsNull(cboOriginator) Then
Calendar4.Value = cboOriginator.Value
Else
Calendar4.Value = Date
End If
End Sub
Private Sub Date_of_last_attempt_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Set cboOriginator = Date_of_last_attempt
' Unhide the calendar and give it the focus
Calendar4.Visible = True
Calendar4.SetFocus
' Match calendar date to existing date if present or today's date
If Not IsNull(cboOriginator) Then
Calendar4.Value = cboOriginator.Value
Else
Calendar4.Value = Date
End If
End Sub


Now i have 2 command buttons with each for their respective appointment to be added to outlook.

Again I tried making up another table and form and put it on the demographics form and then used the
=[Forms]![Demographics]!

.[Form]![DateEnrolled]+270 for ninemonthappointment and it worked again but not a good way to work it out. I have since reverted back to my original two forms only.

i haven't tried Tom's last suggestion yet but if you could let meknow where to insert the code in the above code would help, or if you guys can think any other modification to the issue may also help.
thanks

 

[suddu]

Hi Tom tried ur suggestion and inserted the code before the Send to outllok code in the comand button it does enter the date and send it to outlook at the same time but now it's changing the date in DateEnrolled to a date in 1899 and the threemonthappointment date to 3 months ahead in the year 1900. So in a way the code works but now entering wrong dates.

 

[suddu]

this is the portion of the code that i posted earlier with the modification and u already know the error as above

Private Sub AddAppt_Click()
On Error GoTo AddAppt_Err
Dim dteTemp As Date
Me.DateEnrolled = dteTemp
Me.Threemonthappointment = DateAdd("m", 3, dteTemp)

' Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt
.Start = Me!Threemonthappointment & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!SSN

.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub

End Sub

 

[CajunCenturion]

Three posts ago, you posted all the code from the subform. In that code, where are you assigning a value to Me.[Date Entrolled]?

In your most recent post, the problem is that
Dim dteTemp As Date
Me.DateEnrolled = dteTemp
dteTemp is never assigned a value.

Good Luck
--------------
As a circle of light increases so does the circumference of darkness around it. - Albert Einstein

 

[suddu]

Thanks a lot Tom and Cajun it was a great help and when i fixed the code it took care of the date error, so now it works great but now let me bring two other things if you guys can help with.

1. You see that in the code 5 messages above I have two command buttons for sending to outlook the values of those boxes , How can i achieve it by only clicking once and sending all the values to their respetive calender dast and time.
2. Also is their a way to put in outlook other messages apart from SSN like Patient Name, their phone numbers
etc.

Thanks once again

 

[CajunCenturion]

Best to see what you have now as working code before making any suggestions.

Good Luck
--------------
As a circle of light increases so does the circumference of darkness around it. - Albert Einstein

 

[suddu]

This is the working code only for the three month box:

Private Sub AddAppt_Click()
On Error GoTo AddAppt_Err
Dim dteTemp As Date
dteTemp = Me.DateEnrolled
Me.DateEnrolled = dteTemp
Me.Threemonthappointment = DateAdd("m", 3, dteTemp)

' Save record first to be sure required fields are filled.
DoCmd.RunCommand acCmdSaveRecord
' Exit the procedure if appointment has been added to Outlook.
If Me!AddedToOutlook = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Add a new appointment.
Else
Dim outobj As Outlook.Application
Dim outappt As Outlook.AppointmentItem
Set outobj = CreateObject("outlook.application")
Set outappt = outobj.CreateItem(olAppointmentItem)
With outappt
.Start = Me!Threemonthappointment & " " & Me!ApptTime
.Duration = Me!ApptLength
.Subject = Me!SSN

.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the AddedToOutlook flag, save the record, display a message.
Me!AddedToOutlook = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
AddAppt_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub

End Sub

 

[CajunCenturion]

I might try something like this:

Private Sub AddAppt_Click()

   On Error GoTo AddAppt_Err
      
   Dim outobj As Outlook.Application

   DoCmd.RunCommand acCmdSaveRecord
   If Me!AddedToOutlook = True Then
      MsgBox "This appointment already added to Microsoft Outlook"
   Else
      Set outobj = CreateObject("outlook.application")
      Me.threemonthappointment = DateAdd("m", 3, Me.DateEnrolled)
      Me.ninemonthappointment = DateAdd("m", 9, Me.DateEnrolled)
      Me.oneyearappointment = DateAdd("yyyy", 1, Me.DateEnrolled)
      AddAppointment outobj, Me!threemonthappointment
      AddAppointment outobj, Me!ninemonthappointment
      AddAppointment outobj, Me!oneyearappointment
      Set outobj = Nothing
      Me!AddedToOutlook = True
      DoCmd.RunCommand acCmdSaveRecord
      MsgBox "Appointment Added!"
   End If
      
Exit_AddAppt_Click:
Exit Sub

AddAppt_Err:
         
   MsgBox "Error " & Err.Number & vbCrLf & Err.Description
   Resume Exit_AddAppt_Click
   
End Sub
      
Private Sub AddAppointment(outobj As Object, rVar_ApptStart As Variant)

   On Error GoTo AddAppointment_Err
   
   Dim outappt As Outlook.AppointmentItem
   
   Set outappt = outobj.CreateItem(olAppointmentItem)
   With outappt
      .Start = rVar_ApptStart & " " & Me!ApptTime
      .Duration = Me!ApptLength
      .Subject = Me!SSN
      .Save
   End With
   Set outappt = Nothing

Exit_AddAppointment:
Exit Sub

AddAppointment_Err:
         
   MsgBox "Error " & Err.Number & vbCrLf & Err.Description
   Resume Exit_AddAppointment

End Sub

Good Luck
--------------
As a circle of light increases so does the circumference of darkness around it. - Albert Einstein

 

[suddu]

Thanks Cajun a lot. your code worked word to word.

But remeber I had also asked if there was a way to put other things in the subject portion apart from SSn as it would be weired that it only show some numbers. i think it would be good if I could also see the patient name and phone number with SSn. Now both of these are on the demographics form we were talking about and not on the subform.

Any help will be greatly appreciated