danners430
New Member
- Joined
- Aug 3, 2017
- Messages
- 45
Afternoon all,
I've got a workbook which uses multiple userforms to control data, but have discovered that in one particular userform I get the error code -2147417848 (80010108) (Automation Error: The object invoked has disconnected from its clients) when I hit ESC.
Unfortunately I have no idea where the issue lies in the code, as debug mode only takes me back to the Userform.Show command, and when I try stepping through using F8, it complains that it can't show the userform as it's already visible
I've tried stepping through the entire process of loading the userform and found nothing; and when hitting ESC no code actually runs - the error is the first thing to occur.
This error only appears in one form, I've tested the others and they're all fine with ESC as a means of "emergency stop".
The final twist to this is that following the error, I can't close excel... When I attempt to close the program, it seemingly gets stuck in a loop somehow and refuses to shut down - I have no workbook.close or worksheet.deactivate etc. events created... I end up having to kill the program using task manager.
Anyone got any suggestions? I would attach the userform if I could, but no idea how
Userform code:
Module "EditTasks_Button":
Module "EditTasks_GlobalFunctions":
Module "EditTasks_Launcher":
Module "EditTasks_Page1":
Module "EditTasks_Page2":
Module "EditTasks_page3":
Module "EditTasks_Page4":
Module "EditTasks_Page5":
Module "EditTasks_Page6":
Just for info the ShowPopup procedure is a right click menu generator - I've tried commenting it out, but to no avail...
I've got a workbook which uses multiple userforms to control data, but have discovered that in one particular userform I get the error code -2147417848 (80010108) (Automation Error: The object invoked has disconnected from its clients) when I hit ESC.
Unfortunately I have no idea where the issue lies in the code, as debug mode only takes me back to the Userform.Show command, and when I try stepping through using F8, it complains that it can't show the userform as it's already visible
I've tried stepping through the entire process of loading the userform and found nothing; and when hitting ESC no code actually runs - the error is the first thing to occur.
This error only appears in one form, I've tested the others and they're all fine with ESC as a means of "emergency stop".
The final twist to this is that following the error, I can't close excel... When I attempt to close the program, it seemingly gets stuck in a loop somehow and refuses to shut down - I have no workbook.close or worksheet.deactivate etc. events created... I end up having to kill the program using task manager.
Anyone got any suggestions? I would attach the userform if I could, but no idea how
Userform code:
Code:
Option Explicit
Dim TabCheck As Boolean
Dim LastRowA As Long
Dim TitleArr() As Variant
Dim LinkArr() As Variant
Dim LastRowOldA As Long
Dim LastRowNewA As Long
Dim LastRowNewB As Long
Dim rngA As String
Dim rngB As String
'Page 1
Private Sub CommandButtonCanc_Click()
Me.Hide
End Sub
Private Sub CommandButtonOK_Click()
Call NewRow
Me.Hide
End Sub
Private Sub ListBoxOwn_Change()
Call OKEnable
End Sub
Private Sub OptionButton1_Click()
Call OKEnable
End Sub
Private Sub OptionButton2_Click()
Call OKEnable
End Sub
Private Sub OptionButton3_Click()
Call OKEnable
End Sub
Private Sub P2_ComboBoxID_Change()
If EnableEvents = False Then Exit Sub
Call ComboBoxIDChange(P2_ComboBoxID, P2_ComboBoxID.ListIndex)
End Sub
Private Sub P2_ListBoxOwn_Change()
If EnableEvents = False Then Exit Sub
Call P2_OKEnable
End Sub
Private Sub P2_TextBoxCust_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, P2_TextBoxCust.Text, X, Y, P2_TextBoxCust)
End If
End Sub
Private Sub P2_TextBoxDesc_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, P2_TextBoxDesc.Text, X, Y, P2_TextBoxDesc)
End If
End Sub
Private Sub P3_ComboBoxID_Change()
If EnableEvents = False Then Exit Sub
Call ComboBoxIDChange(P3_ComboBoxID, P3_ComboBoxID.ListIndex)
End Sub
Private Sub P3_CommandButtonRelDocMan_Click()
RelDocMan.Show
Call AcceptID
End Sub
Private Sub P3_TextBoxRelDocLink1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, P3_TextBoxRelDocLink1.Text, X, Y, P3_TextBoxRelDocLink1)
End If
End Sub
Private Sub P3_TextBoxRelDocLink2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, P3_TextBoxRelDocLink2.Text, X, Y, P3_TextBoxRelDocLink2)
End If
End Sub
Private Sub P3_TextBoxRelDocName1_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, P3_TextBoxRelDocName1.Text, X, Y, P3_TextBoxRelDocName1)
End If
End Sub
Private Sub P3_TextBoxRelDocName2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, P3_TextBoxRelDocName2.Text, X, Y, P3_TextBoxRelDocName2)
End If
End Sub
Private Sub P4_ComboBoxID_Change()
If EnableEvents = False Then Exit Sub
Call ComboBoxIDChange(P4_ComboBoxID, P4_ComboBoxID.ListIndex)
End Sub
Private Sub P4_CommandButtonCM_Click()
CM.Show
Call AcceptID
End Sub
Private Sub P4_TextBoxCom_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, P4_TextBoxCom.Text, X, Y, P4_TextBoxCom)
End If
End Sub
Private Sub P5_ComboBoxID_Change()
If EnableEvents = False Then Exit Sub
Call ComboBoxIDChange(P5_ComboBoxID, P5_ComboBoxID.ListIndex)
End Sub
Private Sub P6_ComboBoxID_Change()
If EnableEvents = False Then Exit Sub
Call ComboBoxIDChange(P6_ComboBoxID, P6_ComboBoxID.ListIndex)
End Sub
Private Sub P6_CommandButtonCanc_Click()
Me.Hide
End Sub
Private Sub P6_CommandButtonDel_Click()
Answer = MsgBox("Are you sure you want to delete task no. " & ID & "?", vbYesNo + vbQuestion, "Delete Task")
If Answer = vbNo Then Exit Sub
Call DeleteRow
Me.Hide
End Sub
Private Sub TextBoxCust_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, TextBoxCust.Text, X, Y, TextBoxCust)
End If
End Sub
Private Sub TextBoxDesc_Change()
Call OKEnable
End Sub
'Page 2
Private Sub P2_CommandButtonCanc_Click()
If EnableEvents = False Then Exit Sub
Me.Hide
End Sub
Private Sub P2_CommandButtonOK_Click()
If EnableEvents = False Then Exit Sub
Call P2_OK
Call AcceptID
End Sub
Private Sub P2_OptionButton1_Click()
If EnableEvents = False Then Exit Sub
Call P2_OKEnable
End Sub
Private Sub P2_OptionButton2_Change()
If EnableEvents = False Then Exit Sub
Call P2_OKEnable
End Sub
Private Sub P2_OptionButton3_Change()
If EnableEvents = False Then Exit Sub
Call P2_OKEnable
End Sub
Private Sub P2_TextBoxCust_Change()
If EnableEvents = False Then Exit Sub
Call P2_OKEnable
End Sub
Private Sub P2_TextBoxDesc_Change()
If EnableEvents = False Then Exit Sub
Call P2_OKEnable
End Sub
'Page 3
Private Sub P3_CommandButtonCanc_Click()
Me.Hide
End Sub
Private Sub P3_TextBoxRelDocName1_Change()
If EnableEvents = False Then Exit Sub
If P3_TextBoxRelDocName1 = "" Or P3_TextBoxRelDocName1 = "Name" Then
P3_TextBoxRelDocName2.Visible = False
P3_TextBoxRelDocLink2.Visible = False
Exit Sub
Else
P3_TextBoxRelDocName2.Visible = True
P3_TextBoxRelDocLink2.Visible = True
End If
If P3_OkEnable = False Then P3_CommandButtonOK.Enabled = False
If P3_OkEnable = True Then P3_CommandButtonOK.Enabled = True
End Sub
Private Sub P3_TextBoxRelDocLink1_Change()
If EnableEvents = False Then Exit Sub
If P3_OkEnable = False Then
P3_CommandButtonOK.Enabled = False
P3_CommandButtonCanc.Default = True
Else
P3_CommandButtonOK.Enabled = True
P3_CommandButtonOK.Default = True
End If
End Sub
Private Sub P3_TextBoxRelDocName1_Enter()
If P3_TextBoxRelDocName1 <> "Name" Then
Exit Sub
Else
P3_TextBoxRelDocName1.Value = ""
P3_TextBoxRelDocName1.ForeColor = RGB(0, 0, 0)
End If
End Sub
Private Sub P3_TextBoxRelDocName1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If P3_TextBoxRelDocName1.Value <> "" And P3_TextBoxRelDocName1 <> "Name" Then
Sheet3.Cells(RelDoc1Counter, 1) = P3_TextBoxRelDocName1
Exit Sub
Else
P3_TextBoxRelDocName1.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocName1 = "Name"
End If
End Sub
Private Sub P3_TextBoxRelDocLink1_Enter()
If Not P3_TextBoxRelDocLink1 = "Link" Then
Exit Sub
Else
P3_TextBoxRelDocLink1.Value = ""
P3_TextBoxRelDocLink1.ForeColor = RGB(0, 0, 0)
End If
End Sub
Private Sub P3_TextBoxRelDocLink1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If P3_TextBoxRelDocLink1.Value <> "" And P3_TextBoxRelDocLink1 <> "Link" Then
Sheet3.Cells(RelDoc1Counter, 2) = P3_TextBoxRelDocLink1
Else
P3_TextBoxRelDocLink1.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocLink1 = "Link"
End If
End Sub
Private Sub P3_TextBoxRelDocName2_Enter()
If P3_TextBoxRelDocName2 <> "Name" Then
Exit Sub
Else
P3_TextBoxRelDocName2.Value = ""
P3_TextBoxRelDocName2.ForeColor = RGB(0, 0, 0)
End If
TabCheck = True
End Sub
Private Sub P3_TextBoxRelDocName2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If P3_TextBoxRelDocName2.Value <> "" And P3_TextBoxRelDocName2 <> "Name" Then
Sheet3.Cells(RelDoc2Counter, 1) = P3_TextBoxRelDocName2
Exit Sub
Else
P3_TextBoxRelDocName2.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocName2 = "Name"
End If
End Sub
Private Sub P3_TextBoxRelDocLink2_Enter()
If P3_TextBoxRelDocLink2 <> "Link" Then
Exit Sub
Else
P3_TextBoxRelDocLink2.Value = ""
P3_TextBoxRelDocLink2.ForeColor = RGB(0, 0, 0)
End If
End Sub
Private Sub P3_TextBoxRelDocLink2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If P3_TextBoxRelDocLink2.Value <> "" And P3_TextBoxRelDocLink2 <> "Link" Then
Sheet3.Cells(RelDoc2Counter, 2) = P3_TextBoxRelDocLink2
Call P3_FilledChecker
Exit Sub
Else
P3_TextBoxRelDocLink2.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocLink2 = "Link"
End If
End Sub
Private Sub P3_TextBoxRelDocLink2_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
If TabCheck = False Then Exit Sub
If KeyCode = vbKeyTab And P3_TextBoxRelDocName2 <> "Name" Then
P3_TextBoxRelDocName2.SetFocus
SendKeys "{BS}", True
End If
End Sub
Private Sub P3_CommandButtonRelDocUp_Click()
P3_TextBoxRelDocName1 = Sheet3.Cells(RelDoc1Counter - 1, 1)
P3_TextBoxRelDocLink1 = Sheet3.Cells(RelDoc1Counter - 1, 2)
P3_TextBoxRelDocName2 = Sheet3.Cells(RelDoc2Counter - 1, 1)
P3_TextBoxRelDocLink2 = Sheet3.Cells(RelDoc2Counter - 1, 2)
RelDoc1Counter = RelDoc1Counter - 1
RelDoc2Counter = RelDoc2Counter - 1
If P3ComButUp = True Then
P3_CommandButtonRelDocUp.Visible = True
Else
P3_CommandButtonRelDocUp.Visible = False
End If
If P3ComButDown = True Then
P3_CommandButtonRelDocDown.Visible = True
Else
P3_CommandButtonRelDocDown.Visible = False
End If
If P3_TextBoxRelDocName1 = "" Or P3_TextBoxRelDocName1 = "Name" Then
P3_TextBoxRelDocName1.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocName1 = "Name"
Else
P3_TextBoxRelDocName1.ForeColor = RGB(0, 0, 0)
End If
If P3_TextBoxRelDocLink1 = "" Or P3_TextBoxRelDocLink1 = "Link" Then
P3_TextBoxRelDocLink1.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocLink1 = "Link"
Else
P3_TextBoxRelDocLink1.ForeColor = RGB(0, 0, 0)
End If
If P3_TextBoxRelDocName2 = "" Or P3_TextBoxRelDocName2 = "Name" Then
P3_TextBoxRelDocName2.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocName2 = "Name"
Else
P3_TextBoxRelDocName2.ForeColor = RGB(0, 0, 0)
End If
If P3_TextBoxRelDocLink2 = "" Or P3_TextBoxRelDocLink2 = "Link" Then
P3_TextBoxRelDocLink2.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocLink2 = "Link"
Else
P3_TextBoxRelDocLink2.ForeColor = RGB(0, 0, 0)
End If
End Sub
Private Sub P3_CommandButtonRelDocDown_Click()
P3_TextBoxRelDocName1 = Sheet3.Cells(RelDoc1Counter + 1, 1)
P3_TextBoxRelDocLink1 = Sheet3.Cells(RelDoc1Counter + 1, 2)
P3_TextBoxRelDocName2 = Sheet3.Cells(RelDoc2Counter + 1, 1)
P3_TextBoxRelDocLink2 = Sheet3.Cells(RelDoc2Counter + 1, 2)
RelDoc1Counter = RelDoc1Counter + 1
RelDoc2Counter = RelDoc2Counter + 1
If P3ComButUp = True Then
P3_CommandButtonRelDocUp.Visible = True
Else
P3_CommandButtonRelDocUp.Visible = False
End If
If P3ComButDown = True Then
P3_CommandButtonRelDocDown.Visible = True
Else
P3_CommandButtonRelDocDown.Visible = False
End If
If P3_TextBoxRelDocName1 = "" Or P3_TextBoxRelDocName1 = "Name" Then
P3_TextBoxRelDocName1.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocName1 = "Name"
Else
P3_TextBoxRelDocName1.ForeColor = RGB(0, 0, 0)
End If
If P3_TextBoxRelDocLink1 = "" Or P3_TextBoxRelDocLink1 = "Link" Then
P3_TextBoxRelDocLink1.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocLink1 = "Link"
Else
P3_TextBoxRelDocLink1.ForeColor = RGB(0, 0, 0)
End If
If P3_TextBoxRelDocName2 = "" Or P3_TextBoxRelDocName2 = "Name" Then
P3_TextBoxRelDocName2.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocName2 = "Name"
Else
P3_TextBoxRelDocName2.ForeColor = RGB(0, 0, 0)
End If
If P3_TextBoxRelDocLink2 = "" Or P3_TextBoxRelDocLink2 = "Link" Then
P3_TextBoxRelDocLink2.ForeColor = RGB(160, 160, 160)
P3_TextBoxRelDocLink2 = "Link"
Else
P3_TextBoxRelDocLink2.ForeColor = RGB(0, 0, 0)
End If
End Sub
Private Sub P3_CommandButtonOK_Click()
LastRowA = LastRow(Sheet3, 1)
If Sheets(IDstr).Cells(1, 1) = "" Then
LastRowOldA = 0
Else
LastRowOldA = LastRow(Sheets(IDstr), 1)
End If
TitleArr = Sheet3.Range("A1:A1000")
LinkArr = Sheet3.Range("B1:B1000")
rngA = "A" & LastRowOldA + 1 & ":A1000"
rngB = "B" & LastRowOldA + 1 & ":B1000"
Sheets(IDstr).Range(rngA) = TitleArr
Sheets(IDstr).Range(rngB) = LinkArr
LastRowNewA = LastRow(Sheets(IDstr), 1)
LastRowNewB = LastRow(Sheets(IDstr), 2)
Sheet3.Range("A:B") = ""
If LastRowNewA = 1 And Sheets(IDstr).Cells(1, 1) = "" Then
Sheet1.Cells(TargetRow, 10) = 0
Else
Sheet1.Cells(TargetRow, 10) = LastRowNewA
End If
Call AcceptID
End Sub
Private Function P3_OkEnable()
If P3_TextBoxRelDocName1 = "" And P3_TextBoxRelDocLink1 = "" Then
P3_OkEnable = False
Else
P3_OkEnable = True
End If
End Function
'Page 4
Private Sub P4_CommandButtonCanc_Click()
Me.Hide
End Sub
Private Sub P4_TextBoxCom_Change()
If EnableEvents = False Then Exit Sub
Call P4_OkEnable
End Sub
Private Sub P4_OkEnable()
If Not P4_TextBoxCom = "" Then
P4_CommandButtonOK.Enabled = True
P4_CommandButtonOK.Default = True
Else
P4_CommandButtonOK.Enabled = False
P4_CommandButtonCanc.Default = True
End If
End Sub
Private Sub P4_CommandButtonOK_Click()
Call P4_OK
Call AcceptID
End Sub
'Page 5
Private Sub P5_CheckBoxComp_Click()
Call p5_OKEnable
End Sub
Private Sub P5_CommandButtonCanc_Click()
Me.Hide
End Sub
Private Sub P5_CommandButtonOK_Click()
If P5_CheckBoxComp = False Then
Call Uncomplete
Else
Call Complete
End If
Me.Hide
End Sub
Private Sub p5_OKEnable()
If (Sheet1.Cells(TargetRow, 8) = 0 And P5_CheckBoxComp = False) Or (Sheet1.Cells(TargetRow, 8) = 1 And P5_CheckBoxComp = True) Then
P5_CommandButtonOK.Enabled = False
Else
P5_CommandButtonOK.Enabled = True
End If
End Sub
Private Sub TextBoxDesc_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' If right-button clicked
If Button = 2 Then
Call ShowPopup(Me, TextBoxDesc.Text, X, Y, TextBoxDesc)
End If
End Sub
Private Sub UserForm_Activate()
RDMID = False
CMID = False
Sheet1.Activate
If OpButSel = True Then
Call LoadIDs
Call AcceptID
RelDoc1Counter = 1
RelDoc2Counter = 2
With Me.MultiPage1
.Pages(0).Visible = False
.Pages(1).Visible = True
.Pages(2).Visible = True
.Pages(3).Visible = True
.Pages(4).Visible = True
If Manager = True Then .Pages(5).Visible = True
End With
If Comp = True Then Me.MultiPage1.Value = 4
If CMActivate = True Then Me.MultiPage1.Value = 3
If RelDocSelect = True Then Me.MultiPage1.Value = 2
Comp = False
CMActivate = False
RelDocSelect = False
Else
With Me.MultiPage1
.Pages(0).Visible = True
.Pages(1).Visible = False
.Pages(2).Visible = False
.Pages(3).Visible = False
.Pages(4).Visible = False
.Pages(5).Visible = False
End With
RDMID = False
CMID = False
End If
End Sub
Private Sub MultiPage1_Click(ByVal Index As Long)
Select Case MultiPage1.SelectedItem.Name
Case "Page1": Call P1Switch
Case "Page2": Call P2Switch
Case "Page3": Call P3Switch
Case "Page4": Call P4Switch
Case "Page5": Call P5Switch
Case "Page6": Call P6Switch
End Select
End Sub
Private Sub P1Switch()
End Sub
Private Sub P2Switch()
EditTasks.Height = 280
End Sub
Private Sub P3Switch()
EditTasks.Height = 240
End Sub
Private Sub P4Switch()
EditTasks.Height = 240
End Sub
Private Sub P5Switch()
EditTasks.Height = 240
End Sub
Private Sub P6Switch()
EditTasks.Height = 280
End Sub
Private Sub UserForm_Initialize()
With EditTasks
.Top = Application.Top + 125
.Left = Application.Left + 25
End With
Call UpdateOwn
End Sub
Private Sub UserForm_Terminate()
Call HideNewTask
End Sub
Module "EditTasks_Button":
Code:
Option Explicit
Dim Button As OptionButton
Sub TaskChange()
For Each Button In Sheet1.OptionButtons
If Button.Value = 1 Then
OpButSel = True
End If
Next Button
Sheet1.Unprotect
If OpButSel = True Then
Sheet1.Buttons("Tasks").Caption = "Edit Task"
Else
Sheet1.Buttons("Tasks").Caption = "New Task"
End If
Dim UIOnly As Variant
UIOnly = True
Sheet1.Protect userinterfaceonly:=UIOnly
Call HideNewTask
End Sub
Sub HideNewTask()
With Sheet1
If .Buttons("Tasks").Caption = "New Task" And .Buttons("Hide Completed").Visible = False Then
.Buttons("Tasks").Visible = False
ElseIf .Buttons("Tasks").Caption = "Edit Task" Then
.Buttons("Tasks").Visible = True
ElseIf .Buttons("Tasks").Caption = "New Task" And .Buttons("Hide Completed").Visible = True Then
.Buttons("Tasks").Visible = True
End If
End With
End Sub
Module "EditTasks_GlobalFunctions":
Code:
Option Explicit
Dim cntrl As Control
Sub AcceptID()
EnableEvents = False
IDstr = ID
TargetRow = Application.Match(ID, Sheet1.Range("B1:B10000"), 0)
If IsNumeric(TargetRow) = False Then
MsgBox "Job not found."
Call LoadIDs
Exit Sub
End If
With EditTasks
Dim CBB() As String
ReDim CBB(0 To .P2_ComboBoxID.ListCount - 1) As String
Dim CBBi As Integer
Dim CBBs As ComboBox
For i = 0 To UBound(CBB)
CBB(i) = .P2_ComboBoxID.List(i)
Next i
CBBi = IsInArray(ID & " - " & Sheet1.Cells(TargetRow, "C"), CBB) - 1
.P2_ComboBoxID.ListIndex = CBBi
.P3_ComboBoxID.ListIndex = CBBi
.P4_ComboBoxID.ListIndex = CBBi
.P5_ComboBoxID.ListIndex = CBBi
.P6_ComboBoxID.ListIndex = CBBi
End With
Call EditTaskLoad
Call RelDocLoad
Call CommentsLoad
Call Completi******
Select Case Application.UserName
Case Sheet2.Cells(31, 2), Sheet2.Cells(32, 2), Sheet2.Cells(33, 2), Sheet2.Cells(34, 2), Sheet2.Cells(35, 2), Sheet2.Cells(36, 2), Sheet2.Cells(37, 2), Sheet2.Cells(38, 2), Sheet2.Cells(39, 2), Sheet2.Cells(40, 2), Sheet2.Cells(41, 2), Sheet2.Cells(42, 2), Sheet2.Cells(43, 2), Sheet2.Cells(44, 2), Sheet2.Cells(45, 2), Sheet2.Cells(46, 2), Sheet2.Cells(47, 2), Sheet2.Cells(48, 2), Sheet2.Cells(49, 2), Sheet2.Cells(50, 2), Sheet2.Cells(51, 2), Sheet2.Cells(52, 2), Sheet2.Cells(53, 2), Sheet2.Cells(54, 2), Sheet2.Cells(55, 2), Sheet2.Cells(56, 2), Sheet2.Cells(57, 2)
Manager = True
Case Else
Manager = False
End Select
If Manager = True Then Call DeleteLoad
EnableEvents = True
End Sub
Sub UpdateDur()
EnableEvents = False
With EditTasks
.OptionButton1.Caption = Sheet2.Cells(2, 3)
.OptionButton2.Caption = Sheet2.Cells(2, 4)
.OptionButton3.Caption = Sheet2.Cells(2, 5)
.P2_OptionButton1.Caption = Sheet2.Cells(2, 3)
.P2_OptionButton2.Caption = Sheet2.Cells(2, 4)
.P2_OptionButton3.Caption = Sheet2.Cells(2, 5)
.P6_OptionButton1.Caption = Sheet2.Cells(2, 3)
.P6_OptionButton2.Caption = Sheet2.Cells(2, 4)
.P6_OptionButton3.Caption = Sheet2.Cells(2, 5)
End With
EnableEvents = True
End Sub
Sub UpdateOwn()
EnableEvents = False
Dim cLoc As Range
EditTasks.ListBoxOwn.Clear
EditTasks.P2_ListBoxOwn.Clear
For Each cLoc In Sheet2.Range("Names")
If cLoc.Value <> "" Then
EditTasks.P2_ListBoxOwn.AddItem cLoc.Value
EditTasks.ListBoxOwn.AddItem cLoc.Value
End If
Next cLoc
EnableEvents = True
End Sub
Sub LoadIDs()
EnableEvents = False
Dim cloc2 As Range
Dim CBB() As String
i2 = 1
For Each cloc2 In Sheet1.Range("IDs")
If cloc2.Value <> "" Then
ReDim Preserve CBB(1 To i2) As String
CBB(i2) = cloc2.Value & " - " & Sheet1.Cells(cloc2.Row, "C")
i2 = i2 + 1
End If
Next cloc2
With EditTasks
.P2_ComboBoxID.List = CBB
.P3_ComboBoxID.List = CBB
.P4_ComboBoxID.List = CBB
.P5_ComboBoxID.List = CBB
.P6_ComboBoxID.List = CBB
End With
EnableEvents = True
End Sub
Sub ComboBoxIDChange(ComboBox As ComboBox, indx As Long)
ID = ReturnID(ComboBox, indx)
Call AcceptID
End Sub
Module "EditTasks_Launcher":
Code:
Option Explicit
Dim str As String
Dim Button As OptionButton
Sub TaskFunctions()
OpButSel = False
Dur1 = Sheet2.Cells(2, 3).Value
Dur2 = Sheet2.Cells(2, 4).Value
Dur3 = Sheet2.Cells(2, 5).Value
For Each Button In Sheet1.OptionButtons
If Button.Value = 1 Then
str = Button.Name
OpButSel = True
End If
Next Button
If OpButSel = True Then
ID = removeAlpha(str)
End If
EditTasks.Show
Sheet1.Unprotect
For Each Button In Sheet1.OptionButtons
Button.Value = 0
Next Button
Sheet1.Buttons("Tasks").Caption = "New Task"
Call HideNewTask
Sheet1.Protect userinterfaceonly:=True
End Sub
Module "EditTasks_Page1":
Code:
Option Explicit
'New Task
Dim TargetRow As Long
Sub NewRow()
Dim ownLR As Long
Application.Cursor = xlWait
Application.ScreenUpdating = False
Sheet2.EnableCalculation = False
With Sheet1
TargetRow = LastRow(Sheet1, 2) + 1
If TargetRow = 3 Then ID = 1 Else ID = .Cells(TargetRow - 1, 2) + 1 'If new row is first job on sheet, set Job ID
IDstr = ID
.Cells(TargetRow, 2) = ID 'as 1. Otherwise, set it as the next in
.Cells(TargetRow, 7) = Date 'series.
.Cells(TargetRow, 8) = 0 'Fill in basic details: creation date, job ID
.Cells(TargetRow, 10) = "0" 'completion status and related documents count
.Rows(TargetRow).RowHeight = 22.5 'Set row heights
.Rows(TargetRow + 1).RowHeight = 15
.Rows(TargetRow + 2).RowHeight = 5
.Cells(TargetRow, "L") = "Green"
With ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)) 'Create new hidden sheet named after Job ID.
.Name = IDstr 'This sheet contains details of comments and
.Visible = xlSheetHidden 'related documents associated with this task.
End With
.Activate
Call TableFill 'Fill rows and draw borders
With .Range("B" & TargetRow & ":L" & TargetRow)
.Borders.LineStyle = XlLineStyle.xlContinuous
.Borders.ColorIndex = 41
.Borders(xlInsideVertical).LineStyle = XlLineStyle.xlLineStyleNone
End With
Dim rng As Range
Set rng = .Range("M" & TargetRow)
With Sheet1.OptionButtons.Add(rng.Left, rng.Top, rng.Width, rng.Height) 'Create new Radio Button next to job for job
.Name = "CommandButtonEdit" & ID 'selection.
.Text = "Edit Job " & ID
.OnAction = "EditTasks_Button.TaskChange"
End With
End With
With EditTasks
Dim ownVal As Integer
Sheet1.Cells(TargetRow, 3) = .TextBoxDesc 'Fill in details of new job in spreadsheet
Sheet1.Cells(TargetRow, 6) = .TextBoxCust
Erase Own
ownVal = 0
For i = 0 To .ListBoxOwn.ListCount - 1
If .ListBoxOwn.Selected(i) Then
Own(ownVal) = .ListBoxOwn.List(i)
ownVal = ownVal + 1
End If
Next i
If ownVal = 1 Then
Sheet1.Cells(TargetRow, 5) = Own(0)
Sheets(IDstr).Cells(1, 5) = Own(0)
Else
For i = 0 To ownVal
If i = 0 Then
Sheet1.Cells(TargetRow, 5) = Own(0)
Else
Sheet1.Cells(TargetRow, 5) = Sheet1.Cells(TargetRow, 5).Value & ", " & Own(i)
End If
Sheets(IDstr).Cells(i + 1, 5) = Own(i)
Next i
End If
If Sheets(IDstr).Cells(2, 5) <> "" Then
Sheet1.Cells(TargetRow, 5) = Left(Sheet1.Cells(TargetRow, 5).Value, Len(Sheet1.Cells(TargetRow, 5).Value) - 2)
End If
ownLR = LastRow(Sheets(IDstr), 5)
ownVal = 0
For i = 0 To .ListBoxOwn.ListCount - 1
If .ListBoxOwn.Selected(i) = True Then
Own(ownVal) = .ListBoxOwn.List(i)
ownVal = ownVal + 1
End If
Next i
Dim Present As Boolean
For i = 0 To ownVal - 1
Present = Application.Match(Own(i), Sheets(IDstr).Range("E1:E30"), 0)
If IsNumeric(Present) = True Then
Call Send_Email_Using_VBA(Sheet1.Cells(TargetRow, 3).Value, Sheet2.Cells(Application.Match(Own(i), Sheet2.Range("B1:B30"), 0), 6).Value)
End If
Next i
If .OptionButton1 = True Then
Sheet1.Cells(TargetRow, "D") = Dur1
ElseIf .OptionButton2 = True Then
Sheet1.Cells(TargetRow, "D") = Dur2
ElseIf .OptionButton3 = True Then
Sheet1.Cells(TargetRow, "D") = Dur2
End If
End With
Application.Cursor = xlDefault
Application.ScreenUpdating = True
Sheet2.EnableCalculation = True
End Sub
Sub OKEnable()
Dim OptionButtons As Boolean
Dim Owners As Boolean
With EditTasks
If .OptionButton1 = True Or .OptionButton2 = True Or .OptionButton3 = True Then OptionButtons = True
For i = 0 To .ListBoxOwn.ListCount - 1
If .ListBoxOwn.Selected(i) = True Then Owners = True
Next i
If .TextBoxDesc.Value <> "" And OptionButtons = True And Owners = True Then
.CommandButtonOK.Enabled = True
.CommandButtonOK.Default = True
Else
.CommandButtonOK.Enabled = False
.CommandButtonCanc.Default = True
End If
End With
End Sub
Module "EditTasks_Page2":
Code:
Option Explicit
'Edit Task
Sub EditTaskLoad()
With EditTasks
EnableEvents = False
Dim cntrl As Control
For Each cntrl In .MultiPage1.Page2.Controls
cntrl.Enabled = True
Next cntrl
.P2_CommandButtonOK.Enabled = False
Set cntrl = Nothing
.P2_TextBoxDesc = Sheet1.Cells(TargetRow, "C")
.P2_TextBoxCust = Sheet1.Cells(TargetRow, "F")
.P2_OptionButton1 = False
.P2_OptionButton2 = False
.P2_OptionButton3 = False
Select Case Sheet1.Cells(TargetRow, "D")
Case Dur1
.P2_OptionButton1 = True
Case Dur2
.P2_OptionButton2 = True
Case Dur3
.P2_OptionButton3 = True
End Select
For i = 0 To .P2_ListBoxOwn.ListCount - 1
If InStr(1, Sheet1.Cells(TargetRow, "E"), .P2_ListBoxOwn.List(i)) <> 0 Then
.P2_ListBoxOwn.Selected(i) = True
Else
.P2_ListBoxOwn.Selected(i) = False
End If
Next i
Call P2_OKEnable
End With
End Sub
Sub P2_OKEnable()
Dim ownVal As Integer
Dim P2_OwnChan As Boolean
With EditTasks
If .P2_OptionButton1 = True Then
p2OB = Dur1
ElseIf .P2_OptionButton2 = True Then
p2OB = Dur2
ElseIf .P2_OptionButton3 = True Then
p2OB = Dur3
End If
Erase Own
ownVal = 0
For i = 0 To .P2_ListBoxOwn.ListCount - 1
If .P2_ListBoxOwn.Selected(i) = True Then
Own(ownVal) = .P2_ListBoxOwn.List(i)
ownVal = ownVal + 1
End If
Next i
P2_OwnChan = False
For i = 1 To ownVal
If Sheets(IDstr).Cells(i, 5) <> Own(i - 1) Then P2_OwnChan = True
Next i
If Sheet1.Cells(TargetRow, 3) = .P2_TextBoxDesc.Value And _
P2_OwnChan = False And _
Sheet1.Cells(TargetRow, 6) = .P2_TextBoxCust.Value And _
Sheet1.Cells(TargetRow, 4) = p2OB Then
.P2_CommandButtonOK.Enabled = False
.P2_CommandButtonCanc.Default = True
Else
.P2_CommandButtonOK.Enabled = True
.P2_CommandButtonOK.Default = True
End If
End With
End Sub
Sub P2_OK()
Dim ownLR As Long
Dim Present As Variant
Application.EnableEvents = False
With EditTasks
Dim ownVal As Integer
ownVal = 0
For i = 0 To .P2_ListBoxOwn.ListCount - 1
If .P2_ListBoxOwn.Selected(i) = True Then
Own(ownVal) = .P2_ListBoxOwn.List(i)
ownVal = ownVal + 1
End If
Next i
Sheet1.Cells(TargetRow, 3) = .P2_TextBoxDesc
Sheet1.Cells(TargetRow, 4) = p2OB
Sheet1.Cells(TargetRow, 6) = .P2_TextBoxCust
ownLR = LastRow(Sheets(IDstr), 5)
For i = 1 To ownVal
Sheets(IDstr).Cells(i, 5) = Own(i - 1)
Next i
If ownVal = 1 Then
Cells(TargetRow, 5) = Own(0)
Sheets(IDstr).Cells(1, 5) = Own(0)
Else
For i = 0 To ownVal
If i = 0 Then
Sheet1.Cells(TargetRow, 5) = Own(0)
Else
Sheet1.Cells(TargetRow, 5) = Sheet1.Cells(TargetRow, 5).Value & ", " & Own(i)
End If
Sheets(IDstr).Cells(i + 1, 5) = Own(i)
Next i
End If
If Sheets(IDstr).Cells(2, 5) <> "" Then
Sheet1.Cells(TargetRow, 5) = Left(Sheet1.Cells(TargetRow, 5).Value, Len(Sheet1.Cells(TargetRow, 5).Value) - 2)
End If
End With
EnableEvents = True
End Sub
Module "EditTasks_page3":
Code:
Option Explicit
'Related Documents
Sub RelDocLoad()
With EditTasks
.P3_TextBoxRelDocLink1.Enabled = True
.P3_TextBoxRelDocLink2.Enabled = True
.P3_TextBoxRelDocName1.Enabled = True
.P3_TextBoxRelDocName2.Enabled = True
.P3_LabelRelDoc = "Job " & ID & vbNewLine & "Add Related Documents"
.P3_TextBoxRelDocLink1 = "Link"
.P3_TextBoxRelDocLink2 = "Link"
.P3_TextBoxRelDocName1 = "Name"
.P3_TextBoxRelDocName2 = "Name"
Call P3_FilledChecker
.P3_CommandButtonOK.Enabled = False
If Sheet1.Cells(TargetRow, "J") = 0 Then .CommandButton1.Enabled = False Else .CommandButton1.Enabled = True
RDMID = True
End With
End Sub
Sub P3_FilledChecker()
With EditTasks
If .P3_TextBoxRelDocName1 <> "Name" _
And .P3_TextBoxRelDocLink1 <> "Link" _
And .P3_TextBoxRelDocName2 <> "Name" _
And .P3_TextBoxRelDocLink2 <> "Link" Then
.P3_TextBoxRelDocName1 = Sheet3.Cells(RelDoc1Counter + 1, 1)
.P3_TextBoxRelDocLink1 = Sheet3.Cells(RelDoc1Counter + 1, 2)
.P3_TextBoxRelDocName2 = Sheet3.Cells(RelDoc2Counter + 1, 1)
.P3_TextBoxRelDocLink2 = Sheet3.Cells(RelDoc2Counter + 1, 2)
RelDoc1Counter = RelDoc1Counter + 1
RelDoc2Counter = RelDoc2Counter + 1
.P3_TextBoxRelDocName2.SetFocus
Else
Exit Sub
End If
If P3ComButUp = True Then
.P3_CommandButtonRelDocUp.Visible = True
Else
.P3_CommandButtonRelDocUp.Visible = False
End If
If .P3_TextBoxRelDocName1 = "" Or .P3_TextBoxRelDocName1 = "Name" Then
.P3_TextBoxRelDocName1.ForeColor = RGB(160, 160, 160)
.P3_TextBoxRelDocName1 = "Name"
Else
.P3_TextBoxRelDocName1.ForeColor = RGB(0, 0, 0)
End If
If .P3_TextBoxRelDocLink1 = "" Or .P3_TextBoxRelDocLink1 = "Link" Then
.P3_TextBoxRelDocLink1.ForeColor = RGB(160, 160, 160)
.P3_TextBoxRelDocLink1 = "Link"
Else
.P3_TextBoxRelDocLink1.ForeColor = RGB(0, 0, 0)
End If
If .P3_TextBoxRelDocName2 = "" Or .P3_TextBoxRelDocName2 = "Name" Then
.P3_TextBoxRelDocName2.ForeColor = RGB(160, 160, 160)
.P3_TextBoxRelDocName2 = "Name"
Else
.P3_TextBoxRelDocName2.ForeColor = RGB(0, 0, 0)
End If
If .P3_TextBoxRelDocLink2 = "" Or .P3_TextBoxRelDocLink2 = "Link" Then
.P3_TextBoxRelDocLink2.ForeColor = RGB(160, 160, 160)
.P3_TextBoxRelDocLink2 = "Link"
Else
.P3_TextBoxRelDocLink2.ForeColor = RGB(0, 0, 0)
End If
End With
End Sub
Function P3ComButUp()
On Error GoTo P3ComButUpErrorcatcher
If Sheet3.Cells(RelDoc1Counter - 1, 1) <> "" Or Sheet3.Cells(RelDoc1Counter - 1, 2) <> "" Then
P3ComButUp = True
Else
P3ComButUp = False
End If
Exit Function
P3ComButUpErrorcatcher:
P3ComButUp = False
End Function
Function P3ComButDown()
On Error GoTo P3ComButDownErrorcatcher
If Sheet3.Cells(RelDoc2Counter, 1) <> "" Or Sheet3.Cells(RelDoc2Counter, 2) <> "" Then
P3ComButDown = True
Else
P3ComButDown = False
End If
Exit Function
P3ComButDownErrorcatcher:
P3ComButDown = False
End Function
Module "EditTasks_Page4":
Code:
Option Explicit
'Comments
Sub CommentsLoad()
With EditTasks
.P4_TextBoxCom.Enabled = True
.P4_LabelCom = "Add Comment" & vbNewLine & "Job " & ID
CMID = True
If Sheets(IDstr).Cells(1, 3) = "" Then
.P4_CommandButtonCM.Enabled = False
Else
.P4_CommandButtonCM.Enabled = True
End If
.P4_TextBoxCom = ""
.P4_CommandButtonOK.Enabled = False
End With
End Sub
Sub UpdateComments()
If Sheets(IDstr).Cells(1, 3) <> "" Then
For i = 1 To LastRow(Sheets(IDstr), 3)
Sheets(IDstr).Cells(i, 3) = Sheet4.Cells(i, 1)
Sheets(IDstr).Cells(i, 4) = Sheet4.Cells(i, 2) & "; " & Sheet4.Cells(i, 3)
If i = 1 Then
Sheet1.Cells(TargetRow, 11) = Sheets(IDstr).Cells(i, 3) & " - " & Sheets(IDstr).Cells(i, 4)
Else
Sheet1.Cells(TargetRow, 11) = Sheet1.Cells(TargetRow, 11) & vbNewLine & Sheets(IDstr).Cells(i, 3) & " - " & Sheets(IDstr).Cells(i, 4)
End If
Next i
Else
Sheet1.Cells(TargetRow, 11) = ""
End If
End Sub
Sub P4_OK()
Dim LastRowC As Long
Dim tempstr As String
With EditTasks
tempstr = "Add comment" & vbNewLine & "~" & .P4_TextBoxCom & "~" & vbNewLine & "To Job " & ID & "?"
tempstr = Replace(tempstr, Chr(126), Chr(34))
Answer = MsgBox(tempstr, vbOKCancel, "Confirm Comment")
If Not Answer = vbYes Then Exit Sub
LastRowC = LastRow(Sheets(IDstr), 3)
If Sheets(IDstr).Cells(LastRowC, 3) = "" Then
Sheets(IDstr).Cells(LastRowC, 3) = .P4_TextBoxCom
Sheets(IDstr).Cells(LastRowC, 4) = Application.UserName & "; " & Date
Sheet1.Cells(TargetRow, 11) = .P4_TextBoxCom & " - " & Application.UserName & "; " & Date
Else
Sheets(IDstr).Cells(LastRowC + 1, 3) = .P4_TextBoxCom
Sheets(IDstr).Cells(LastRowC + 1, 4) = Application.UserName & "; " & Date
Sheet1.Cells(TargetRow, "K") = Sheet1.Cells(TargetRow, "K") & vbNewLine & .P4_TextBoxCom & " - " & Application.UserName & "; " & Date
End If
MsgBox "Comment successfully added.", vbOKOnly, "Success!"
End With
End Sub
Module "EditTasks_Page5":
Code:
Option Explicit
'Completion
Sub Completi******()
With EditTasks
If Sheet1.Cells(TargetRow, "H") = 0 Then
.P5_CheckBoxComp = False
.P5_CheckBoxComp.Caption = ""
Else
.P5_CheckBoxComp = True
.P5_CheckBoxComp.Caption = "Completion Date: " & Sheet1.Cells(TargetRow, "I")
End If
End With
End Sub
Sub Complete()
Answer = MsgBox("Mark task " & ID & " as completed?", vbYesNo + vbQuestion, "Complete Task")
If Answer <> vbYes Then Exit Sub
Sheet1.Cells(TargetRow, "H") = 1
Sheet1.Cells(TargetRow, "I") = Date
End Sub
Sub Uncomplete()
Answer = MsgBox("Mark task " & ID & " as incomplete?", vbYesNo + vbQuestion, "Task Incomplete")
If Answer <> vbYes Then Exit Sub
Sheet1.Cells(TargetRow, "H") = 0
Sheet1.Cells(TargetRow, "I").ClearContents
End Sub
Module "EditTasks_Page6":
Code:
Option Explicit
'Delete Task
Sub DeleteLoad()
With EditTasks
.P6_CommandButtonDel.Enabled = True
.P6_LabelDesc2.Caption = Sheet1.Cells(TargetRow, "C")
.P6_LabelOwn2.Caption = Sheet1.Cells(TargetRow, "E")
.P6_LabelCust2.Caption = Sheet1.Cells(TargetRow, "F")
.P6_OptionButton1 = False
.P6_OptionButton2 = False
.P6_OptionButton3 = False
Select Case Sheet1.Cells(TargetRow, "D")
Case Dur1
.P6_OptionButton1 = True
Case Dur2
.P6_OptionButton2 = True
Case Dur3
.P6_OptionButton3 = True
End Select
.P6_OptionButton1.Locked = True
.P6_OptionButton2.Locked = True
.P6_OptionButton3.Locked = True
End With
End Sub
Sub DeleteRow()
With Sheet1
Application.Cursor = xlWait
Sheet2.EnableCalculation = False
Application.EnableEvents = False
.Unprotect
.OptionButtons("CommandButtonEdit" & ID).Delete
.Rows(TargetRow).Delete 'Also deletes associated worksheet.
Call ResetRowHeights
.Rows(LastRow(Sheet1, 2) + 1).RowHeight = 15
.Rows(LastRow(Sheet1, 2) + 2).RowHeight = 5
On Error Resume Next
Application.DisplayAlerts = False
Sheets(IDstr).Delete
Application.DisplayAlerts = True
Application.Cursor = xlDefault
Sheet1.EnableCalculation = True
Application.EnableEvents = True
End With
End Sub
Just for info the ShowPopup procedure is a right click menu generator - I've tried commenting it out, but to no avail...