-
Nov 13th, 2014, 08:00 AM
#1
Thread Starter
New Member
[ACCESS] Export/Create clickable link to specific record in access database
Hello,
I have an Access form, that collects data, tracks a workflow, and schedules reminders/appointments in outlook.
Is it possible to have a "clickable" link to the specific record that the appointment is being scheduled for, as part of the payload of the appointment scheduler portion of the code?
Hope that makes sense... Another way of stating... When I go to the appointment in outlook, in addition to the information already being sent with the appointment, i would like to have a link in the appointment body, that i could click and it would open the access database form with the current record data populating the field.
I am using access 2013, but saved in 07 to 13 file format.
Here is the code: (and if anyone would help clean up / shorten / simplify / streamline / etc... ) i would greatly appreciate. I feel like the code is unnecessarily very repetitive. I'm new to much of this.
Code:
Option Compare Database
Private Sub sch24_Click()
On Error GoTo sch24_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!TfHourAo = 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 = IIf(Weekday(Date) = 6, Date + 3, IIf(Weekday(Date) = 7, Date + 3, Date + 1))
.Subject = "24-hr. Telephone Call"
.Body = "Call " & Me!FirstName & " " & Me!LastName & " for their 24 hour phone call." & vbNewLine & "Patient ID:" & Me!ID & vbNewLine & "Cell phone number: " & Me!CellPhone & vbNewLine & "Home phone number: " & Me!HomePhone
.AllDayEvent = True
.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the 24 hour ao flag, save the record, display a message.
Me!TfHourAo = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
sch24_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
Private Sub sch48_Click()
On Error GoTo sch48_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!FeHourAo = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Exit the procedure if the previous appointment has not been completed.
ElseIf Me!Check24C = False Then
MsgBox "Please complete the 24 Hour followup before scheduling the 48 hour task!"
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 = IIf(Weekday(Date) = 6, Date + 3, IIf(Weekday(Date) = 7, Date + 3, Date + 1))
.Subject = "48-hr. Telephone Call"
.Body = "Call " & Me!FirstName & " " & Me!LastName & " for their 24 hour phone call." & vbNewLine & "Patient ID:" & Me!ID & vbNewLine & "Cell phone number: " & Me!CellPhone & vbNewLine & "Home phone number: " & Me!HomePhone
.AllDayEvent = True
.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the 48 hour ao flag, save the record, display a message.
Me!FeHourAo = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
sch48_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
Private Sub sch1w_Click()
On Error GoTo sch1w_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!OWkAo = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Exit the procedure if the previous appointment has not been completed.
ElseIf Me!Check48C = False Then
MsgBox "Please complete the 48 Hour followup before scheduling the 1 week task!"
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 = IIf(Weekday(Date) = 7, Date + 9, IIf(Weekday(Date) = 1, Date + 9, Date + 7))
.Subject = "1-wk. Telephone Call"
.Body = "Call " & Me!FirstName & " " & Me!LastName & " for their 1 week phone call." & vbNewLine & "Patient ID:" & Me!ID & vbNewLine & "Cell phone number: " & Me!CellPhone & vbNewLine & "Home phone number: " & Me!HomePhone
.AllDayEvent = True
.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the 1 week ao flag, save the record, display a message.
Me!OWkAo = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
sch1w_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
Private Sub sch1m_Click()
On Error GoTo sch1m_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!OMoAo = True Then
MsgBox "This appointment already added to Microsoft Outlook"
Exit Sub
' Exit the procedure if the previous appointment has not been completed.
ElseIf Me!Check1WkC = False Then
MsgBox "Please complete the 1 week followup before scheduling the 1 month task!"
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 = IIf(Weekday(Date) = 7, Date + 30, IIf(Weekday(Date) = 1, Date + 30, Date + 28))
.Subject = "1 Month Telephone Call"
.Body = "Call " & Me!FirstName & " " & Me!LastName & " for their 1 month phone call." & vbNewLine & "Patient ID:" & Me!ID & vbNewLine & "Cell phone number: " & Me!CellPhone & vbNewLine & "Home phone number: " & Me!HomePhone
.AllDayEvent = True
.Save
End With
End If
' Release the Outlook object variable.
Set outobj = Nothing
' Set the 1 month ao flag, save the record, display a message.
Me!OMoAo = True
DoCmd.RunCommand acCmdSaveRecord
MsgBox "Appointment Added!"
Exit Sub
sch1m_Err:
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
Exit Sub
End Sub
The above code continues on for 2 months, 3 months, 4 months ... 1 year
Then more repetitive code as follows:
Code:
Private Sub Check24C_AfterUpdate()
If Me.Check24C = True Then
Me.Date24C = Date
End If
End Sub
Private Sub Check48C_AfterUpdate()
If Me.Check48C = True Then
Me.Date48C = Date
End If
End Sub
Private Sub Check1WkC_AfterUpdate()
If Me.Check1WkC = True Then
Me.Date1WkC = Date
End If
End Sub
Private Sub Check1MoC_AfterUpdate()
If Me.Check1MoC = True Then
Me.Date1MoC = Date
End If
End Sub
Private Sub Check2MoC_AfterUpdate()
If Me.Check2MoC = True Then
Me.Date2MoC = Date
End If
End Sub
Continues on through 3,4,5 months, to a year...
Then the "search for record by id code"
Code:
Private Sub cmdSearch_Click()
Dim strPatientRef As String
Dim strSearch As String
'Check txtSearch for Null value or Nill Entry first.
If IsNull(Me![txtSearch]) Or (Me![txtSearch]) = "" Then
MsgBox "Please enter a value!", vbOKOnly, "Invalid Search Criterion!"
Me![txtSearch].SetFocus
Exit Sub
End If
'---------------------------------------------------------------
'Performs the search using value entered into txtSearch
'and evaluates this against values in ID
DoCmd.ShowAllRecords
DoCmd.GoToControl ("ID")
DoCmd.FindRecord Me!txtSearch
ID.SetFocus
strPatientRef = ID.Text
txtSearch.SetFocus
strSearch = txtSearch.Text
'If matching record found sets focus in ID and shows msgbox
'and clears search control
If strPatientRef = strSearch Then
MsgBox "Match Found For: " & strSearch, , "Congratulations!"
ID.SetFocus
txtSearch = ""
'If value not found sets focus back to txtSearch and shows msgbox
Else
MsgBox "Match Not Found For: " & strSearch & " - Please Try Again.", _
, "Invalid Search Criterion!"
txtSearch.SetFocus
End If
End Sub
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|