[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

---