Hello all,
I am trying to add a user from a sub-form which pulls details from Outlook. Once I press a button, it should save the record and add it to my table. For some reason it does not do that.
Here is the code in question:
Here is the full code for this sub-form:
I am trying to add a user from a sub-form which pulls details from Outlook. Once I press a button, it should save the record and add it to my table. For some reason it does not do that.
Here is the code in question:
Code:
' Add the entry
CurrentDb.Execute "INSERT INTO tblMember(fldLastName,fldFirstName,fldEmail,fldTradeID,fldSectionID)VALUES('" & txtLast.Value & "','" & txtFirst.Value & "','" & txtEmail.Value & "'," & lstTrade.Value & "," & lstSection.Value & ");"
' Exit the form
DoCmd.Close acForm, Me.Name, acSaveYes
' Update
Forms!frmMembers.Requery
Here is the full code for this sub-form:
Code:
Option Compare Database
Private Sub Form_Load()
lstTrade.Value = lstTrade.ItemData(0)
lstSection.Value = lstSection.ItemData(0)
If Len(Me.OpenArgs) > 0 Then
Dim nameArray() As String
nameArray() = Split(Me.OpenArgs, " ")
If UBound(nameArray) = 0 Then
txtLast.Value = nameArray(0)
ElseIf UBound(nameArray) = 1 Then
txtLast.Value = nameArray(0)
txtFirst.Value = nameArray(1)
End If
End If
End Sub
Private Sub lstSection_NotInList(NewData As String, Response As Integer)
Response = acDataErrContinue
AddNewSection NewData
End Sub
Private Sub lstTrade_NotInList(NewData As String, Response As Integer)
Response = acDataErrContinue
AddNewTrade NewData
End Sub
Private Sub cmdGetEmail_Click()
On Error GoTo ErrorHandler
Dim objOutlook As Outlook.Application
Set objOutlook = CreateObject("Outlook.Application")
Dim objNamespace As Outlook.NameSpace
Set objNamespace = objOutlook.GetNamespace("MAPI")
With objNamespace.Session.GetSelectNamesDialog
.ShowOnlyInitialAddressList = True
.SetDefaultDisplayMode olDefaultSingleName
.AllowMultipleSelection = False
.Caption = "Select Member"
.NumberOfRecipientSelectors = olShowNone
If .Display Then
'Recipients Resolved
With .Recipients(1)
txtLast.Value = .AddressEntry.GetExchangeUser.LastName
txtFirst.Value = .AddressEntry.GetExchangeUser.FirstName
txtEmail.Value = .AddressEntry.GetExchangeUser.PrimarySmtpAddress
End With
End If
End With
Set objNamespace = Nothing
Set objDialog = Nothing
Exit Sub
ErrorHandler:
MsgBox Err.Description, vbOKOnly, "Error #: " & Err.Number
Exit Sub
End Sub
Private Sub cmdOk_Click()
Dim Fail As Boolean: Fail = False
' Check to ensure the pertinate data has been intput
If Not Len(txtLast.Value) > 0 Then
txtLast.BackColor = RGB(255, 0, 0)
Fail = True
Else
txtLast.BackThemeColorIndex = 1
End If
If Not Len(txtFirst.Value) > 0 Then
txtFirst.BackColor = RGB(255, 0, 0)
Fail = True
Else
txtFirst.BackThemeColorIndex = 1
End If
If Not Len(lstTrade.Value) > 0 Then
lstTrade.BackColor = RGB(255, 0, 0)
Fail = True
Else
lstTrade.BackThemeColorIndex = 1
End If
If Not Len(lstSection.Value) > 0 Then
lstSection.BackColor = RGB(255, 0, 0)
Fail = True
Else
lstSection.BackThemeColorIndex = 1
End If
If Not Len(txtEmail.Value) > 0 Then
txtEmail.BackColor = RGB(255, 0, 0)
Fail = True
Else
txtEmail.BackThemeColorIndex = 1
End If
If Fail Then
With CreateObject("WScript.Shell")
Select Case .PopUp("Please fill in all the data in the red boxes before hitting Ok!", 2, "Information", 48)
Case 1, -1
Exit Sub
End Select
End With
End If
On Error GoTo ErrorHandler
' Add the entry
CurrentDb.Execute "INSERT INTO tblMember(fldLastName,fldFirstName,fldEmail,fldTradeID,fldSectionID)VALUES('" & txtLast.Value & "','" & txtFirst.Value & "','" & txtEmail.Value & "'," & lstTrade.Value & "," & lstSection.Value & ");"
' Exit the form
DoCmd.Close acForm, Me.Name, acSaveYes
' Update
Forms!frmMembers.Requery
Exit Sub
ErrorHandler:
If Err.Number <> 2046 Then
MsgBox Err.Description, vbOKOnly, "Error #: " & Err.Number
Exit Sub
End If
End Sub
Private Sub cmdCancel_Click()
On Error GoTo ErrorHandler
DoCmd.Close acForm, Me.Name, acSaveNo
Exit Sub
ErrorHandler:
If Err.Number <> 2046 Then
MsgBox Err.Description, vbOKOnly, "Error #: " & Err.Number
Exit Sub
End If
End Sub