I'm pretty new at VBA. I have a form with a text box and a check box. If I open the form and click the check box without populating the text box, I get a message box to enter comments.
However, in the same session, if I unchecked the box and recheck it, I do not get the message box to enter comments even tho the text box is blank.
How can I get the code to "refire" in the same session to give me the message box to enter comments?
Below is my code:
Private Sub Check29_Click()
If IsNull(Me.Text16) Then
MsgBox "Comments are Required.", vbCritical
Me.Check29 = Null
Exit Sub
Else
If Me.Check29 = -1 Then
Dim RS As DAO.Recordset
Set RS = CurrentDb.OpenRecordset("Exclusions", dbOpenDynaset)
RS.AddNew
RS("HW535ID") = Me![HWID]
RS("Excluded") = "Yes"
RS("BOA Assignee") = Me![AssignedBA]
RS("Comments") = Me![Text16]
RS("CheckBox") = Me![Check29]
RS("Date of Exclusion") = Me![Text115]
RS("ReviewID") = Me![Text33]
RS.Update
RS.Close
Set RS = Nothing
Exit Sub
Else
DoCmd.SetWarnings False
DoCmd.OpenQuery ("RemoveExclusion")
Me.Text16 = Null
Exit Sub
End If
End If
End Sub
I can see a logic problem in the code. Please be aware that this line:
Me.Check29 = Null
will re-trigger the _click event and produce unexpected results. And it is also incorrect (should be Me.Check29.Value=False). Please try the revised version below:
Declare a module level variable
Option Explicit
Private bCancel as Boolean
The event code (I also made more corrections):
Private Sub Check29_Click()
if bCancel Then Exit Sub
bCancel = False
If Trim(Me.Text16.Text) = vbnullstring Then
MsgBox "Comments are Required.", vbCritical
bCancel = True
Me.Check29.Value = False
bCancel = False
Exit Sub
Else
If Me.Check29.Value = True Then
Dim RS As DAO.Recordset
Set RS = CurrentDb.OpenRecordset("Exclusions", dbOpenDynaset)
RS.AddNew
RS("HW535ID") = Me![HWID]
RS("Excluded") = "Yes"
RS("BOA Assignee") = Me![AssignedBA]
RS("Comments") = Me![Text16]
RS("CheckBox") = Me![Check29]
RS("Date of Exclusion") = Me![Text115]
RS("ReviewID") = Me![Text33]
RS.Update
RS.Close
Set RS = Nothing
Exit Sub
Else
DoCmd.SetWarnings False
DoCmd.OpenQuery ("RemoveExclusion")
Me.Text16.Text = vbnullstring
Exit Sub
End If
End If
End Sub
Private Sub Check29_Click()
If bCancel Then Exit Sub
bCancel = False
Me.Text16.SetFocus
If Trim(Me.Text16.Text) = vbNullString And Me.Check29.Value = True Then
MsgBox "Comments are Required.", vbCritical
bCancel = True
Me.Check29.Value = False
bCancel = False
Exit Sub
Else
If Me.Check29.Value = True Then
Dim RS As DAO.Recordset
Set RS = CurrentDb.OpenRecordset("Exclusions", dbOpenDynaset)
RS.AddNew
RS("HW535ID") = Me![HWID]
RS("Excluded") = "Yes"
RS("BOA Assignee") = Me![AssignedBA]
RS("Comments") = Me![Text16]
RS("CheckBox") = Me![Check29]
RS("Date of Exclusion") = Me![Text115]
RS("ReviewID") = Me![Text33]
RS.Update
RS.Close
Set RS = Nothing
Exit Sub
Else
If Me.Check29.Value = False Then
DoCmd.SetWarnings False
DoCmd.OpenQuery ("RemoveExclusion")
Me.Text16 = ""
Exit Sub
End If
End If
End If
End Sub
Related
I am trying to run a if statement to send an email if the sub has run and is successful.
The current code I am trying is
Private Sub SendButton_Click()
Call Populate
If Populate = True Then
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save
With EmailItem
.Subject = "New ePRF Available"
.Body = "I have completed a new e-PRF"
.To = ""
.Importance = olImportanceNormal
.attachments.Add Doc.FullName
.Send
End With
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Else
Call Populate
End If
End Sub
This is something I have never really done before so am very confused! Any help would be grateful!
Thanks
Make Populate a function and have it return a boolean value, then check that value in SendButton_Click
I made a nonsense populate to show the general idea.
Option Explicit
Private Sub SendButton_Click()
If populate() Then 'Test the return
Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument
Doc.Save
With EmailItem
.Subject = "New ePRF Available"
.Body = "I have completed a new e-PRF"
.To = ""
.Importance = olImportanceNormal
.attachments.Add Doc.FullName
.Send
End With
Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Else
Call populate 'This is probably not what you actually want, but hard to tell without seeing populate
End If
End Sub
Function populate() As Boolean 'specify the return type
Dim returnval As Boolean
Dim x As Boolean
Dim y As Boolean
returnval = True 'Start with true, if anything is false below flip the value
x = True
y = False
'just showing the flow, you would be checking your userform values here
If Not x Then
returnval = False
ElseIf Not y Then
returnval = False
End If
populate = returnval 'return the value
End Function
I have a form that has Work Orders, PK=OrderID. A subform that has the OrderDetails, PK=OrderDetailsID. And a subform on that subform that has OrderDetailAccessories, PK=OrderAccID.
When I set a check box on the main form to True, I want all the check boxes for the subform OrderDetails to change to True and set the CompDate to todays date AND all the check boxes for it's subform OrderDetailsAccessories to change to True and set the CompDate to today's date.
In my code, the recordset rs returns the records expected but I get an empty recordset for rs2. I stepped through the code and orddetid returns the correct value.
Private Sub IsComplete_AfterUpdate()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim rs2 As DAO.Recordset
Dim strItemComp As String
Dim strAccComp As String
Dim ordid As Long
Dim orddetid As Long
ordid = Me.txtOrdID
strItemComp = "SELECT OrderDetailID, IsComplete, CompDate FROM tblOrderDetails WHERE OrderID = " & ordid
strAccComp = "SELECT OrderAccID, IsComplete, CompDate FROM tblOrderAcc WHERE OrderDetailID = " & orddetid
Set db = CurrentDb
Set rs = db.OpenRecordset(strItemComp)
If Me.IsComplete = True Then
If MsgBox("Marking main order complete will mark ALL items and accessories for this Order as complete!", vbYesNo, "Are you sure?") = vbYes Then
Me!txtCompletionDate = Date
rs.MoveFirst
Do Until rs.EOF
If rs!IsComplete = False Then
rs.Edit
rs!IsComplete = True
rs!CompDate = Date
rs.Update
End If
orddetid = rs.Fields("OrderDetailID").Value
Debug.Print orddetid
Set rs2 = db.OpenRecordset(strAccComp)
If rs2.RecordCount > 0 Then
rs2.MoveFirst
Do Until rs2.EOF
If rs2!IsComplete = False Then
rs2.Edit
rs2!IsComplete = True
rs2!CompDate = Date
rs2.Update
End If
rs2.MoveNext
Loop
End If
rs.MoveNext
Loop
Me.Dirty = False
Exit Sub
Else
Me.Undo
End If
Else
Me.txtCompletionDate = Null
Exit Sub
End If
Me.Dirty = False
End Sub
You must update strAccComp for each record, something like:
If Me.IsComplete = True Then
If MsgBox("Marking main order complete will mark ALL items and accessories for this Order as complete!", vbYesNo, "Are you sure?") = vbYes Then
Me!txtCompletionDate = Date
Me.Dirty = False
Set rs = Me!NameOfSubformControl.Form.RecordsetClone
rs.MoveFirst
Do Until rs.EOF
If rs!IsComplete = False Then
rs.Edit
rs!IsComplete = True
rs!CompDate = Date
rs.Update
End If
strAccComp = "SELECT OrderAccID, IsComplete, CompDate FROM tblOrderAcc WHERE OrderDetailID = " & rs!orddetid.Value
Set rs2 = CurrentDb.OpenRecordset(strAccComp)
If rs2.RecordCount > 0 Then
rs2.MoveFirst
Do Until rs2.EOF
If rs2!IsComplete = False Then
rs2.Edit
rs2!IsComplete = True
rs2!CompDate = Date
rs2.Update
End If
rs2.MoveNext
Loop
End If
rs2.Close
rs.MoveNext
Loop
rs.Close
End If
End If
I want to determine if something has changed in a catpart that would drive a change in a body, but the change hasnt been done because update is set to manual.
I have tried:
if part.product.update = true then
'do something
else
'do something else
endif
However this just forces an update and doesnt tell me if one was required.
I worked out a solution (see below)
'#####################
Function func_CheckNoModsSinceLastSaved() As Boolean
func_CheckNoModsSinceLastSaved = False
Dim flg_NoModsSinceLastSaved As Boolean
flg_NoModsSinceLastSaved = False
If Right(CATIA.ActiveDocument.FullName, 11) = ".CATProduct" Then
Dim productDocument1 As ProductDocument
Set productDocument1 = CATIA.ActiveDocument
Dim product1 As Product
Set product1 = productDocument1.Product
flg_NoModsSinceLastSaved = productDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
product1.Update
flg_NoModsSinceLastSaved = productDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
Set productDocument1 = Nothing
ElseIf Right(CATIA.ActiveDocument.FullName, 8) = ".CATPart" Then
Dim partDocument1 As PartDocument
Set partDocument1 = CATIA.ActiveDocument
flg_NoModsSinceLastSaved = partDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
partDocument1.Part.Update
flg_NoModsSinceLastSaved = partDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
Set partDocument1 = Nothing
ElseIf Right(CATIA.ActiveDocument.FullName, 11) = ".CATDrawing" Then
Dim drawingDocument1 As DrawingDocument
Set drawingDocument1 = CATIA.ActiveDocument
flg_NoModsSinceLastSaved = drawingDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
drawingDocument1.Update
flg_NoModsSinceLastSaved = drawingDocument1.Saved
If flg_NoModsSinceLastSaved Then
func_CheckNoModsSinceLastSaved = True
Else
func_CheckNoModsSinceLastSaved = False
MsgBox "Modified Since Last Saved"
End If
Set drawingDocument1 = Nothing
Else
MsgBox "ERROR: Unidentified File Type!", vbCritical + vbOKOnly, ""
End If
End Function
'#####################
Check CATIA Settings
Set mySettControlers = CATIA.SettingControllers
Set myPartInfraSetting = mySettControlers.Item("CATMmuPartInfrastructureSettingCtrl")
Check how is set myPartInfraSetting.UpdateMode and see if is catManualUpdate or catAutomaticUpdate
i have 2 menu buttons that i want added in outlook menu after help menu. i made the code to add the buttons but it just adds 2 more buttons every time i reopen outlook even if the 2 menu buttons are there already . Any help is welcomed.
Function ToolBarExists(strName As String) As Boolean
Dim tlbar As commandBar
For Each tlbar In ActiveExplorer.CommandBars
If tlbar.Name = strName Then
ToolBarExists = True
Exit For
End If
Next tlbar
End Function
Sub TBarExistsbutton1()
If ToolBarExists("button1") Then
If ActiveExplorer.CommandBars("button1").Visible = True Then
ActiveExplorer.CommandBars("button1").Visible = False
Else
ActiveExplorer.CommandBars("button1").Visible = True
End If
Else
Call a123
End If
End Sub
Sub TBarExistsbutton2()
If ToolBarExists("button2") Then
If ActiveExplorer.CommandBars("button2").Visible = True Then
ActiveExplorer.CommandBars("button2").Visible = False
Else
ActiveExplorer.CommandBars("button2").Visible = True
End If
Else
Call a1234
End If
End Sub
Sub a123()
Dim outl As Object
Dim msg As Object
Set outl = CreateObject("Outlook.Application")
Dim objBar As Office.commandBar
Dim objButton As Office.commandBarButton
Set objBar = Application.ActiveWindow.CommandBars("Menu Bar")
Set objButton = objBar.Controls.Add(msoControlButton)
With objButton
.caption = "button1"
.onAction = "macro1"
.faceId = 487
.Style = msoButtonIconAndCaption
End With
End Sub
Sub a1234()
Dim outl As Object
Dim msg As Object
Set outl = CreateObject("Outlook.Application")
Dim objBar As Office.commandBar
Dim objButton As Office.commandBarButton
Set objBar = Application.ActiveWindow.CommandBars("Menu Bar")
Set objButton = objBar.Controls.Add(msoControlButton)
With objButton
.caption = "button2"
.onAction = "macro2"
.faceId = 487
.Style = msoButtonIconAndCaption
End With
End Sub
In Outlook 2010. If Visible works for you incorporate it in a similar manner.
Option Explicit
Sub TBarExistsbutton1()
Dim cbControlCount As Long
Dim button1Found As Boolean
Dim j As Long
If ToolBarExists("Menu Bar") Then
cbControlCount = ActiveWindow.CommandBars("Menu Bar").Controls.count
Debug.Print " There are " & cbControlCount & " controls in " & "Menu Bar"
For j = 1 To cbControlCount
Debug.Print ActiveWindow.CommandBars("Menu Bar").Controls(j).Caption
If ActiveWindow.CommandBars("Menu Bar").Controls(j).Caption = "button1" Then
button1Found = True
Exit For
End If
Next j
If button1Found = False Then a123
Else
Debug.Print "Menu Bar does not exist."
a123
End If
End Sub
So I have this code in Mcirosoft Outlook. The code runs when new mail comes in, and depending on the sender's name and the attachments, it saves the text files and imports the data into 2 access databases and and runs certain queries pre built in the database. The code errors out when 2 emails which are from the right sender and has the right attachments comes in. The code processes the first email correctly however when the second email is getting processed, the code errors out at the bolded line below.
Option Explicit
Private Sub Application_NewMail()
Dim ns As NameSpace
Dim inbox As MAPIFolder
Dim Item As MailItem
Dim atmt As Attachment
Dim fso As FileSystemObject
Dim fs As TextStream
Dim dt, invfn, misfn, invdr, misdr, dbfn As String
Dim invt, mist As Boolean
Dim db As Object
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set fso = New FileSystemObject
If inbox.UnReadItemCount = 0 Then
Exit Sub
Else
For Each Item In inbox.Items.Restrict("[UnRead] = True")
If Item.SenderName = "Menon, Jayesh" Then
dt = Left(Right(Item.Subject, 12), 10)
For Each atmt In Item.Attachments
If atmt.FileName = "InvalidLoans.txt" Then
invfn = "ERLMF_InvalidLoans_" & dt & ".txt"
invdr = "C:\Documents and Settings\U299482\Desktop\Data Drop\" & _
invfn
atmt.SaveAsFile invdr
Set fs = fso.OpenTextFile(invdr)
If fs.Read(23) = "Invalid Loans Count = 0" Then
invt = False
Else
invt = True
End If
fs.Close
End If
If atmt.FileName = "MissingLoans.txt" Then
misfn = "ERLMF_MissingLoans_" & dt & ".txt"
misdr = "C:\Documents and Settings\U299482\Desktop\Data Drop\" & _
misfn
atmt.SaveAsFile misdr
Set fs = fso.OpenTextFile(misdr)
If fs.Read(23) = "Missing Loans Count = 0" Then
mist = False
Else
mist = True
End If
fs.Close
End If
Next
If invt = True Or mist = True Then
Set db = CreateObject("Access.Application")
dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\BPDashboard.accdb"
With db
.OpenCurrentDatabase dbfn, True
.Visible = True
If invt = True Then
.DoCmd.TransferText acImportDelim, "Lns_Spec", "Invalid_Lns", invdr, True
End If
If mist = True Then
.DoCmd.TransferText acImportDelim, "Lns_Spec", "Missing_Lns", misdr, True
End If
.Quit
End With
Set db = Nothing
End If
If invt = True Then
Set db = CreateObject("Access.Application")
dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\CORE IDP.accdb"
With db
.OpenCurrentDatabase dbfn, True
.Visible = True
**CurrentDb.Execute "A0_Empty_ERLMF_InvalidLoans_2013-04-02", dbFailOnError**
.DoCmd.TransferText acImportDelim, "Lns_Spec", "ERLMF_InvalidLoans_2013-04-02", invdr, True
CurrentDb.Execute "AppendERLMF", dbFailOnError
CurrentDb.Execute "FaxRF Crystal Append", dbFailOnError
.Quit
End With
Set db = Nothing
End If
Item.UnRead = False
End If
Next
End If
End Sub
I think you're getting over-lapping .Execute commands. You need to ensure that the first execution finishes before starting the next. To fix, I'd start by declaring a Public variable Executing then move the below code into its own method.
Sub Execute()
Executing = True
Set db = CreateObject("Access.Application")
dbfn = "C:\Documents and Settings\U299482\Desktop\Databases\CORE IDP.accdb"
With db
.OpenCurrentDatabase dbfn, True
.Visible = True
CurrentDb.Execute "A0_Empty_ERLMF_InvalidLoans_2013-04-02", dbFailOnError
.DoCmd.TransferText acImportDelim, "Lns_Spec", "ERLMF_InvalidLoans_2013-04-02", invdr, True
CurrentDb.Execute "AppendERLMF", dbFailOnError
CurrentDb.Execute "FaxRF Crystal Append", dbFailOnError
.Quit
End With
Set db = Nothing
Executing = False
End Sub
Then, when calling the function, surround it with a loop that tests to see if Executing is false.
Do
If Executing = False Then
Execute
Exit Do
End If
Loop