Related
I want to give credit to an agent, if they're the one that sent the message, but only if their signature is at the top of the email.
Here is what I have. The search order is off. The code searches for one name at a time, and clear through the document. I need it to search for All names, the first one that hits in the body of the email.
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim strSpecificText As String
Dim tmpStr As String
Dim x As Integer
Dim Count As Integer
Dim HunterCnt As Integer
Dim SunmolaCnt As Integer
Dim RodriguezCnt As Integer
Dim MammedatyCnt As Integer
Dim MitchellCnt As Integer
Dim TannerCnt As Integer
Dim TAYLORCnt As Integer
Dim WilsonCnt As Integer
Dim WilliamsCnt As Integer
Dim GrooverCnt As Integer
Dim TyreeCnt As Integer
Dim ChapmanCnt As Integer
Dim LukerCnt As Integer
Dim KlinedinstCnt As Integer
Dim HicksCnt As Integer
Dim NATHANIALCnt As Integer
Dim SkinnerCnt As Integer
Dim SimonsCnt As Integer
Dim AgentNames(14) As Variant
AgentNames(0) = "Simons"
AgentNames(1) = "Skinner"
AgentNames(2) = "Mammedaty"
AgentNames(3) = "Hunter"
AgentNames(4) = "Sunmola"
AgentNames(5) = "Rodriguez"
AgentNames(6) = "Mitchell"
AgentNames(7) = "Tanner"
AgentNames(8) = "Taylor"
AgentNames(9) = "Wilson"
AgentNames(10) = "Williams"
AgentNames(11) = "Groover"
AgentNames(12) = "Tyree"
AgentNames(13) = "Chapman"
AgentNames(14) = "Luker"
x = 0
While x < ActiveExplorer.Selection.Count
x = x + 1
Set MailItem = ActiveExplorer.Selection.item(x)
tmpStr = MailItem.Body
For Each Agent In AgentNames
If InStr(tmpStr, Agent) <> 0 Then
If Agent = "Assunta" Then
HunterCnt = HunterCnt + 1
GoTo skip
End If
If Agent = "Sunmola" Then
SunmolaCnt = SunmolaCnt + 1
GoTo skip
End If
If Agent = "Rodriguez" Then
RodriguezCnt = RodriguezCnt + 1
GoTo skip
End If
If Agent = "Mammedaty" Then
MammedatyCnt = MammedatyCnt + 1
GoTo skip
End If
If Agent = "Mitchell" Then
MitchellCnt = MitchellCnt + 1
GoTo skip
End If
If Agent = "Tanner" Then
TannerCnt = TannerCnt + 1
GoTo skip
End If
If Agent = "Taylor" Then
TAYLORCnt = TAYLORCnt + 1
GoTo skip
End If
If Agent = "Wilson" Then
WilsonCnt = WilsonCnt + 1
GoTo skip
End If
If Agent = "Williams" Then
WilliamsCnt = WilliamsCnt + 1
GoTo skip
End If
If Agent = "Groover" Then
GrooverCnt = GrooverCnt + 1
GoTo skip
End If
If Agent = "Tyree" Then
TyreeCnt = TyreeCnt + 1
GoTo skip
End If
If Agent = "Chapman" Then
ChapmanCnt = ChapmanCnt + 1
GoTo skip
End If
If Agent = "Luker" Then
LukerCnt = LukerCnt + 1
GoTo skip
End If
If Agent = "Hicks" Then
HicksCnt = HicksCnt + 1
GoTo skip
End If
End If
Next
skip:
Count = Count + 1
Wend
MsgBox "Found " & vbCrLf & "Hunter Count: " & HunterCnt & vbCrLf & "Sunmola Count: " & SunmolaCnt & vbCrLf & "Rodriguez Count: " & RodriguezCnt & vbCrLf & "Mammedaty Count: " & MammedatyCnt & vbCrLf & "Mitchell Count: " & MitchellCnt & vbCrLf & "Tanner Count: " & TannerCnt & vbCrLf & "Taylor Count: " & TAYLORCnt & vbCrLf & "Wilson Count: " & WilsonCnt & vbCrLf & "Williams Count: " & WilliamsCnt & vbCrLf & "Groover Count: " & GrooverCnt & vbCrLf & "Tyree Count: " & TyreeCnt & vbCrLf & "Chapman Count: " & ChapmanCnt & vbCrLf & "Luker Count: " & LukerCnt & vbCrLf & " in: " & Count & " emails"
End Sub
InStr returns positional information. While it is difficult to find the first occurrence of an array member within the text (you would need to build and compare matches), you can find the first position of each name then find which came first.
For example (untested)
Sub CountOccurences_SpecificText_In_Folder()
Dim MailItem As Outlook.MailItem
Dim i As Long, x As Long, position As Long, First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
Dim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For i = LBound(AgentCount) To UBound(AgentCount)
AgentCount(i) = 0
Next i
For Each MailItem In ActiveExplorer.Selection
x = 0
For i = LBound(AgentNames) To UBound(AgentNames)
position = InStr(MailItem.Body, AgentNames(i))
If x > 0 Then
If position < x Then
x = position
First = i
End If
Else
If position > 0 Then
x = position
First = i
End If
End If
Next i
AgentCount(First) = AgentCount(First) + 1
Next MailItem
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
The idea in the previous answer may be better implemented like this:
Option Explicit
Sub CountOccurences_SpecificText_SelectedItems()
Dim objItem As Object
Dim objMail As MailItem
Dim i As Long
Dim j As Long
Dim x As Long
Dim position As Long
Dim First As Long
Dim AgentNames() As String
AgentNames = Split("Simons,Skinner,Mammedaty,Hunter,Sunmola,Rodriguez,Mitchell,Tanner,Taylor,Wilson,Williams,Groover,Tyree,Chapman,Luker", ",")
ReDim AgentCount(LBound(AgentNames) To UBound(AgentNames)) As Long
For j = 1 To ActiveExplorer.Selection.Count
Set objItem = ActiveExplorer.Selection(j)
' Verify before attempting to return mailitem poroperties
If TypeOf objItem Is MailItem Then
Set objMail = objItem
Debug.Print
Debug.Print "objMail.Subject: " & objMail.Subject
x = Len(objMail.Body)
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print
Debug.Print "AgentNames(i): " & AgentNames(i)
position = InStr(objMail.Body, AgentNames(i))
Debug.Print " position: " & position
If position > 0 Then
If position < x Then
x = position
First = i
End If
End If
Debug.Print "Lowest position: " & x
Debug.Print " Current first: " & AgentNames(First)
Next i
If x < Len(objMail.Body) Then
AgentCount(First) = AgentCount(First) + 1
Debug.Print
Debug.Print AgentNames(First) & " was found first"
Else
Debug.Print "No agent found."
End If
End If
Next
For i = LBound(AgentNames) To UBound(AgentNames)
Debug.Print AgentNames(i) & " Count: " & AgentCount(i)
Next i
End Sub
I'm trying to write a code module using the InsertLines method, but am getting the
Statement too complex Error
My code boils down to this loop:
Dim extractorModule As VBComponent
With extractorModule.codeModule
Dim singItem As codeItem
Dim i As Long
For i = LBound(codeItems) To UBound(codeItems)
singItem = codeItems(i) 'array of private type with .value property
.InsertLines 5, singItem.value 'write to line 5
Next i
End With
Which loops through an array of custom codeItems, and writes their .value to a new module with .InsertLines
singItem.value is a base64 encoded string. If it is a short one, 100 characters say, like this string:
.code_content = "QXR0cmlidXRlIFZCX05hbWUgPSAic2ltcGxlTW9kdWxlIg0KUHJpdmF0ZSBhIEFzIExvbmcNCg=="
no problem. However I want a longer string, this one for example (19000 chars, contains newlines):
.code_content = "QXR0cmlidXRlIFZCX05hbWUgPSAicHJvamVjdENvbXByZXNzb3IiDQonQ29tcHJlc3NvciBtb2R1bGUsIGNvbXByZXNzZXMgYSBsb2FkIG9mIGZpbGVzIGludG8gc3RyaW5ncyB0byBleHBvcnQNCk9wdGlvbiBFeHBsaWNpdA0KUHJpdmF0ZSBUeXBlIGNvZGVJdGVtDQogICAgZXh0ZW5zaW9uIEFzIFN0cmluZw0KICAgIG1vZHVsZV9uYW1lIEFzIFN0cmluZw0KICAgIGNvZGVfY29udGVudCBBcyBTdHJpbmcNCkVuZCBUeXBlDQpQcml2YXRlIENvbnN0IFR5cGVCaW5hcnkgPSAxDQoNClB1YmxpYyBTdWIgY29tcHJlc3NQcm9qZWN0KFBhcmFtQXJyYXkgZmlsZW5hbWVzKCkpDQogICAgJ1N1YiB0byBjb252ZXJ0IHNlbGVjdGVkIGZpbGVzIGludG8gc2VsZi1leHRyYWN0aW5nIG1vZHVsZQ0KICAgICdJbnB1dDoNCiAgICAnICAgZmlsZW5hbWVzOiBhcnJheSBvZiBzdHJpbmdzIGJhc2VkIG9uIG5hbWVzIG9mIG1vZHVsZXMgaW4gcHJvamVjdA0KICAgIElmIE5vdCBwcm9qZWN0X2FjY2Vzc2libGUgVGhlbg0KICAgICAgICBNc2dCb3ggIkFjY2VzcyB0byBWQkEgcHJvamVjdCBpcyByZXN0cmljdGVkLCB0aGlzIHdvbid0IHdvcmshIg0KICAgICAgICBFeGl0IFN1Yg0KICAgIEVuZCBJZg0KDQogICAgRGltIGNvZGVJdGVtcygpIEFzIGNvZGVJdGVtDQogICAgRGltIGFycmF5U3QgQXMgTG9uZywg" & _
"YXJyYXlFbmQgQXMgTG9uZywgaSBBcyBMb25nDQogICAgYXJyYXlTdCA9IExCb3VuZChmaWxlbmFtZXMpDQogICAgYXJyYXlFbmQgPSBVQm91bmQoZmlsZW5hbWVzKQ0KICAgIFJlRGltIGNvZGVJdGVtcyhhcnJheVN0IFRvIGFycmF5RW5kKQ0KICAgIA0KICAgIERlYnVnLlByaW50ICJHZXR0aW5nIERlZmluaXRpb25zLi4uIg0KICAgIFdpdGggVGhpc1dvcmtib29rLlZCUHJvamVjdC5WQkNvbXBvbmVudHMNCiAgICAgICAgJ2xvb3AgdGhyb3VnaCBmaWxlcyBjb21wcmVzc2luZyB0aGVtIGludCA2NCBiaXQgc3RyaW5ncw0KICAgICAgICBGb3IgaSA9IGFycmF5U3QgVG8gYXJyYXlFbmQNCiAgICAgICAgICAgIGNvZGVJdGVtcyhpKSA9IG1vZHVsZURlZmluaXRpb24oZmlsZW5hbWVzKGkpKQ0KICAgICAgICBOZXh0IGkNCiAgICBFbmQgV2l0aA0KICAgIERlYnVnLlByaW50ICwgIkRlZmluaXRpb25zIHNhdmVkIg0KICAgICd3cml0ZSBzdHJpbmdzIHRvIHNrZWxldG9uIGZpbGUNCiAgICAgICAgRGVidWcuUHJpbnQgIldyaXRpbmcgZmlsZS4uLiINCiAgICB3cml0ZVNrZWxldG9uIGNvZGVJdGVtcw0KRGVidWcuUHJpbnQgIkNvbXBsZXRlIg0KRW5kIFN1Yg0KUHJpdmF0ZSBTdWIgd3JpdGVTa2VsZXRvbihjb2RlSXRlbXMoKSBBcyBjb2RlSXRlbSwgT3B0aW9uYWwgd2IgQXMgVmFyaWFudCwg" & _
"T3B0aW9uYWwgQnlSZWYgcHJvamVjdE5hbWUgQXMgU3RyaW5nID0gIm15UHJvamVjdCIpICcgLCBPcHRpb25hbCB3YiBBcyBWYXJpYW50KQ0KICAgIERpbSBpdGVtQ291bnQgQXMgTG9uZw0KICAgIGl0ZW1Db3VudCA9IFVCb3VuZChjb2RlSXRlbXMpIC0gTEJvdW5kKGNvZGVJdGVtcykgKyAxDQogICAgSWYgaXRlbUNvdW50IDwgMSBUaGVuIEV4aXQgU3ViDQogICAgDQogICAgRGltIGJvb2sgQXMgV29ya2Jvb2sNCiAgICBJZiBJc01pc3Npbmcod2IpIFRoZW4gU2V0IGJvb2sgPSBUaGlzV29ya2Jvb2sgRWxzZSBTZXQgYm9vayA9IHdiDQogICAgJ2NyZWF0ZSBzZWxmLWV4dHJhY3RpbmcgbW9kdWxlIGFuZCBzZXQgbmFtZQ0KDQogICAgRGltIGV4dHJhY3Rvck1vZHVsZSBBcyBWQkNvbXBvbmVudA0KICAgIFNldCBleHRyYWN0b3JNb2R1bGUgPSBib29rLlZCUHJvamVjdC5WQkNvbXBvbmVudHMuQWRkKHZiZXh0X2N0X1N0ZE1vZHVsZSkNCiAgICBleHRyYWN0b3JNb2R1bGUuTmFtZSA9IHByb2plY3ROYW1lICdtYXkgZXJyIGlmIGR1cGxpY2F0ZSAtIGNoYW5nZXMNCkRlYnVnLlByaW50ICwgIlByb2plY3QgZmlsZSBhZGRlZCINCiAgICAnd3JpdGUgY29kZSB0byBtb2R1bGUNCiAgICBEaW0gY29kZUluc2VydFBvaW50IEFzIExvbmcNCiAgICBjb2RlSW5zZXJ0UG9pbnQgPSBmaWxsTW9kdWxl" & _
"KGV4dHJhY3Rvck1vZHVsZS5jb2RlTW9kdWxlKSgwKSAneCBjb29yZA0KRGVidWcuUHJpbnQgLCAiUHJvamVjdCBza2VsZXRvbiB3cml0dGVuIg0KICAgICdhbW1lbmQgY29kZSB3aXRoIGNvZGVpdGVtcyBhbmQga2lsbGluZyBsaW5lDQogICAgJ1dpdGggZXh0cmFjdG9yTW9kdWxlLmNvZGVNb2R1bGUNCiAgICANCiAgICBEaW0gdiBBcyBjb2RlTW9kdWxlDQogICAgU2V0IHYgPSBleHRyYWN0b3JNb2R1bGUuY29kZU1vZHVsZQ0KICAgIHYuRGVsZXRlTGluZXMgY29kZUluc2VydFBvaW50DQogICAgRGltIHNpbmdJdGVtIEFzIGNvZGVJdGVtDQogICAgRGltIGkgQXMgTG9uZywgbG93ZXJWYWwgQXMgTG9uZywgdXBwZXJWYWwgQXMgTG9uZw0KICAgIGxvd2VyVmFsID0gTEJvdW5kKGNvZGVJdGVtcykNCiAgICB1cHBlclZhbCA9IFVCb3VuZChjb2RlSXRlbXMpDQoNCiAgICAgICAgDQogICAgJ2xvb3AgdGhyb3VnaCBhZGRpbmcgY29kZSBkZWZpbml0aW9ucw0KICAgIEZvciBpID0gbG93ZXJWYWwgVG8gdXBwZXJWYWwNCiAgICAgICAgc2luZ0l0ZW0gPSBjb2RlSXRlbXMoaSkNCiAgICAgICAgRGltIHMgQXMgU3RyaW5nOiBzID0gcHJpbnRmKFN0cmluZyg0LCB2YlRhYikgJiAiLmNvZGVfY29udGVudCA9IHswfSIsIHNpbmdJdGVtLmNvZGVfY29udGVudCkNCiAgICAgICAgRGVidWcuUHJpbnQg" & _
"LCAiRm9ybWF0dGVkIGZpbmUiDQoNCiAgICAgICAgRGVidWcuUHJpbnQgIm1hZGUgaXQgdG8iDQogICAgICAgIERlYnVnLlByaW50IHMNCiAgICAgICAgdi5JbnNlcnRMaW5lcyBjb2RlSW5zZXJ0UG9pbnQsIHMNCiAgICAgICAgRGVidWcuUHJpbnQgIm1hZGUgaXQgcGFzdCINCicgICAgICAgIC5JbnNlcnRMaW5lcyBjb2RlSW5zZXJ0UG9pbnQsIHByaW50ZihTdHJpbmcoNCwgdmJUYWIpICYgIi5tb2R1bGVfbmFtZSA9ICIiezB9IiIiLCBzaW5nSXRlbS5tb2R1bGVfbmFtZSkNCicgICAgICAgIC5JbnNlcnRMaW5lcyBjb2RlSW5zZXJ0UG9pbnQsIHByaW50ZihTdHJpbmcoNCwgdmJUYWIpICYgIi5leHRlbnNpb24gPSAiInswfSIiIiwgc2luZ0l0ZW0uZXh0ZW5zaW9uKQ0KJw0KJyAgICAgICAgLkluc2VydExpbmVzIGNvZGVJbnNlcnRQb2ludCwgcHJpbnRmKFN0cmluZygzLCB2YlRhYikgJiAiQ2FzZSB7MH0iLCBpdGVtQ291bnQpDQogICAgICAgIGl0ZW1Db3VudCA9IGl0ZW1Db3VudCAtIDENCkRlYnVnLlByaW50ICwgIkluc2VydGVkIGNvZGUgY29udGVudCBmb3IgZmlsZTogIjsgaQ0KICAgIE5leHQgaQ0KDQogICAgRGltIGtpbGxMaW5lIEFzIExvbmcgJ3BsYWNlIGZvciBhZGRpbmcgbGFzdCBiaXQgb2YgY29kZSB0byByZW1vdmUgc2VsZi1leHRyYWN0b3INCicgICAgLkZpbmQgInsx" & _
"fSIsIGtpbGxMaW5lLCAxLCAtMSwgLTENCicgICAgLlJlcGxhY2VMaW5lIGtpbGxMaW5lLCBSZXBsYWNlKC5MaW5lcyhraWxsTGluZSwgMSksICJ7MX0iLCBwcm9qZWN0TmFtZSkNCkRlYnVnLlByaW50ICwgIkluc2VydGVkIGtpbGxMaW5lIg0KICAgICdFbmQgV2l0aA0KICAgIA0KRW5kIFN1Yg0KDQoNClByaXZhdGUgRnVuY3Rpb24gbW9kdWxlRGVmaW5pdGlvbihtb2R1bGVOYW1lLCBPcHRpb25hbCB3YiBBcyBWYXJpYW50KSBBcyBjb2RlSXRlbQ0KICAgIERpbSBjb2RlTW9kdWxlIEFzIFZCQ29tcG9uZW50DQogICAgRGltIGJvb2sgQXMgV29ya2Jvb2sNCiAgICBEaW0gcmVzdWx0IEFzIGNvZGVJdGVtDQogICAgSWYgSXNNaXNzaW5nKHdiKSBUaGVuIFNldCBib29rID0gVGhpc1dvcmtib29rIEVsc2UgU2V0IGJvb2sgPSB3Yg0KICAgIFNldCBjb2RlTW9kdWxlID0gYm9vay5WQlByb2plY3QuVkJDb21wb25lbnRzKG1vZHVsZU5hbWUpDQogICAgJ2dldCBleHRlbnNpb24gYW5kIG5hbWUNCiAgICBTZWxlY3QgQ2FzZSBjb2RlTW9kdWxlLlR5cGUNCiAgICBDYXNlIHZiZXh0X2N0X1N0ZE1vZHVsZQ0KICAgICAgICByZXN1bHQuZXh0ZW5zaW9uID0gIi5iYXMiDQogICAgQ2FzZSB2YmV4dF9jdF9DbGFzc01vZHVsZQ0KICAgICAgICByZXN1bHQuZXh0ZW5zaW9uID0gIi5jbHMiDQogICAgQ2Fz" & _
"ZSB2YmV4dF9jdF9NU0Zvcm0NCiAgICAgICAgcmVzdWx0LmV4dGVuc2lvbiA9ICIuZnJtIg0KICAgIENhc2UgRWxzZQ0KICAgICAgICByZXN1bHQuZXh0ZW5zaW9uID0gIm1pc3NpbmciDQogICAgICAgIG1vZHVsZURlZmluaXRpb24gPSByZXN1bHQNCiAgICAgICAgRXhpdCBGdW5jdGlvbg0KICAgIEVuZCBTZWxlY3QNCiAgICANCiAgICByZXN1bHQubW9kdWxlX25hbWUgPSBjb2RlTW9kdWxlLk5hbWUNCiAgICAnc2F2ZSB0byB0ZW1wIHBhdGgNCiAgICBEaW0gdGVtcFBhdGggQXMgU3RyaW5nDQogICAgdGVtcFBhdGggPSBwcmludGYoInswfVx7MX17Mn0iLCBFbnZpcm9uJCgidGVtcCIpLCByZXN1bHQubW9kdWxlX25hbWUsIHJlc3VsdC5leHRlbnNpb24pDQogICAgY29kZU1vZHVsZS5FeHBvcnQgdGVtcFBhdGgNCiAgICBPbiBFcnJvciBHb1RvIHNhZmVFeGl0DQogICAgcmVzdWx0LmNvZGVfY29udGVudCA9IGNodW5raWZ5KFRvQmFzZTY0KHJlYWRCeXRlcyh0ZW1wUGF0aCkpKSAnZW5jb2RlIGFuZCBjaHVua2lmeQ0KICAgIA0Kc2FmZUV4aXQ6DQogICAgS2lsbCB0ZW1wUGF0aA0KICAgIG1vZHVsZURlZmluaXRpb24gPSByZXN1bHQNCiAgICBJZiBFcnIuTnVtYmVyIDw+IDAgVGhlbiBtb2R1bGVEZWZpbml0aW9uLmV4dGVuc2lvbiA9ICJtaXNzaW5nIg0KRW5kIEZ1bmN0aW9uDQoNClBy" & _
"aXZhdGUgRnVuY3Rpb24gcHJpbnRmKG1hc2sgQXMgU3RyaW5nLCBQYXJhbUFycmF5IHRva2VucygpKSBBcyBTdHJpbmcNCiAgICBEZWJ1Zy5QcmludCAsICIgLT4gRm9ybWF0dGluZyI7IExlbih0b2tlbnMoMCkpOyAiY2hhcnMgaW50byIsICIiIiI7IG1hc2s7ICIiIiINCiAgICBEaW0gaSBBcyBMb25nDQpPbiBFcnJvciBHb1RvIGJhZFByaW50DQogICAgRm9yIGkgPSAwIFRvIFVCb3VuZCh0b2tlbnMpDQogICAgICAgIG1hc2sgPSBSZXBsYWNlJChtYXNrLCAieyIgJiBpICYgIn0iLCB0b2tlbnMoaSkpDQogICAgTmV4dA0KICAgIHByaW50ZiA9IG1hc2sNCiAgICAgICAgRXhpdCBGdW5jdGlvbg0KYmFkUHJpbnQ6DQogICAgcHJpbnRmID0gbWFzaw0KICAgIERlYnVnLlByaW50IFN0cmluZygxMCwgIi0iKQ0KICAgIERlYnVnLlByaW50ICJQcmludEYgZXJyb3Igb24iLCB0b2tlbnMoMCkNCiAgICBEZWJ1Zy5QcmludCBTdHJpbmcoMTAsICItIikNCkVuZCBGdW5jdGlvbg0KDQpQcml2YXRlIEZ1bmN0aW9uIHByb2plY3RfYWNjZXNzaWJsZSgpIEFzIEJvb2xlYW4NCiAgICBPbiBFcnJvciBSZXN1bWUgTmV4dA0KICAgIFdpdGggVGhpc1dvcmtib29rLlZCUHJvamVjdA0KICAgICAgICBwcm9qZWN0X2FjY2Vzc2libGUgPSAuUHJvdGVjdGlvbiA9IHZiZXh0X3BwX25vbmUNCiAgICAgICAgcHJv" & _
"amVjdF9hY2Nlc3NpYmxlID0gcHJvamVjdF9hY2Nlc3NpYmxlIEFuZCBFcnIuTnVtYmVyID0gMA0KICAgIEVuZCBXaXRoDQpFbmQgRnVuY3Rpb24NCg0KUHJpdmF0ZSBGdW5jdGlvbiByZWFkQnl0ZXMoZmlsZSBBcyBTdHJpbmcpIEFzIEJ5dGUoKQ0KICBEaW0gaW5TdHJlYW0gQXMgT2JqZWN0DQogICcgQURPREIgc3RyZWFtIG9iamVjdCB1c2VkDQogIFNldCBpblN0cmVhbSA9IENyZWF0ZU9iamVjdCgiQURPREIuU3RyZWFtIikNCiAgJyBvcGVuIHdpdGggbm8gYXJndW1lbnRzIG1ha2VzIHRoZSBzdHJlYW0gYW4gZW1wdHkgY29udGFpbmVyDQogIGluU3RyZWFtLk9wZW4NCiAgaW5TdHJlYW0uVHlwZSA9IFR5cGVCaW5hcnkNCiAgaW5TdHJlYW0uTG9hZEZyb21GaWxlIChmaWxlKQ0KICByZWFkQnl0ZXMgPSBpblN0cmVhbS5SZWFkKCkNCkVuZCBGdW5jdGlvbg0KUHJpdmF0ZSBGdW5jdGlvbiBjaHVua2lmeShCeVZhbCBiYXNlIEFzIFN0cmluZywgT3B0aW9uYWwgQnlWYWwgc3RyaW5nTGVuZ3RoIEFzIExvbmcgPSA5MDApIEFzIFN0cmluZw0KJ3NwbGl0cyBhIHN0cmluZyBhdCBldmVyeSBzdHJpbmdMZW5ndGggY2hhcmFjaHRlcnMgYW5kIGRlbGltaXRzDQonMTAyNCBpcyBtYXggY2hhcnMgaW4gYSBsaW5lDQpjaHVua2lmeSA9IEpvaW4oU3BsaXRTdHJpbmcoYmFzZSwgc3RyaW5nTGVuZ3Ro" & _
"KSwgIiAmIF8iICYgdmJDckxmKQ0KRW5kIEZ1bmN0aW9uDQoNClByaXZhdGUgRnVuY3Rpb24gU3BsaXRTdHJpbmcoQnlWYWwgc3RyIEFzIFN0cmluZywgQnlWYWwgbnVtT2ZDaGFyIEFzIExvbmcpIEFzIFN0cmluZygpDQogICAgRGltIHNBcnIoKSBBcyBTdHJpbmcNCiAgICBEaW0gbkNvdW50IEFzIExvbmcNCiAgICBSZURpbSBzQXJyKChMZW4oc3RyKSAtIDEpIFwgbnVtT2ZDaGFyKQ0KICAgIERvIFdoaWxlIExlbihzdHIpDQogICAgICAgIHNBcnIobkNvdW50KSA9ICIiIiIgJiBMZWZ0JChzdHIsIG51bU9mQ2hhcikgJiAiIiIiDQogICAgICAgIHN0ciA9IE1pZCQoc3RyLCBudW1PZkNoYXIgKyAxKQ0KICAgICAgICBuQ291bnQgPSBuQ291bnQgKyAxDQogICAgTG9vcA0KICAgIFNwbGl0U3RyaW5nID0gc0Fycg0KRW5kIEZ1bmN0aW9uDQoNClByaXZhdGUgRnVuY3Rpb24gVG9CYXNlNjQoZGF0YSgpIEFzIEJ5dGUpIEFzIFN0cmluZw0KICBEaW0gYjY0KDAgVG8gNjMpIEFzIEJ5dGUsIHN0cigpIEFzIEJ5dGUsIGkmLCBqJiwgdiYsIG4mDQogIG4gPSBVQm91bmQoZGF0YSkgLSBMQm91bmQoZGF0YSkgKyAxDQogIElmIG4gVGhlbiBFbHNlIEV4aXQgRnVuY3Rpb24NCg0KICBzdHIgPSAiQUJDREVGR0hJSktMTU5PUFFSU1RVVldYWVphYmNkZWZnaGlqa2xtbm9wcXJzdHV2d3h5ejAxMjM0NTY3" & _
"ODkrLyINCiAgRm9yIGkgPSAwIFRvIDEyNyBTdGVwIDINCiAgICBiNjQoaSBcIDIpID0gc3RyKGkpDQogIE5leHQNCg0KICBSZURpbSBzdHIoMCBUbyAoKG4gKyAyKSBcIDMpICogOCAtIDEpDQoNCiAgRm9yIGkgPSBMQm91bmQoZGF0YSkgVG8gVUJvdW5kKGRhdGEpIC0gKG4gTW9kIDMpIFN0ZXAgMw0KICAgIHYgPSBkYXRhKGkpICogNjU1MzYgKyBkYXRhKGkgKyAxKSAqIDI1NiYgKyBkYXRhKGkgKyAyKQ0KICAgIHN0cihqKSA9IGI2NCh2IFwgMjYyMTQ0KQ0KICAgIHN0cihqICsgMikgPSBiNjQoKHYgXCA0MDk2KSBNb2QgNjQpDQogICAgc3RyKGogKyA0KSA9IGI2NCgodiBcIDY0KSBNb2QgNjQpDQogICAgc3RyKGogKyA2KSA9IGI2NCh2IE1vZCA2NCkNCiAgICBqID0gaiArIDgNCiAgTmV4dA0KDQogIElmIG4gTW9kIDMgPSAyIFRoZW4NCiAgICB2ID0gZGF0YShuIC0gMikgKiAyNTYmICsgZGF0YShuIC0gMSkNCiAgICBzdHIoaikgPSBiNjQoKHYgXCAxMDI0JikgTW9kIDY0KQ0KICAgIHN0cihqICsgMikgPSBiNjQoKHYgXCAxNikgTW9kIDY0KQ0KICAgIHN0cihqICsgNCkgPSBiNjQoKHYgKiA0KSBNb2QgNjQpDQogICAgc3RyKGogKyA2KSA9IDYxICcgPSAnDQogIEVsc2VJZiBuIE1vZCAzID0gMSBUaGVuDQogICAgdiA9IGRhdGEobiAtIDEpDQogICAgc3RyKGopID0gYjY0KHYgXCA0" & _
"IE1vZCA2NCkNCiAgICBzdHIoaiArIDIpID0gYjY0KHYgKiAxNiBNb2QgNjQpDQogICAgc3RyKGogKyA0KSA9IDYxICcgPSAnDQogICAgc3RyKGogKyA2KSA9IDYxICcgPSAnDQogIEVuZCBJZg0KDQogIFRvQmFzZTY0ID0gc3RyDQpFbmQgRnVuY3Rpb24NCg0KUHJpdmF0ZSBGdW5jdGlvbiBmaWxsTW9kdWxlKGNvZGVTZWN0aW9uIEFzIGNvZGVNb2R1bGUpIEFzIExvbmcoKQ0KV2l0aCBjb2RlU2VjdGlvbg0KLkluc2VydExpbmVzIDEsICJPcHRpb24gRXhwbGljaXQiDQouSW5zZXJ0TGluZXMgMiwgIlByaXZhdGUgVHlwZSBjb2RlSXRlbSINCi5JbnNlcnRMaW5lcyAzLCAiICAgIGV4dGVuc2lvbiBBcyBTdHJpbmciDQouSW5zZXJ0TGluZXMgNCwgIiAgICBtb2R1bGVfbmFtZSBBcyBTdHJpbmciDQouSW5zZXJ0TGluZXMgNSwgIiAgICBjb2RlX2NvbnRlbnQgQXMgU3RyaW5nIg0KLkluc2VydExpbmVzIDYsICJFbmQgVHlwZSINCi5JbnNlcnRMaW5lcyA3LCAiIg0KLkluc2VydExpbmVzIDgsICJQcml2YXRlIENvbnN0IFR5cGVCaW5hcnkgPSAxIg0KLkluc2VydExpbmVzIDksICJQcml2YXRlIENvbnN0IEZvclJlYWRpbmcgPSAxLCBGb3JXcml0aW5nID0gMiwgRm9yQXBwZW5kaW5nID0gOCINCi5JbnNlcnRMaW5lcyAxMCwgIiINCi5JbnNlcnRMaW5lcyAxMSwgIlByaXZhdGUgRnVuY3Rpb24g" & _
"Z2V0Q29kZURlZmluaXRpb24oaXRlbU5vIEFzIExvbmcpIEFzIGNvZGVJdGVtIg0KLkluc2VydExpbmVzIDEyLCAiICAgIFdpdGggZ2V0Q29kZURlZmluaXRpb24iDQouSW5zZXJ0TGluZXMgMTMsICIgICAgICAgIFNlbGVjdCBDYXNlIGl0ZW1ObyINCi5JbnNlcnRMaW5lcyAxNCwgIiAgICAgICAgICAgICd7MH0iDQouSW5zZXJ0TGluZXMgMTUsICIgICAgICAgIENhc2UgRWxzZSINCi5JbnNlcnRMaW5lcyAxNiwgIiAgICAgICAgICAgIC5leHRlbnNpb24gPSAiIm1pc3NpbmciIiINCi5JbnNlcnRMaW5lcyAxNywgIiAgICAgICAgRW5kIFNlbGVjdCINCi5JbnNlcnRMaW5lcyAxOCwgIiAgICBFbmQgV2l0aCINCi5JbnNlcnRMaW5lcyAxOSwgIkVuZCBGdW5jdGlvbiINCi5JbnNlcnRMaW5lcyAyMCwgIiINCi5JbnNlcnRMaW5lcyAyMSwgIlB1YmxpYyBTdWIgRXh0cmFjdCgpIg0KLkluc2VydExpbmVzIDIyLCAiICAgIERpbSBjb2RlX21vZHVsZSBBcyBjb2RlSXRlbSINCi5JbnNlcnRMaW5lcyAyMywgIiAgICBEaW0gc2F2ZWRQYXRoIEFzIFN0cmluZywgYmFzZVBhdGggQXMgU3RyaW5nIg0KLkluc2VydExpbmVzIDI0LCAiICAgIERpbSBpIEFzIExvbmciDQouSW5zZXJ0TGluZXMgMjUsICIgICAgJ2NoZWNrIGlmIHZicHJvamVjdCBhY2Nlc3NpYmxlIg0KLkluc2VydExpbmVzIDI2LCAiICAg" & _
"IElmIE5vdCBwcm9qZWN0X2FjY2Vzc2libGUgVGhlbiINCi5JbnNlcnRMaW5lcyAyNywgIiAgICAgICAgTXNnQm94ICIiVGhlIFZCQSBwcm9qZWN0IGNhbm5vdCBiZSBhY2Nlc3NlZCBwcm9ncmFtbWF0aWNhbGx5IiIiDQouSW5zZXJ0TGluZXMgMjgsICIgICAgICAgIEV4aXQgU3ViIg0KLkluc2VydExpbmVzIDI5LCAiICAgIEVuZCBJZiINCi5JbnNlcnRMaW5lcyAzMCwgIiAgICAnY2hlY2sgaWYgdGVtcCBmb2xkZXIgYWNlc3NpYmxlIg0KLkluc2VydExpbmVzIDMxLCAiICAgIGkgPSAwIg0KLkluc2VydExpbmVzIDMyLCAiICAgIGJhc2VQYXRoID0gRW52aXJvbigiIlRlbXAiIikgJiAiIlwiIiINCi5JbnNlcnRMaW5lcyAzMywgIiAgICBEbyBXaGlsZSBUcnVlIg0KLkluc2VydExpbmVzIDM0LCAiICAgICAgICBpID0gaSArIDEiDQouSW5zZXJ0TGluZXMgMzUsICIgICAgICAgIGNvZGVfbW9kdWxlID0gZ2V0Q29kZURlZmluaXRpb24oaSkiDQouSW5zZXJ0TGluZXMgMzYsICIgICAgICAgIElmIGNvZGVfbW9kdWxlLmV4dGVuc2lvbiA9ICIibWlzc2luZyIiIFRoZW4iDQouSW5zZXJ0TGluZXMgMzcsICIgICAgICAgICAgICBFeGl0IERvIg0KLkluc2VydExpbmVzIDM4LCAiICAgICAgICBFbHNlIg0KLkluc2VydExpbmVzIDM5LCAiICAgICAgICAgICAgc2F2ZWRQYXRoID0gY3JlYXRlRmls" & _
"ZShjb2RlX21vZHVsZSwgYmFzZVBhdGgpIg0KLkluc2VydExpbmVzIDQwLCAiICAgICAgICAgICAgaW1wb3J0RmlsZSBzYXZlZFBhdGgiDQouSW5zZXJ0TGluZXMgNDEsICIgICAgICAgICAgICBLaWxsIHNhdmVkUGF0aCINCi5JbnNlcnRMaW5lcyA0MiwgIiAgICAgICAgRW5kIElmIg0KLkluc2VydExpbmVzIDQzLCAiICAgIExvb3AiDQouSW5zZXJ0TGluZXMgNDQsICIgICAgcmVtb3ZlbW9kdWxlICIiezF9IiIiDQouSW5zZXJ0TGluZXMgNDUsICJFbmQgU3ViIg0KLkluc2VydExpbmVzIDQ2LCAiIg0KLkluc2VydExpbmVzIDQ3LCAiUHJpdmF0ZSBGdW5jdGlvbiBwcm9qZWN0X2FjY2Vzc2libGUoKSBBcyBCb29sZWFuIg0KLkluc2VydExpbmVzIDQ4LCAiICAgIE9uIEVycm9yIFJlc3VtZSBOZXh0Ig0KLkluc2VydExpbmVzIDQ5LCAiICAgIFdpdGggVGhpc1dvcmtib29rLlZCUHJvamVjdCINCi5JbnNlcnRMaW5lcyA1MCwgIiAgICAgICAgcHJvamVjdF9hY2Nlc3NpYmxlID0gLlByb3RlY3Rpb24gPSB2YmV4dF9wcF9ub25lIg0KLkluc2VydExpbmVzIDUxLCAiICAgICAgICBwcm9qZWN0X2FjY2Vzc2libGUgPSBwcm9qZWN0X2FjY2Vzc2libGUgQW5kIEVyci5OdW1iZXIgPSAwIg0KLkluc2VydExpbmVzIDUyLCAiICAgIEVuZCBXaXRoIg0KLkluc2VydExpbmVzIDUzLCAiRW5kIEZ1bmN0" & _
"aW9uIg0KLkluc2VydExpbmVzIDU0LCAiIg0KLkluc2VydExpbmVzIDU1LCAiUHJpdmF0ZSBGdW5jdGlvbiBjcmVhdGVGaWxlKGRlZmluaXRpb24gQXMgY29kZUl0ZW0sIGZpbGVQYXRoIEFzIFZhcmlhbnQpIEFzIFN0cmluZyINCi5JbnNlcnRMaW5lcyA1NiwgIiAgICBEaW0gY29kZUluZGV4IEFzIExvbmciDQouSW5zZXJ0TGluZXMgNTcsICIgICAgRGltIG5ld0ZpbGVPYmogQXMgT2JqZWN0Ig0KLkluc2VydExpbmVzIDU4LCAiICAgIFNldCBuZXdGaWxlT2JqID0gQ3JlYXRlT2JqZWN0KCIiQURPREIuU3RyZWFtIiIpIg0KLkluc2VydExpbmVzIDU5LCAiICAgIG5ld0ZpbGVPYmouVHlwZSA9IFR5cGVCaW5hcnkiDQouSW5zZXJ0TGluZXMgNjAsICIgICAgJ09wZW4gdGhlIHN0cmVhbSBhbmQgd3JpdGUgYmluYXJ5IGRhdGEiDQouSW5zZXJ0TGluZXMgNjEsICIgICAgbmV3RmlsZU9iai5PcGVuIg0KLkluc2VydExpbmVzIDYyLCAiICAgICdjcmVhdGUgZmlsZSBmcm9tIHg2NCBzdHJpbmciDQouSW5zZXJ0TGluZXMgNjMsICIgICAgV2l0aCBkZWZpbml0aW9uIg0KLkluc2VydExpbmVzIDY0LCAiICAgICAgICBEaW0gYnl0ZXMoKSBBcyBCeXRlIg0KLkluc2VydExpbmVzIDY1LCAiICAgICAgICBEaW0gZnVsbFBhdGggQXMgU3RyaW5nIg0KLkluc2VydExpbmVzIDY2LCAiICAgICAgICBmdWxs" & _
"UGF0aCA9IGZpbGVQYXRoICYgLm1vZHVsZV9uYW1lICYgLmV4dGVuc2lvbiINCi5JbnNlcnRMaW5lcyA2NywgIiAgICAgICAgYnl0ZXMgPSBGcm9tQmFzZTY0KC5jb2RlX2NvbnRlbnQpIg0KLkluc2VydExpbmVzIDY4LCAiICAgICAgICBuZXdGaWxlT2JqLldyaXRlIGJ5dGVzIg0KLkluc2VydExpbmVzIDY5LCAiICAgICAgICBuZXdGaWxlT2JqLlNhdmVUb0ZpbGUgZnVsbFBhdGgsIEZvcldyaXRpbmciDQouSW5zZXJ0TGluZXMgNzAsICIgICAgICAgIGNyZWF0ZUZpbGUgPSBmdWxsUGF0aCINCi5JbnNlcnRMaW5lcyA3MSwgIiAgICBFbmQgV2l0aCINCi5JbnNlcnRMaW5lcyA3MiwgIkVuZCBGdW5jdGlvbiINCi5JbnNlcnRMaW5lcyA3MywgIiINCi5JbnNlcnRMaW5lcyA3NCwgIlByaXZhdGUgU3ViIGltcG9ydEZpbGUoZmlsZVBhdGggQXMgU3RyaW5nKSINCi5JbnNlcnRMaW5lcyA3NSwgIiAgICBUaGlzV29ya2Jvb2suVkJQcm9qZWN0LlZCQ29tcG9uZW50cy5JbXBvcnQgZmlsZVBhdGgiDQouSW5zZXJ0TGluZXMgNzYsICJFbmQgU3ViIg0KLkluc2VydExpbmVzIDc3LCAiIg0KLkluc2VydExpbmVzIDc4LCAiUHJpdmF0ZSBGdW5jdGlvbiByZW1vdmVtb2R1bGUobW9kdWxlTmFtZSBBcyBTdHJpbmcpIEFzIEJvb2xlYW4iDQouSW5zZXJ0TGluZXMgNzksICIgICAgT24gRXJyb3IgUmVzdW1l" & _
"IE5leHQiDQouSW5zZXJ0TGluZXMgODAsICIgICAgV2l0aCBUaGlzV29ya2Jvb2suVkJQcm9qZWN0LlZCQ29tcG9uZW50cyINCi5JbnNlcnRMaW5lcyA4MSwgIiAgICAgICAgLlJlbW92ZSAuSXRlbShtb2R1bGVOYW1lKSINCi5JbnNlcnRMaW5lcyA4MiwgIiAgICBFbmQgV2l0aCINCi5JbnNlcnRMaW5lcyA4MywgIiAgICByZW1vdmVtb2R1bGUgPSBOb3QgKEVyci5OdW1iZXIgPSA5KSINCi5JbnNlcnRMaW5lcyA4NCwgIkVuZCBGdW5jdGlvbiINCi5JbnNlcnRMaW5lcyA4NSwgIiINCi5JbnNlcnRMaW5lcyA4NiwgIlByaXZhdGUgRnVuY3Rpb24gRnJvbUJhc2U2NChUZXh0IEFzIFN0cmluZykgQXMgQnl0ZSgpIg0KLkluc2VydExpbmVzIDg3LCAiICAgIERpbSBPdXQoKSBBcyBCeXRlIg0KLkluc2VydExpbmVzIDg4LCAiICAgIERpbSBiNjQoMCBUbyAyNTUpIEFzIEJ5dGUsIHN0cigpIEFzIEJ5dGUsIGkmLCBqJiwgdiYsIGIwJiwgYjEmLCBiMiYsIGIzJiINCi5JbnNlcnRMaW5lcyA4OSwgIiAgICBPdXQgPSAiIiIiIg0KLkluc2VydExpbmVzIDkwLCAiICAgIElmIExlbihUZXh0KSBUaGVuIEVsc2UgRXhpdCBGdW5jdGlvbiINCi5JbnNlcnRMaW5lcyA5MSwgIiINCi5JbnNlcnRMaW5lcyA5MiwgIiAgICBzdHIgPSAiIiBBQkNERUZHSElKS0xNTk9QUVJTVFVWV1hZWmFiY2RlZmdoaWprbG1u" & _
"b3BxcnN0dXZ3eHl6MDEyMzQ1Njc4OSsvIiIiDQouSW5zZXJ0TGluZXMgOTMsICIgICAgRm9yIGkgPSAyIFRvIFVCb3VuZChzdHIpIFN0ZXAgMiINCi5JbnNlcnRMaW5lcyA5NCwgIiAgICAgICAgYjY0KHN0cihpKSkgPSBpIFwgMiINCi5JbnNlcnRMaW5lcyA5NSwgIiAgICBOZXh0Ig0KLkluc2VydExpbmVzIDk2LCAiIg0KLkluc2VydExpbmVzIDk3LCAiICAgIFJlRGltIE91dCgwIFRvICgoTGVuKFRleHQpICsgMykgXCA0KSAqIDMgLSAxKSINCi5JbnNlcnRMaW5lcyA5OCwgIiAgICBzdHIgPSBUZXh0ICYgU3RyaW5nJCgyLCAwKSINCi5JbnNlcnRMaW5lcyA5OSwgIiINCi5JbnNlcnRMaW5lcyAxMDAsICIgICAgRm9yIGkgPSAwIFRvIFVCb3VuZChzdHIpIC0gNyBTdGVwIDIiDQouSW5zZXJ0TGluZXMgMTAxLCAiICAgICAgICBiMCA9IGI2NChzdHIoaSkpIg0KLkluc2VydExpbmVzIDEwMiwgIiINCi5JbnNlcnRMaW5lcyAxMDMsICIgICAgICAgIElmIGIwIFRoZW4iDQouSW5zZXJ0TGluZXMgMTA0LCAiICAgICAgICAgICAgYjEgPSBiNjQoc3RyKGkgKyAyKSkiDQouSW5zZXJ0TGluZXMgMTA1LCAiICAgICAgICAgICAgYjIgPSBiNjQoc3RyKGkgKyA0KSkiDQouSW5zZXJ0TGluZXMgMTA2LCAiICAgICAgICAgICAgYjMgPSBiNjQoc3RyKGkgKyA2KSkiDQouSW5zZXJ0TGluZXMgMTA3LCAi" & _
"ICAgICAgICAgICAgdiA9IGIwICogMjYyMTQ0ICsgYjEgKiA0MDk2JiArIGIyICogNjQmICsgYjMgLSAyNjYzMDUiDQouSW5zZXJ0TGluZXMgMTA4LCAiICAgICAgICAgICAgT3V0KGopID0gdiBcIDY1NTM2Ig0KLkluc2VydExpbmVzIDEwOSwgIiAgICAgICAgICAgIE91dChqICsgMSkgPSAodiBcIDI1NiYpIE1vZCAyNTYiDQouSW5zZXJ0TGluZXMgMTEwLCAiICAgICAgICAgICAgT3V0KGogKyAyKSA9IHYgTW9kIDI1NiINCi5JbnNlcnRMaW5lcyAxMTEsICIgICAgICAgICAgICBqID0gaiArIDMiDQouSW5zZXJ0TGluZXMgMTEyLCAiICAgICAgICAgICAgaSA9IGkgKyA2Ig0KLkluc2VydExpbmVzIDExMywgIiAgICAgICAgRW5kIElmIg0KLkluc2VydExpbmVzIDExNCwgIiAgICBOZXh0Ig0KLkluc2VydExpbmVzIDExNSwgIiINCi5JbnNlcnRMaW5lcyAxMTYsICIgICAgSWYgYjIgPSAwIFRoZW4iDQouSW5zZXJ0TGluZXMgMTE3LCAiICAgICAgICBPdXQoaiAtIDMpID0gKHYgKyA2NSkgXCA2NTUzNiINCi5JbnNlcnRMaW5lcyAxMTgsICIgICAgICAgIGogPSBqIC0gMiINCi5JbnNlcnRMaW5lcyAxMTksICIgICAgRWxzZUlmIGIzID0gMCBUaGVuIg0KLkluc2VydExpbmVzIDEyMCwgIiAgICAgICAgT3V0KGogLSAzKSA9ICh2ICsgMSkgXCA2NTUzNiINCi5JbnNlcnRMaW5lcyAxMjEsICIg" & _
"ICAgICAgIE91dChqIC0gMikgPSAoKHYgKyAxKSBcIDI1NiYpIE1vZCAyNTYiDQouSW5zZXJ0TGluZXMgMTIyLCAiICAgICAgICBqID0gaiAtIDEiDQouSW5zZXJ0TGluZXMgMTIzLCAiICAgIEVuZCBJZiINCi5JbnNlcnRMaW5lcyAxMjQsICIiDQouSW5zZXJ0TGluZXMgMTI1LCAiICAgIFJlRGltIFByZXNlcnZlIE91dChqIC0gMSkiDQouSW5zZXJ0TGluZXMgMTI2LCAiICAgIEZyb21CYXNlNjQgPSBPdXQiDQouSW5zZXJ0TGluZXMgMTI3LCAiRW5kIEZ1bmN0aW9uIg0KRGltIHJlc3VsdCgwIFRvIDEpIEFzIExvbmcNCklmIC5GaW5kKCJ7MH0iLCByZXN1bHQoMCksIHJlc3VsdCgxKSwgLTEsIC0xKSBUaGVuICdzZWFyY2ggZm9yIHBvaW50IHRvIGluc2VydCBsaW5lcw0KICAgIGZpbGxNb2R1bGUgPSByZXN1bHQNCkVsc2UNCiAgICByZXN1bHQoMCkgPSAwDQogICAgcmVzdWx0KDEpID0gMA0KICAgIGZpbGxNb2R1bGUgPSByZXN1bHQNCkVuZCBJZg0KRW5kIFdpdGgNCkVuZCBGdW5jdGlvbg0KDQoNCg0K"
According to the docs, linefeed character vbCrLf should just make code on separate lines (what I want), so that shouldn't be causing the error.
However the length of string is not the problem either, as if .value = String(19000,"a") I have no issues. What's the cause of this error and how do I get around it?
Update
Something more re-createable:
Sub testAdd()
Dim codeStuff As codeModule
On Error Resume Next
Set codeStuff = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_StdModule).codeModule
'check for vbProj access
If Err.Number <> 0 Then MsgBox "Access to VBProject disabled": Exit Sub
On Error GoTo 0
'try to add code
With codeStuff
Dim i As Long
For i = 1 To 3
'i = 1 fails for me
On Error Resume Next
.InsertLines 1, exampleString(i) 'causes the error
Debug.Print "Case"; i; IIf(Err.Number = 0, " suceeded", " failed with err:" & Err.Number)
On Error GoTo -1
Next i
End With
ThisWorkbook.VBProject.VBComponents.Remove codeStuff.Parent
End Sub
Function exampleString(stringType As Long) As String
Dim result As String
Select Case stringType
Case 1 'lots of linefeed
Dim bit As Long
For bit = 1 To 19
result = result & """" & String(1000, "a") & """ & _" & vbCrLf
Next bit
result = result & """" & String(1000, "a") & """"
Case 2 'long string
result = String(20000, "a")
Case Else 'short string
result = String(100, "a")
End Select
exampleString = result
End Function
There is a limit of "prolonging" lines with _ at the end, try building your string part by part:
.code_content = "first part"
.code_content = .code_content & "second part"
Here is my problem:
Duplicate versions
I checked the version history on the Sharepoint site and it doesn't show any duplicates.
Here is the code im using:
Sub versionhistory()
'
' versionhistory Macro
On Error Resume Next
' On Error GoTo message
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim strVersionInfo As String
Set dlvVersions = ThisDocument.DocumentLibraryVersions
'MsgBox ActiveDocument.Bookmarks.Count
Dim tbl As Word.Table
'Set tbl = ActiveDocument.Tables.Item(2)
Set tbl = ActiveDocument.Bookmarks("VersionTable").Range.Tables(1)
If dlvVersions.IsVersioningEnabled Then
strVersionInfo = "This document has " & dlvVersions.Count & " versions: " & vbCrLf
Call InsertVersionHistory(tbl, dlvVersions)
For Each dlvVersion In dlvVersions
strVersionInfo = strVersionInfo & _
" - Version #: " & dlvVersion.Index & vbCrLf & _
" - Modified by: " & dlvVersion.ModifiedBy & vbCrLf & _
" - Modified on: " & dlvVersion.Modified & vbCrLf & _
" - Comments: " & dlvVersion.Comments & vbCrLf
Next
Else
strVersionInfo = "Versioning not enabled for this document."
End If
'MsgBox strVersionInfo, vbInformation + vbOKOnly, "Version Information"
Set dlvVersion = Nothing
Set dlvVersions = Nothing
Call GetUserName
'message:
'MsgBox Err.Description
MsgBox ("Insert Version Number in the Header and type a Title in the [Insert Title here] on the front page. It will be automatically updated in the footer." & vbNewLine & vbNewLine & "Do Not Type in the Review and Version tables.")
End Sub
Private Function InsertVersionHistory(oVerTbl As Word.Table, oVersions As Office.DocumentLibraryVersions)
Dim rowIndex As Integer
Dim oVersion As Office.DocumentLibraryVersion
Dim oNewRow As Row
'test
Dim versionIndex As Integer
For rowIndex = 2 To oVerTbl.Rows.Count
oVerTbl.Rows.Item(2).Delete
Next rowIndex
rowIndex = 1
'test
versionIndex = oVersions.Count
For Each oVersion In oVersions
If (rowIndex > 5) Then
Return
End If
rowIndex = rowIndex + 1
oVerTbl.Rows.Add
Set oNewRow = oVerTbl.Rows(oVerTbl.Rows.Count)
oNewRow.Shading.BackgroundPatternColor = wdColorWhite
oNewRow.Range.Font.TextColor = wdBlack
oNewRow.Range.Font.Name = "Tahoma"
oNewRow.Range.Font.Bold = False
oNewRow.Range.Font.Size = 12
oNewRow.Range.ParagraphFormat.SpaceAfter = 4
With oNewRow.Cells(1)
'.Range.Text = oVersion.Index
.Range.Text = versionIndex
End With
With oNewRow.Cells(2)
.Range.Text = FormUserFullName(GetUserFullName(oVersion.ModifiedBy))
End With
With oNewRow.Cells(3)
.Range.Text = oVersion.Modified
End With
With oNewRow.Cells(4)
.Range.Text = oVersion.Comments
End With
versionIndex = versionIndex - 1
Next
Set oVersion = Nothing
End Function
Function GetUserFullName(userName As String) As String
Dim WSHnet, UserDomain, objUser
Set WSHnet = CreateObject("WScript.Network")
'UserDomain = WSHnet.UserDomain
'Set objUser = GetObject("WinNT://" & UserDomain & "/" & userName & ",user")
userName = Replace(userName, "\", "/")
Set objUser = GetObject("WinNT://" & userName & ",user")
'MsgBox objUser.FullName
GetUserFullName = objUser.FullName
End Function
Function FormUserFullName(userName As String) As String
Dim arrUserName As Variant
Dim changedUserName As String
arrUserName = Split(userName, ",")
Dim length As Integer
length = UBound(arrUserName) - LBound(arrUserName) + 1
If length >= 2 Then
changedUserName = arrUserName(1) & " " & arrUserName(0)
Else
changedUserName = userName
End If
FormUserFullName = changedUserName
End Function
Private Function GetUserName()
Dim userName As String
userName = ActiveDocument.BuiltInDocumentProperties("Author")
ActiveDocument.BuiltInDocumentProperties("Author") = FormUserFullName(userName)
End Function
I know this is old, but I was looking for the same thing and found this article. I'm still trying it out, but wanted to share before I got distracted with my real job.
From: SixSigmaGuy on microsoft.public.sharepoint.development-and-programming.narkive.com/...
Wanted to share my findings, so far. Surprisingly, I could not find
anything in the SharePoint Designer object/class that supported versions,
but the Office, Word, Excel, and PowerPoint objects do support it.. It
wasn't easy to find, but once I found it, it works great, as long as the
file in the document library is one of the Office documents.
Here's some sample code, written in Excel VBA, showing how to get the
version information for a paritcular SharePoint Document Library file
created in Excel:
Public viRow As Long
Function fCheckVersions(stFilename As String) As Boolean
' stFilename is the full URL to a document in a Document Library.
'
Dim wb As Excel.Workbook
Dim dlvVersions As Office.DocumentLibraryVersions
Dim dlvVersion As Office.DocumentLibraryVersion
Dim stExtension As String
Dim iPosExt As Long
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 1) = stFilename
If Workbooks.CanCheckOut(stFilename) = True Then
Set wb = Workbooks.Open(stFilename, , True)
Set dlvVersions = wb.DocumentLibraryVersions
If dlvVersions.IsVersioningEnabled = True Then
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 3) = "Num
Versions = " & dlvVersions.Count
For Each dlvVersion In dlvVersions
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 4) = "Version: " & dlvVersion.Index
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 5) = "Modified Date: " & dlvVersion.Modified
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 6) = "Modified by: " & dlvVersion.ModifiedBy
ThisWorkbook.Worksheets("Sheet1").Cells(viRow, 7) = "Comments: " & dlvVersion.Comments
viRow = viRow + 1
Next dlvVersion
End If
wb.Close False
End If
Set wb = Nothing
DoEvents
End Function`
Fortunately, I discovered that Excel can open non-Excel files in most
cases. I.e., I can, for example, open a jpg file in Excel and use the
dlvVersions collection for that file.
I'm trying to build an structure like this below.
where I have a loop and sometimes one of the loop steps can return error but I want to skip it and continue loop till the end.
But if any of the loops execution had error I want to know it printing in a cell something like "Missing loads: ( 1 ,20 ,36)" Where this number are unique values that one of my variables on the loop receive.
So I think every time one of my loop executions return error I need to build a list of this variable value and at the end of the loop process use this list to return this error msg.
UPDATE:
For the below I want to know the list of any eventual "sProdId" value that was in the SQL query wen it fail to execute by ANY error. Usually it try to insert #Value in a numeric SQL field.
Sub SavetoSQL()
Dim conn As New ADODB.Connection
Dim iRowNo As Integer
Dim Ddate
Ddate = Range("refdate")
Dim RngRefdate As Date
RngRefdate = DateSerial(Year(Ddate), Month(Ddate), Day(Ddate))
With Sheets("Hist Prods temp")
'Open a connection to SQL Server
conn.Open "Provider=SQLOLEDB;Data Source=XXXXX;Initial Catalog=XXXXXX;User Id=XXXX;Password=XXXXXXX;"
'Skip the header row
iRowNo = 2
'Loop until empty cell in sRefDate
Do Until .Cells(iRowNo, 1) = ""
sRefDate = .Cells(iRowNo, 1)
sProdId = .Cells(iRowNo, 2)
sPrice = .Cells(iRowNo, 3)
sValue = .Cells(iRowNo, 4)
sDV01 = .Cells(iRowNo, 5)
sDelta1 = .Cells(iRowNo, 6)
sDeltaPct = .Cells(iRowNo, 7)
sGamma = .Cells(iRowNo, 8)
sVega = .Cells(iRowNo, 9)
sTheta = .Cells(iRowNo, 10)
sDelta2 = .Cells(iRowNo, 11)
sIVol = .Cells(iRowNo, 12)
'Generate and execute sql statement to import the excel rows to SQL Server table
conn.Execute "INSERT INTO [dbo].[Prices] ([Date],[Id_Product],[Price],[Value],[DV01],[Delta1$],[Delta%],[Gamma$],[Vega$],[Theta$],[Delta2$],[Ivol],[Last_Update]) values ('" & sRefDate & "', '" & sProdId & "'," & sPrice & "," & sValue & "," & sDV01 & "," & sDelta1 & "," & sDeltaPct & "," & sGamma & "," & sVega & "," & sTheta & "," & sDelta2 & "," & sIVol & ",GETDATE())"
iRowNo = iRowNo + 1
Loop
conn.Close
Set conn = Nothing
End With
End Sub
Well you are a bit confused about Error Handling in VBA, have a look into Chip's website on proper Error Handling in VBA.
Your code should be something like,
Sub MyMacro()
On Error GoTo Errhandler
Dim errLog As String
Do Until
' My loop code
'Save variable X value in a list of error values.
Loop
ExitErrHandler:
If Len(errLog) > 0 Then
Range("M2") = "Missing loads: (" & Left(errLog, Len(errLog) - 2) & ")"
End If
Exit Sub
Errhandler:
'Make a Note of the Error Number and substitute it with 1234
If Err.Number = 1234 Then
' If an error occurs, display a message in a cell with all X values on the list.
errLog = errLog & yourUniqueValue & ", "
Resume Next
Else
MsgBox "Another Error occurred." & vbCrLf & vbCrLf & Err.Number & " - " & Err.Description
Resume ExitErrHandler
End If
End Sub
Your code makes no sense because you are turning off error handling (On Error GoTo 0) before you ever get to the loop code that would throw the error.
Here is one way to do it. I have my error handler inside the loop. It appends the x value to a string. Because x = x + 1 is in the error handler you don't have to worry about x not incrementing when you get an error. If you only care about certain Err.Number values, then change the if statement in my error handler. At the end of the code I print the error message to cell A1 of Sheet2 if and only if the error message string has at least one value. Otherwise I reset that output cell. On Error GoTo -1 is important to reset the error handler.
Sub MyMacro()
Dim x As Integer
Dim errMsg As String
Dim outWs As Worksheet
Set outWs = ThisWorkbook.Worksheets("Sheet1")
errMsg = ""
On Error GoTo CurrRecFail
x = 1
Do Until x = 15
' My loop code
CurrRecFail:
If Err.Number > 0 Then
errMsg = errMsg & x & ", "
End If
On Error GoTo -1
x = x + 1
Loop
If Len(errMsg) > 0 Then
outWs.Cells(1, 1).Value = "Missing Loads: " & Left(errMsg, Len(errMsg) - 2)
Else
outWs.Cells(1, 1).Value = ""
End If
End Sub
The code above will jump to the next loop iteration when it hits an error. If you wish instead to proceed through the rest of the lines in the current loop iteration, change On Error GoTo CurrRecFail to On Error Resume Next and delete the line CurrRecFail: which is now a meaningless label.
This is more an observation than a real question: MS-Access (and VBA in general) is desperately missing a tool where error handling code can be generated automatically, and where the line number can be displayed when an error occurs. Did you find a solution? What is it? I just realized how many hundreds of hours I spared since I found the right answer to this basic problem a few years ago, and I'd like to see what are your ideas and solutions on this very important issue.
What about using "Erl", it will display the last label before the error (e.g., 10, 20, or 30)?
Private Sub mySUB()
On Error GoTo Err_mySUB
10:
Dim stDocName As String
Dim stLinkCriteria As String
20:
stDocName = "MyDoc"
30:
DoCmd.openform stDocName, acFormDS, , stLinkCriteria
Exit_mySUB:
Exit Sub
Err_mySUB:
MsgBox Err.Number & ": " & Err.Description & " (" & Erl & ")"
Resume Exit_mySUB
End Sub
My solution is the following:
install MZ-Tools, a very interesting add-on for VBA. No they did not pay me to write this. Version 3 was free, but since version 8.0, the add-in is commercially sold.
program a standard error handler code such as this one (see MZ-Tools menu/Options/Error handler):
On Error GoTo {PROCEDURE_NAME}_Error
{PROCEDURE_BODY}
On Error GoTo 0
Exit {PROCEDURE_TYPE}
{PROCEDURE_NAME}_Error:
debug.print "#" & Err.Number, Err.description, "l#" & erl, "{PROCEDURE_NAME}", "{MODULE_NAME}"
This standard error code can be then automatically added to all of your procs and function by clicking on the corresponding button in the MZ-Tools menu. You'll notice that we refer here to a hidden and undocumented function in the VBA standard library, 'Erl', which stands for 'error line'. You got it! If you ask MZ-Tools to automatically number your lines of code, 'Erl' will then give you the number of the line where the error occured. You will have a complete description of the error in your immediate window, such as:
#91, Object variable or With block variable not set, l# 30, addNewField, Utilities
Of course, once you realize the interest of the system, you can think of a more sophisticated error handler, that will not only display the data in the debug window but will also:
display it as a message on the screen
Automatically insert a line in an error log file with the description of the error or
if you are working with Access or if you are connected to a database, automatically add a record to a Tbl_Error table!
meaning that each error generated at the user level can be stored either in a file or a table, somewhere on the machine or the network. Are we talking about building an automated error reporting system working with VBA?
Well there are a couple of tools that will do what you ask MZ Tools and FMS Inc come to mind.
Basically they involve adding an:
On Error GoTo ErrorHandler
to the top of each proc
and at the end they put an:
ErrorHandler:
Call MyErrorhandler Err.Number, Err.Description, Err.LineNumber
label with usually a call to a global error handler where you can display and log custom error messages
You can always roll your own tool like Chip Pearson did. VBA can actually access it's own IDE via the Microsoft Visual Basic for Applications Extensibility 5.3 Library. I've written a few class modules that make it easier to work with myself. They can be found on Code Review SE.
I use it to insert On Error GoTo ErrHandler statements and the appropriate labels and constants related to my error handling schema. I also use it to sync up the constants with the actual procedure names (if the function names should happen to change).
There is no need to buy tools DJ mentioned. Here is my code for free:
Public Sub InsertErrHandling(modName As String)
Dim Component As Object
Dim Name As String
Dim Kind As Long
Dim FirstLine As Long
Dim ProcLinesCount As Long
Dim Declaration As String
Dim ProcedureType As String
Dim Index As Long, i As Long
Dim LastLine As Long
Dim StartLines As Collection, LastLines As Collection, ProcNames As Collection, ProcedureTypes As Collection
Dim gotoErr As Boolean
Kind = 0
Set StartLines = New Collection
Set LastLines = New Collection
Set ProcNames = New Collection
Set ProcedureTypes = New Collection
Set Component = Application.VBE.ActiveVBProject.VBComponents(modName)
With Component.CodeModule
' Remove empty lines on the end of the code
For i = .CountOfLines To 1 Step -1
If Component.CodeModule.Lines(i, 1) = "" Then
Component.CodeModule.DeleteLines i, 1
Else
Exit For
End If
Next i
Index = .CountOfDeclarationLines + 1
Do While Index < .CountOfLines
gotoErr = False
Name = .ProcOfLine(Index, Kind)
FirstLine = .ProcBodyLine(Name, Kind)
ProcLinesCount = .ProcCountLines(Name, Kind)
Declaration = Trim(.Lines(FirstLine, 1))
LastLine = FirstLine + ProcLinesCount - 2
If InStr(1, Declaration, "Function ", vbBinaryCompare) > 0 Then
ProcedureType = "Function"
Else
ProcedureType = "Sub"
End If
Debug.Print Component.Name & "." & Name, "First: " & FirstLine, "Lines:" & ProcLinesCount, "Last: " & LastLine, Declaration
Debug.Print "Declaration: " & Component.CodeModule.Lines(FirstLine, 1), FirstLine
Debug.Print "Closing Proc: " & Component.CodeModule.Lines(LastLine, 1), LastLine
' do not insert error handling if there is one already:
For i = FirstLine To LastLine Step 1
If Component.CodeModule.Lines(i, 1) Like "*On Error*" Then
gotoErr = True
Exit For
End If
Next i
If Not gotoErr Then
StartLines.Add FirstLine
LastLines.Add LastLine
ProcNames.Add Name
ProcedureTypes.Add ProcedureType
End If
Index = FirstLine + ProcLinesCount + 1
Loop
For i = LastLines.Count To 1 Step -1
If Not (Component.CodeModule.Lines(StartLines.Item(i) + 1, 1) Like "*On Error GoTo *") Then
Component.CodeModule.InsertLines LastLines.Item(i), "ExitProc_:"
Component.CodeModule.InsertLines LastLines.Item(i) + 1, " Exit " & ProcedureTypes.Item(i)
Component.CodeModule.InsertLines LastLines.Item(i) + 2, "ErrHandler_:"
Component.CodeModule.InsertLines LastLines.Item(i) + 3, " Call LogError(Err, Me.Name, """ & ProcNames.Item(i) & """)"
Component.CodeModule.InsertLines LastLines.Item(i) + 4, " Resume ExitProc_"
Component.CodeModule.InsertLines LastLines.Item(i) + 5, " Resume ' use for debugging"
Component.CodeModule.InsertLines StartLines.Item(i) + 1, " On Error GoTo ErrHandler_"
End If
Next i
End With
End Sub
Put it in a module and call it from Immediate Window every time you add new function or sub to a form or module like this (Form1 is name of your form):
MyModule.InsertErrHandling "Form_Form1"
It will alter your ode in Form1 from this:
Private Function CloseIt()
DoCmd.Close acForm, Me.Name
End Function
to this:
Private Function CloseIt()
On Error GoTo ErrHandler_
DoCmd.Close acForm, Me.Name
ExitProc_:
Exit Function
ErrHandler_:
Call LogError(Err, Me.Name, "CloseIt")
Resume ExitProc_
Resume ' use for debugging
End Function
Create now in a module a Sub which will display the error dialog and where you can add inserting the error to a text file or database:
Public Sub LogError(ByVal objError As ErrObject, moduleName As String, Optional procName As String = "")
On Error GoTo ErrHandler_
Dim sql As String
MsgBox "Error " & Err.Number & " Module " & moduleName & Switch(procName <> "", " in " & procName) & vbCrLf & " (" & Err.Description & ") ", vbCritical
Exit_:
Exit Sub
ErrHandler_:
MsgBox "Error in LogError procedure " & Err.Number & ", " & Err.Description
Resume Exit_
Resume ' use for debugging
End Sub
This code does not enter error handling if there is already "On Error" statement in a proc.
Love it Vlado!
I realize this is an old post, but I grabbed it and gave it a try, but I ran into a number of issues with it, which I managed to fix. Here's the code with fixes:
First of course, be sure to add the "Microsoft Visual Basic for Applications Extensibility 5.3" library to your project, and add these subroutines / modules to your project as well.
First, the module with the main code was named "modVBAChecks", and contained the following two subroutines:
To go through all modules (behind forms, sheets, the workbook, and classes as well, though not ActiveX Designers):
Sub AddErrorHandlingToAllProcs()
Dim VBProj As VBIDE.VBProject
Dim VBComp As VBIDE.VBComponent
Dim lCtr As Long
StartNewWorksheetLog
Set VBProj = Workbooks("LabViewAnalysisTools.xla").VBProject
For Each VBComp In VBProj.VBComponents
If VBComp.Type <> vbext_ct_ActiveXDesigner Then
If VBComp.Name <> "modVBAChecks" And VBComp.Name <> "modLogToWorksheet" Then
AddToWksLog "============ Looking at Module """ & VBComp.Name & """"
'InsertErrHandling VBComp.Name
AddToWksLog
AddToWksLog
End If
End If
Next
MsgBox "Done!", vbSystemModal
End Sub
Then the modified version of your code (including a suggested change by
Rafał B.):
Public Sub InsertErrHandling(modsProcName As String)
' Modified from code submitted to StackOverflow by user Vlado, originally found
' here: https://stackoverflow.com/questions/357822/automatically-generating-handling-of-issues
Dim vbcmA As VBIDE.CodeModule
Dim ProcKind As VBIDE.vbext_ProcKind
Dim LineProcKind As VBIDE.vbext_ProcKind
Dim sProcName As String
Dim sLineProcName As String
Dim lFirstLine As Long
Dim lProcLinesCount As Long
Dim lLastLine As Long
Dim sDeclaration As String
Dim sProcType As String
Dim lLine As Long, lLine2 As Long
Dim sLine As String
Dim lcStartLines As Collection, lcLastlines As Collection, scProcsProcNames As Collection, scProcTypes As Collection
Dim bAddHandler As Boolean
Dim lLinesAbove As Long
Set lcStartLines = New Collection
Set lcLastlines = New Collection
Set scProcsProcNames = New Collection
Set scProcTypes = New Collection
Set vbcmA = Application.VBE.ActiveVBProject.VBComponents(modsProcName).CodeModule
' Remove empty lines on the end of the module. Cleanup, not error handling.
lLine = vbcmA.CountOfLines
If lLine = 0 Then Exit Sub ' Nothing to do!
Do
If Trim(vbcmA.Lines(lLine, 1)) <> "" Then Exit Do
vbcmA.DeleteLines lLine, 1
lLine = lLine - 1
Loop
lLine = vbcmA.CountOfDeclarationLines + 1
Do While lLine < vbcmA.CountOfLines
bAddHandler = False
' NOTE: ProcKind is RETRUNED from ProcOfLine!
sProcName = vbcmA.ProcOfLine(lLine, ProcKind)
' Fortunately ProcBodyLine ALWAYS returns the first line of the procedure declaration!
lFirstLine = vbcmA.ProcBodyLine(sProcName, ProcKind)
sDeclaration = Trim(vbcmA.Lines(lFirstLine, 1))
Select Case ProcKind
Case VBIDE.vbext_ProcKind.vbext_pk_Proc
If sDeclaration Like "*Function *" Then
sProcType = "Function"
ElseIf sDeclaration Like "*Sub *" Then
sProcType = "Sub"
End If
Case VBIDE.vbext_ProcKind.vbext_pk_Get, VBIDE.vbext_ProcKind.vbext_pk_Let, VBIDE.vbext_ProcKind.vbext_pk_Set
sProcType = "Property"
End Select
' The "lProcLinesCount" function will sometimes return ROWS ABOVE
' the procedure, possibly up until the prior procedure,
' and often rows BELOW the procedure as well!!!
lProcLinesCount = vbcmA.ProcCountLines(sProcName, ProcKind)
lLinesAbove = 0
lLine2 = lFirstLine - 1
If lLine2 > 0 Then
Do
sLineProcName = vbcmA.ProcOfLine(lLine2, LineProcKind)
If Not (sLineProcName = sProcName And LineProcKind = ProcKind) Then Exit Do
lLinesAbove = lLinesAbove + 1
lLine2 = lLine2 - 1
If lLine2 = 0 Then Exit Do
Loop
End If
lLastLine = lFirstLine + lProcLinesCount - lLinesAbove - 1
' Now need to trim off any follower lines!
Do
sLine = Trim(vbcmA.Lines(lLastLine, 1))
If sLine = "End " & sProcType Or sLine Like "End " & sProcType & " '*" Then Exit Do
lLastLine = lLastLine - 1
Loop
AddToWksLog modsProcName & "." & sProcName, "First: " & lFirstLine, "Lines:" & lProcLinesCount, "Last: " & lLastLine
AddToWksLog "sDeclaration: " & vbcmA.Lines(lFirstLine, 1), lFirstLine
AddToWksLog "Closing Proc: " & vbcmA.Lines(lLastLine, 1), lLastLine
If lLastLine - lFirstLine < 8 Then
AddToWksLog " --------------- Too Short to bother!"
Else
bAddHandler = True
' do not insert error handling if there is one already:
For lLine2 = lFirstLine To lLastLine Step 1
If vbcmA.Lines(lLine2, 1) Like "*On Error GoTo *" And Not vbcmA.Lines(lLine2, 1) Like "*On Error GoTo 0" Then
bAddHandler = False
Exit For
End If
Next lLine2
If bAddHandler Then
lcStartLines.Add lFirstLine
lcLastlines.Add lLastLine
scProcsProcNames.Add sProcName
scProcTypes.Add sProcType
End If
End If
AddToWksLog
lLine = lFirstLine + lProcLinesCount + 1
Loop
For lLine = lcLastlines.Count To 1 Step -1
vbcmA.InsertLines lcLastlines.Item(lLine), "ExitProc:"
vbcmA.InsertLines lcLastlines.Item(lLine) + 1, " Exit " & scProcTypes.Item(lLine)
vbcmA.InsertLines lcLastlines.Item(lLine) + 2, "ErrHandler:"
vbcmA.InsertLines lcLastlines.Item(lLine) + 3, " ShowErrorMsg Err, """ & scProcsProcNames.Item(lLine) & """, """ & modsProcName & """"
vbcmA.InsertLines lcLastlines.Item(lLine) + 4, " Resume ExitProc"
' Now replace any "On Error Goto 0" lines with "IF ErrorTrapping Then On Error Goto ErrHandler"
For lLine2 = lcStartLines(lLine) To lcLastlines(lLine)
sLine = vbcmA.Lines(lLine2, 1)
If sLine Like "On Error GoTo 0" Then
vbcmA.ReplaceLine lLine2, Replace(sLine, "On Error Goto 0", "IF ErrorTrapping Then On Error Goto ErrHandler")
End If
Next
lLine2 = lcStartLines.Item(lLine)
Do
sLine = vbcmA.Lines(lLine2, 1)
If Not sLine Like "* _" Then Exit Do
lLine2 = lLine2 + 1
Loop
vbcmA.InsertLines lLine2 + 1, " If ErrorTrapping Then On Error GoTo ErrHandler"
Next lLine
End Sub
And rather than pushing things to the Immediate window I used subroutines in a module I named "modLogToWorksheet", the full module being here:
Option Explicit
Private wksLog As Worksheet
Private lRow As Long
Public Sub StartNewWorksheetLog()
Dim bNewSheet As Boolean
bNewSheet = True
If ActiveSheet.Type = xlWorksheet Then
Set wksLog = ActiveSheet
bNewSheet = Not (wksLog.UsedRange.Cells.Count = 1 And wksLog.Range("A1").Formula = "")
End If
If bNewSheet Then Set wksLog = ActiveWorkbook.Worksheets.Add
lRow = 1
End Sub
Public Sub AddToWksLog(ParamArray sMsg() As Variant)
Dim lCol As Long
If wksLog Is Nothing Or lRow = 0 Then StartNewWorksheetLog
If Not (IsNull(sMsg)) Then
For lCol = 0 To UBound(sMsg)
If sMsg(lCol) <> "" Then wksLog.Cells(lRow, lCol + 1).Value = "'" & sMsg(lCol)
Next
End If
lRow = lRow + 1
End Sub
And finally, here's my Error Dialog generator:
Public Sub ShowErrorMsg(errThis As ErrObject, strSubName As String, strModName As String _
, Optional vbMBStyle As VbMsgBoxStyle = vbCritical, Optional sTitle As String = APP_TITLE)
If errThis.Number <> 0 Then
MsgBox "An Error Has Occurred in the Add-in. Please inform " & ADMINS & " of this problem." _
& vbCrLf & vbCrLf _
& "Error #: " & errThis.Number & vbCrLf _
& "Description: " & " " & errThis.Description & vbCrLf _
& "Subroutine: " & " " & strSubName & vbCrLf _
& "Module: " & " " & strModName & vbCrLf _
& "Source: " & " " & errThis.Source & vbCrLf & vbCrLf _
& "Click OK to continue.", vbMBStyle Or vbSystemModal, sTitle
End If
End Sub
Hope future users find it useful!