wizards/source/access2base/Module.xba

   1 <?xml version="1.0" encoding="UTF-8"?>
   2 <!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
   3 <script:module xmlns:script="http://openoffice.org/2000/script" script:name="Module" script:language="StarBasic">
   4 REM =======================================================================================================================
   5 REM ===                                 The Access2Base library is a part of the LibreOffice project.                                                                   ===
   6 REM ===                                 Full documentation is available on http://www.access2base.com                                                                   ===
   7 REM =======================================================================================================================
   8
   9 Option Compatible
  10 Option ClassModule
  11
  12 Option Explicit
  13
  14 REM -----------------------------------------------------------------------------------------------------------------------
  15 REM --- CLASS ROOT FIELDS                                                                                                                                                                                       ---
  16 REM -----------------------------------------------------------------------------------------------------------------------
  17
  18 Private _Type                                   As String                               &apos;  Must be MODULE
  19 Private _This                                   As Object                               &apos;  Workaround for absence of This builtin function
  20 Private _Parent                                 As Object
  21 Private _Name                                   As String
  22 Private _Library                                As Object                               &apos;  com.sun.star.container.XNameAccess
  23 Private _LibraryName                    As String
  24 Private _Storage                                As String                               &apos;  GLOBAL or DOCUMENT
  25 Private _Script                                 As String                               &apos;  Full script (string with vbLf&apos;s)
  26 Private _Lines                                  As Variant                              &apos;  Array of script lines
  27 Private _CountOfLines                   As Long
  28 Private _ProcsParsed                    As Boolean                              &apos;  To test before use of proc arrays
  29 Private _ProcNames()                    As Variant                              &apos;  All procedure names
  30 Private _ProcDecPositions()             As Variant                              &apos;  All procedure declarations
  31 Private _ProcEndPositions()             As Variant                              &apos;  All end procedure statements
  32 Private _ProcTypes()                    As Variant                              &apos;  One of the vbext_pk_* constants
  33
  34 REM -----------------------------------------------------------------------------------------------------------------------
  35 REM --- CONSTRUCTORS / DESTRUCTORS                                                                                                                                                                      ---
  36 REM -----------------------------------------------------------------------------------------------------------------------
  37 Private Sub Class_Initialize()
  38         _Type = OBJMODULE
  39         Set _This = Nothing
  40         Set _Parent = Nothing
  41         _Name = &quot;&quot;
  42         Set _Library = Nothing
  43         _LibraryName = &quot;&quot;
  44         _Storage = &quot;&quot;
  45         _Script = &quot;&quot;
  46         _Lines = Array()
  47         _CountOfLines = 0
  48         _ProcsParsed = False
  49         _ProcNames = Array()
  50         _ProcDecPositions = Array()
  51         _ProcEndPositions = Array()
  52 End Sub         &apos;  Constructor
  53
  54 REM -----------------------------------------------------------------------------------------------------------------------
  55 Private Sub Class_Terminate()
  56         On Local Error Resume Next
  57         Call Class_Initialize()
  58 End Sub         &apos;  Destructor
  59
  60 REM -----------------------------------------------------------------------------------------------------------------------
  61 Public Sub Dispose()
  62         Call Class_Terminate()
  63 End Sub         &apos;  Explicit destructor
  64
  65 REM -----------------------------------------------------------------------------------------------------------------------
  66 REM --- CLASS GET/LET/SET PROPERTIES                                                                                                                                                            ---
  67 REM -----------------------------------------------------------------------------------------------------------------------
  68
  69 REM -----------------------------------------------------------------------------------------------------------------------
  70 Property Get CountOfDeclarationLines() As Long
  71         CountOfDeclarationLines = _PropertyGet(&quot;CountOfDeclarationLines&quot;)
  72 End Property            &apos;  CountOfDeclarationLines (get)
  73
  74 REM -----------------------------------------------------------------------------------------------------------------------
  75 Property Get CountOfLines() As Long
  76         CountOfLines = _PropertyGet(&quot;CountOfLines&quot;)
  77 End Property            &apos;  CountOfLines (get)
  78
  79 REM -----------------------------------------------------------------------------------------------------------------------
  80 Property Get Name() As String
  81         Name = _PropertyGet(&quot;Name&quot;)
  82 End Property            &apos;  Name (get)
  83
  84 REM -----------------------------------------------------------------------------------------------------------------------
  85 Property Get ObjectType() As String
  86         ObjectType = _PropertyGet(&quot;ObjectType&quot;)
  87 End Property            &apos;  ObjectType (get)
  88
  89 REM -----------------------------------------------------------------------------------------------------------------------
  90 Public Function Lines(Optional ByVal pvLine As Variant, Optional ByVal pvNumLines As Variant) As String
  91 &apos;  Returns a string containing the contents of a specified line or lines in a standard module or a class module
  92
  93 Const cstThisSub = &quot;Module.Lines&quot;
  94         Utils._SetCalledSub(cstThisSub)
  95
  96 Dim sLines As String, lLine As Long
  97         sLines = &quot;&quot;
  98
  99         If IsMissing(pvLine) Or IsMissing(pvNumLines) Then Call _TraceArguments()
 100         If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
 101         If Not Utils._CheckArgument(pvNumLines, 1, _AddNumeric()) Then GoTo Exit_Function
 102
 103         lLine = pvLine
 104         Do While lLine &lt; _CountOfLines And lLine &lt; pvLine + pvNumLines
 105                 sLines = sLines &amp; _Lines(lLine - 1) &amp; vbLf
 106                 lLine = lLine + 1
 107         Loop
 108         If Len(sLines) &gt; 0 Then sLines = Left(sLines, Len(sLines) - 1)
 109
 110 Exit_Function:
 111         Lines = sLines
 112         Utils._ResetCalledSub(cstThisSub)
 113         Exit Function
 114 End Function    &apos;  Lines
 115
 116 REM -----------------------------------------------------------------------------------------------------------------------
 117 Public Function ProcBodyLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
 118 &apos;  Return the number of the line at which the body of a specified procedure begins
 119
 120 Const cstThisSub = &quot;Module.ProcBodyLine&quot;
 121         Utils._SetCalledSub(cstThisSub)
 122
 123 Dim iIndex As Integer
 124
 125         If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
 126         If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
 127         If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
 128
 129         iIndex = _FindProcIndex(pvProc, pvProcType)
 130         If iIndex &gt;= 0 Then ProcBodyLine = _LineOfPosition(_ProcDecPositions(iIndex)) Else ProcBodyLine = iIndex
 131
 132 Exit_Function:
 133         Utils._ResetCalledSub(cstThisSub)
 134         Exit Function
 135 End Function    &apos;  ProcBodyline
 136
 137 REM -----------------------------------------------------------------------------------------------------------------------
 138 Public Function ProcCountLines(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
 139 &apos;  Return the number of lines in the specified procedure
 140
 141 Const cstThisSub = &quot;Module.ProcCountLines&quot;
 142         Utils._SetCalledSub(cstThisSub)
 143
 144 Dim iIndex As Integer, lStart As Long, lEnd As Long
 145
 146         If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
 147         If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
 148         If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
 149
 150         iIndex = _FindProcIndex(pvProc, pvProcType)
 151         lStart = ProcStartLine(pvProc, pvProcType)
 152         lEnd = _LineOfPosition(_ProcEndPositions(iIndex))
 153         ProcCountLines = lEnd - lStart + 1
 154
 155 Exit_Function:
 156         Utils._ResetCalledSub(cstThisSub)
 157         Exit Function
 158 End Function    &apos;  ProcCountLines
 159
 160 REM -----------------------------------------------------------------------------------------------------------------------
 161 Public Function ProcOfLine(Optional ByVal pvLine As Variant, Optional ByRef pvProcType As Variant) As String
 162 &apos;  Return the name and type of the procedure containing line pvLine
 163
 164 Const cstThisSub = &quot;Module.ProcOfLine&quot;
 165         Utils._SetCalledSub(cstThisSub)
 166
 167 Dim sProcedure As String, iProc As Integer, lLineDec As Long, lLineEnd As Long
 168
 169         If IsMissing(pvLine) Or IsMissing(pvProcType) Then Call _TraceArguments()
 170         If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
 171         If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
 172
 173         If Not _ProcsParsed Then _ParseProcs()
 174
 175         sProcedure = &quot;&quot;
 176         For iProc = 0 To UBound(_ProcNames)
 177                 lLineEnd = _LineOfPosition(_ProcEndPositions(iProc))
 178                 If pvLine &lt;= lLineEnd Then
 179                         lLineDec = _LineOfPosition(_ProcDecPositions(iProc))
 180                         If pvLine &lt; lLineDec Then            &apos;  Line between 2 procedures
 181                                 sProcedure = &quot;&quot;
 182                         Else
 183                                 sProcedure = _ProcNames(iProc)
 184                                 pvProcType = _ProcTypes(iProc)
 185                         End If
 186                         Exit For
 187                 End If
 188         Next iProc
 189
 190 Exit_Function:
 191         ProcOfLine = sProcedure
 192         Utils._ResetCalledSub(cstThisSub)
 193         Exit Function
 194 End Function    &apos;  ProcOfline
 195
 196 REM -----------------------------------------------------------------------------------------------------------------------
 197 Public Function ProcStartLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
 198 &apos;  Return the number of the line at which the specified procedure begins
 199
 200 Const cstThisSub = &quot;Module.ProcStartLine&quot;
 201         Utils._SetCalledSub(cstThisSub)
 202
 203 Dim lLine As Long, lIndex As Long, sLine As String
 204
 205         If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
 206         If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
 207         If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function
 208
 209         lLine = ProcBodyLine(pvProc, pvProcType)
 210         &apos;  Search baclIndexward for comment lines
 211         lIndex = lLine - 1
 212         Do While lIndex &gt; 0
 213                 sLine = _Trim(_Lines(lIndex - 1))
 214                 If UCase(Left(sLine, 4)) = &quot;REM &quot; Or Left(sLine, 1) = &quot;&apos;&quot; Then
 215                         lLine = lIndex
 216                 Else
 217                         Exit Do
 218                 End If
 219                 lIndex = lIndex - 1
 220         Loop
 221
 222         ProcStartLine = lLine
 223
 224 Exit_Function:
 225         Utils._ResetCalledSub(cstThisSub)
 226         Exit Function
 227 End Function    &apos;  ProcStartLine
 228
 229 REM -----------------------------------------------------------------------------------------------------------------------
 230 Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
 231 &apos;  Return
 232 &apos;          a Collection object if pvIndex absent
 233 &apos;          a Property object otherwise
 234
 235 Const cstThisSub = &quot;Module.Properties&quot;
 236         Utils._SetCalledSub(cstThisSub)
 237
 238 Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String
 239
 240         vPropertiesList = _PropertiesList()
 241         sObject = Utils._PCase(_Type)
 242         If IsMissing(pvIndex) Then
 243                 vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
 244         Else
 245                 vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
 246                 vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
 247         End If
 248
 249 Exit_Function:
 250         Set Properties = vProperty
 251         Utils._ResetCalledSub(cstThisSub)
 252         Exit Function
 253 End Function    &apos;  Properties
 254
 255 REM -----------------------------------------------------------------------------------------------------------------------
 256 Property Get pType() As String
 257         pType = _PropertyGet(&quot;Type&quot;)
 258 End Property            &apos;  Type (get)
 259
 260 REM -----------------------------------------------------------------------------------------------------------------------
 261 REM --- CLASS METHODS                                                                                                                                                                                           ---
 262 REM -----------------------------------------------------------------------------------------------------------------------
 263
 264 REM -----------------------------------------------------------------------------------------------------------------------
 265 Public Function Find(Optional ByVal pvTarget As Variant _
 266                                         , Optional ByRef pvStartLine As Variant _
 267                                         , Optional ByRef pvStartColumn As Variant _
 268                                         , Optional ByRef pvEndLine As Variant _
 269                                         , Optional ByRef pvEndColumn As Variant _
 270                                         , Optional ByVal pvWholeWord As Boolean _
 271                                         , Optional ByVal pvMatchCase As Boolean _
 272                                         , Optional ByVal pvPatternSearch As Boolean _
 273                                         ) As Boolean
 274 &apos;  Finds specified text in the module
 275 &apos;  xxLine and xxColumn arguments are mainly to return the position of the found string
 276 &apos;          If they are initialized but nonsense, the function returns False
 277
 278 Const cstThisSub = &quot;Module.Find&quot;
 279         Utils._SetCalledSub(cstThisSub)
 280         If _ErrorHandler() Then On Local Error Goto Error_Function
 281
 282 Dim bFound As Boolean, lPosition As Long, lStartLine As Long, lStartColumn As Long, lStartPosition As Long
 283 Dim lEndLine As Long, lEndColumn As Long, lEndPosition As Long
 284 Dim sMatch As String, vOptions As Variant, sPattern As String
 285 Dim i As Integer, sSpecChar As String
 286
 287 Const cstSpecialCharacters = &quot;\[^$.|?*+()&quot;
 288
 289         bFound = False
 290
 291         If IsMissing(pvTarget) Or IsMissing(pvStartLine) Or IsMissing(pvStartColumn) Or IsMissing(pvEndLine) Or IsMissing(pvEndColumn) Then Call _TraceArguments()
 292         If Not Utils._CheckArgument(pvTarget, 1, vbString) Then GoTo Exit_Function
 293         If Len(pvTarget) = 0 Then GoTo Exit_Function
 294         If Not IsEmpty(pvStartLine) Then
 295                 If Not Utils._CheckArgument(pvStartLine, 2, _AddNumeric()) Then GoTo Exit_Function
 296         End If
 297         If Not IsEmpty(pvStartColumn) Then
 298                 If Not Utils._CheckArgument(pvStartColumn, 3, _AddNumeric()) Then GoTo Exit_Function
 299         End If
 300         If Not IsEmpty(pvEndLine) Then
 301                 If Not Utils._CheckArgument(pvEndLine, 4, _AddNumeric()) Then GoTo Exit_Function
 302         End If
 303         If Not IsEmpty(pvEndColumn) Then
 304                 If Not Utils._CheckArgument(pvEndColumn, 5, _AddNumeric()) Then GoTo Exit_Function
 305         End If
 306         If IsMissing(pvWholeWord) Then pvWholeWord = False
 307         If Not Utils._CheckArgument(pvWholeWord, 6, vbBoolean) Then GoTo Exit_Function
 308         If IsMissing(pvMatchCase) Then pvMatchCase = False
 309         If Not Utils._CheckArgument(pvMatchCase, 7, vbBoolean) Then GoTo Exit_Function
 310         If IsMissing(pvPatternSearch) Then pvPatternSearch = False
 311         If Not Utils._CheckArgument(pvPatternSearch, 8, vbBoolean) Then GoTo Exit_Function
 312
 313         &apos;  Initialize starting values
 314         If IsEmpty(pvStartLine) Then lStartLine = 1 Else lStartLine = pvStartLine
 315         If lStartLine &lt;= 0 Or lStartLine &gt; UBound(_Lines) + 1 Then GoTo Exit_Function
 316         If IsEmpty(pvStartColumn) Then lStartColumn = 1 Else lStartColumn = pvStartColumn
 317         If lStartColumn &lt;= 0 Then GoTo Exit_Function
 318         If lStartColumn &gt; 1 And lStartColumn &gt; Len(_Lines(lStartLine + 1)) Then GoTo Exit_Function
 319         lStartPosition = _PositionOfLine(lStartline) + lStartColumn - 1
 320         If IsEmpty(pvEndLine) Then lEndLine = UBound(_Lines) + 1 Else lEndLine = pvEndLine
 321         If lEndLine &lt; lStartLine Or lEndLine &gt; UBound(_Lines) + 1 Then GoTo Exit_Function
 322         If IsEmpty(pvEndColumn) Then lEndColumn = Len(_Lines(lEndLine - 1)) Else lEndColumn = pvEndColumn
 323         If lEndColumn &lt; 0 Then GoTo Exit_Function
 324         If lEndColumn = 0 Then lEndColumn = 1
 325         If lEndColumn &gt; Len(_Lines(lEndLine - 1)) + 1 Then GoTo Exit_Function
 326         lEndPosition = _PositionOfLine(lEndline) + lEndColumn - 1
 327
 328         If pvMatchCase Then
 329                 Set vOptions = _A2B_.SearchOptions
 330                 vOptions.transliterateFlags = 0
 331         End If
 332
 333         &apos;  Define pattern to search for
 334         sPattern = pvTarget
 335         &apos;  Protect special characters in regular expressions
 336         For i = 1 To Len(cstSpecialCharacters)
 337                 sSpecChar = Mid(cstSpecialCharacters, i, 1)
 338                 sPattern = Replace(sPattern, sSpecChar, &quot;\&quot; &amp; sSpecChar)
 339         Next i
 340         If pvPatternSearch Then sPattern = Replace(Replace(sPattern, &quot;\*&quot;, &quot;.*&quot;), &quot;\?&quot;, &quot;.&quot;)
 341         If pvWholeWord Then sPattern = &quot;\b&quot; &amp; sPattern &amp; &quot;\b&quot;
 342
 343         lPosition = lStartPosition
 344         sMatch = Utils._RegexSearch(_Script, sPattern, lPosition)
 345         &apos;  Re-establish default options for later searches
 346         If pvMatchCase Then vOptions.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE
 347
 348         &apos;  Found within requested bounds ?
 349         If sMatch &lt;&gt; &quot;&quot; And lPosition &gt;= lStartPosition And lPosition &lt;= lEndPosition Then
 350                 pvStartLine = _LineOfPosition(lPosition)
 351                 pvStartColumn = lPosition - _PositionOfLine(pvStartLine) + 1
 352                 pvEndLine = _LineOfPosition(lPosition + Len(sMatch) - 1)
 353                 If pvEndLine &gt; pvStartLine Then
 354                         pvEndColumn = lPosition + Len(sMatch) - 1 - _PositionOfLine(pvEndLine)
 355                 Else
 356                         pvEndColumn = pvStartColumn + Len(sMatch) - 1
 357                 End If
 358                 bFound = True
 359         End If
 360
 361 Exit_Function:
 362         Find = bFound
 363         Utils._ResetCalledSub(cstThisSub)
 364         Exit Function
 365 Error_Function:
 366         TraceError(TRACEABORT, Err, &quot;Module.Find&quot;, Erl)
 367         bFound = False
 368         GoTo Exit_Function
 369 End Function    &apos;  Find
 370
 371 REM -----------------------------------------------------------------------------------------------------------------------
 372 Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
 373 &apos;  Return property value of psProperty property name
 374
 375 Const cstThisSub = &quot;Module.Properties&quot;
 376
 377         Utils._SetCalledSub(cstThisSub)
 378         If IsMissing(pvProperty) Then Call _TraceArguments()
 379         getProperty = _PropertyGet(pvProperty)
 380         Utils._ResetCalledSub(cstThisSub)
 381
 382 End Function            &apos;  getProperty
 383
 384 REM --------------------------------Mid(a._Script, iCtl, 25)---------------------------------------------------------------------------------------
 385 Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
 386 &apos;  Return True if object has a valid property called pvProperty (case-insensitive comparison !)
 387
 388 Const cstThisSub = &quot;Module.hasProperty&quot;
 389
 390         Utils._SetCalledSub(cstThisSub)
 391         If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
 392         Utils._ResetCalledSub(cstThisSub)
 393         Exit Function
 394
 395 End Function    &apos;  hasProperty
 396
 397 REM -----------------------------------------------------------------------------------------------------------------------
 398 REM --- PRIVATE FUNCTIONS                                                                                                                                                                                       ---
 399 REM -----------------------------------------------------------------------------------------------------------------------
 400
 401 REM -----------------------------------------------------------------------------------------------------------------------
 402 Private Function _BeginStatement(ByVal plStart As Long) As Long
 403 &apos;  Return the position in _Script of the beginning of the current statement as defined by plStart
 404
 405 Dim sProc As String, iProc As Integer, iType As Integer
 406 Dim lPosition As Long, lPrevious As Long, sFind As String
 407
 408         sProc = ProcOfLine(_LineOfPosition(plStart), iType)
 409         iProc = _FindProcIndex(sProc, iType)
 410         If iProc &lt; 0 Then lPosition = 1 Else lPosition = _ProcDecPositions(iProc)
 411
 412         sFind = &quot;Any&quot;
 413         Do While lPosition &lt; plStart And sFind &lt;&gt; &quot;&quot;
 414                 lPrevious = lPosition
 415                 sFind = _FindPattern(&quot;%^\w&quot;, lPosition)
 416                 If sFind = &quot;&quot; Then Exit Do
 417         Loop
 418
 419         _BeginStatement = lPrevious
 420
 421 End Function    &apos;  _EndStatement
 422
 423 REM -----------------------------------------------------------------------------------------------------------------------
 424 Private Function _EndStatement(ByVal plStart As Long) As Long
 425 &apos;  Return the position in _Script of the end of the current statement as defined by plStart
 426 &apos;  plStart is assumed not to be in the middle of a comment or a string
 427
 428 Dim sMatch As String, lPosition As Long
 429         lPosition = plStart
 430         sMatch = _FindPattern(&quot;%$&quot;, lPosition)
 431         _EndStatement = lPosition
 432
 433 End Function    &apos;  _EndStatement
 434
 435 REM -----------------------------------------------------------------------------------------------------------------------
 436 Private Function _FindPattern(ByVal psPattern As Variant, Optional ByRef plStart As Long) As String
 437 &apos;  Find first occurrence of any of the patterns in |-delimited string psPattern
 438 &apos;  Special escapes
 439 &apos;                          - for word breaks: &quot;%B&quot; (f.i. for searching &quot;END%BFUNCTION&quot;)
 440 &apos;                          - for statement start: &quot;%^&quot; (f.i. for searching &quot;%^END%BFUNCTION&quot;). Necessarily first 2 characters of pattern
 441 &apos;                          - for statement end: &quot;%$&quot;. Pattern should not contain anything else
 442 &apos;  If quoted string searched, pattern should start and end with a double quote
 443 &apos;  Return &quot;&quot; if none found, otherwise returns the matching string
 444 &apos;  plStart = start position of _Script to search (starts at 1)
 445 &apos;  In output plStart contains the first position of the matching string or is left unchanged
 446 &apos;  To search again the same or another pattern =&gt; plStart = plStart + Len(matching string)
 447 &apos;  Comments and strings are skipped
 448
 449 &apos;  Common patterns
 450 Const cstComment = &quot;(&apos;|\bREM\b)[^\n]*$&quot;
 451 Const cstString = &quot;&quot;&quot;[^&quot;&quot;\n]*&quot;&quot;&quot;
 452 Const cstBeginStatement = &quot;(^|:|\bthen\b|\belse\b|\n)[ \t]*&quot;
 453 Const cstEndStatement = &quot;[ \t]*($|:|\bthen\b|\belse\b|\n)&quot;
 454 Const cstContinuation = &quot;[ \t]_\n&quot;
 455 Const cstWordBreak = &quot;\b[ \t]+(_\n[ \t]*)?\b&quot;
 456 Const cstAlt = &quot;|&quot;
 457
 458 Dim sRegex As String, lStart As Long, bContinue As Boolean, sMatch As String
 459 Dim bEndStatement As Boolean, bQuote As Boolean
 460
 461         If psPattern = &quot;%$&quot; Then
 462                 sRegex = cstEndStatement
 463         Else
 464                 sRegex = psPattern
 465                 If Left(psPattern, 2) = &quot;%^&quot; Then sRegex = cstBeginStatement &amp; Right(sRegex, Len(sregex) - 2)
 466                 sregex = Replace(sregex, &quot;%B&quot;, cstWordBreak)
 467         End If
 468         &apos;  Add all to ignore patterns to regex. If pattern = quoted string do not add cstString
 469         If Len(psPattern) &gt; 2 And Left(psPattern, 1) = &quot;&quot;&quot;&quot; And Right(psPattern, 1) = &quot;&quot;&quot;&quot; Then
 470                 bQuote = True
 471                 sRegex = sRegex &amp; cstAlt &amp; cstComment &amp; cstAlt &amp; cstContinuation
 472         Else
 473                 bQuote = False
 474                 sRegex = sRegex &amp; cstAlt &amp; cstComment &amp; cstAlt &amp; cstString &amp; cstAlt &amp; cstContinuation
 475         End If
 476
 477         If IsMissing(plStart) Then plStart = 1
 478         lStart = plStart
 479
 480         bContinue = True
 481         Do While bContinue
 482                 bEndStatement = False
 483                 sMatch = Utils._RegexSearch(_Script, sRegex, lStart)
 484                 Select Case True
 485                         Case sMatch = &quot;&quot;
 486                                 bContinue = False
 487                         Case Left(sMatch, 1) = &quot;&apos;&quot;
 488                                 bEndStatement = True
 489                         Case Left(sMatch, 1) = &quot;&quot;&quot;&quot;
 490                                 If bQuote Then
 491                                         plStart = lStart
 492                                         bContinue = False
 493                                 End If
 494                         Case Left(smatch, 1) = &quot;:&quot; Or Left(sMatch, 1) = vbLf
 495                                 If psPattern = &quot;%$&quot; Then
 496                                         bEndStatement = True
 497                                 Else
 498                                         bContinue = False
 499                                         plStart = lStart + 1
 500                                         sMatch = Right(sMatch, Len(sMatch) - 1)
 501                                 End If
 502                         Case UCase(Left(sMatch, 4)) = &quot;REM &quot; Or UCase(Left(sMatch, 4)) = &quot;REM&quot; &amp; vbTab Or UCase(Left(sMatch, 4)) = &quot;REM&quot; &amp; vbNewLine
 503                                 bEndStatement = True
 504                         Case UCase(Left(sMatch, 4)) = &quot;THEN&quot; Or UCase(Left(sMatch, 4)) = &quot;ELSE&quot;
 505                                 If psPattern = &quot;%$&quot; Then
 506                                         bEndStatement = True
 507                                 Else
 508                                         bContinue = False
 509                                         plStart = lStart + 4
 510                                         sMatch = Right(sMatch, Len(sMatch) - 4)
 511                                 End If
 512                         Case sMatch = &quot; _&quot; &amp; vbLf
 513                         Case Else               &apos;  Found
 514                                 plStart = lStart
 515                                 bContinue = False
 516                 End Select
 517                 If bEndStatement And psPattern = &quot;%$&quot; Then
 518                         bContinue = False
 519                         plStart = lStart - 1
 520                         sMatch = &quot;&quot;
 521                 End If
 522                 lStart = lStart + Len(sMatch)
 523         Loop
 524
 525         _FindPattern = sMatch
 526
 527 End Function    &apos;  _FindPattern
 528
 529 REM -----------------------------------------------------------------------------------------------------------------------
 530 Private Function _FindProcIndex(ByVal psProc As String, ByVal piType As Integer) As Integer
 531 &apos;  Return index of entry in _Procnames corresponding with pvProc
 532
 533 Dim i As Integer, iIndex As Integer
 534
 535         If Not _ProcsParsed Then _ParseProcs
 536
 537         iIndex = -1
 538         For i = 0 To UBound(_ProcNames)
 539                 If UCase(psProc) = UCase(_ProcNames(i)) And piType = _ProcTypes(i) Then
 540                         iIndex = i
 541                         Exit For
 542                 End If
 543         Next i
 544         If iIndex &lt; 0 Then TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, Utils._CalledSub(), 0, , Array(psProc, _Name))
 545
 546 Exit_Function:
 547         _FindProcIndex = iIndex
 548         Exit Function
 549 End Function    &apos;  _FindProcIndex
 550
 551 REM -----------------------------------------------------------------------------------------------------------------------
 552 Public Sub _Initialize()
 553
 554         _Script = Replace(_Script, vbCr, &quot;&quot;)
 555         _Lines = Split(_Script, vbLf)
 556         _CountOfLines = UBound(_Lines) + 1
 557
 558 End Sub         &apos;  _Initialize
 559
 560 REM -----------------------------------------------------------------------------------------------------------------------
 561 Private Function _LineOfPosition(ByVal plPosition) As Long
 562 &apos;  Return the line number of a position in _Script
 563
 564 Dim lLine As Long, lLength As Long
 565         &apos;  Start counting from start or end depending on how close position is
 566         If plPosition &lt;= Len(_Script) / 2 Then
 567                 lLength = 0
 568                 For lLine = 0 To UBound(_Lines)
 569                         lLength = lLength + Len(_Lines(lLine)) + 1              &apos;  + 1 for line feed
 570                         If lLength &gt;= plPosition Then
 571                                 _LineOfPosition = lLine + 1
 572                                 Exit Function
 573                         End If
 574                 Next lLine
 575         Else
 576                 If Right(_Script, 1) = vbLf Then lLength = Len(_Script) + 1 Else lLength = Len(_Script)
 577                 For lLine = UBound(_Lines) To 0 Step -1
 578                         lLength = lLength - Len(_Lines(lLine)) - 1              &apos;  - 1 for line feed
 579                         If lLength &lt;= plPosition Then
 580                                 _LineOfPosition = lLine + 1
 581                                 Exit Function
 582                         End If
 583                 Next lLine
 584         End If
 585
 586 End Function    &apos;  _LineOfPosition
 587
 588 REM -----------------------------------------------------------------------------------------------------------------------
 589 Private Sub _ParseProcs()
 590 &apos;  Fills the Proc arrays: name, start and end position
 591 &apos;  Executed at first request needing this processing
 592
 593 Dim lPosition As Long, iProc As Integer, sDecProc As String, sEndProc As String, sNameProc As String, sType As String
 594 Const cstDeclaration = &quot;%^(private%B|public%B)?\b(property%Bget|property%Blet|property%Bset|function|sub)\b&quot;
 595 Const cstEnd = &quot;%^end%B(property|function|sub)\b&quot;
 596 Const cstName = &quot;\w*&quot; &apos;&quot;[A-Za-z_][A-Za-z_0-9]*&quot;
 597
 598         If _ProcsParsed Then Exit Sub           &apos;  Do not redo if already done
 599         _ProcNames = Array()
 600         _ProcDecPositions = Array()
 601         _ProcEndPositions = Array()
 602         _ProcTypes = Array()
 603
 604         lPosition = 1
 605         iProc = -1
 606         sDecProc = &quot;???&quot;
 607         Do While sDecProc &lt;&gt; &quot;&quot;
 608                 &apos;  Identify Function/Sub declaration string
 609                 sDecProc = _FindPattern(cstDeclaration, lPosition)
 610                 If sDecProc &lt;&gt; &quot;&quot; Then
 611                         iProc = iProc + 1
 612                         ReDim Preserve _ProcNames(0 To iProc)
 613                         ReDim Preserve _ProcDecPositions(0 To iProc)
 614                         ReDim Preserve _ProcEndPositions(0 To iProc)
 615                         ReDim Preserve _ProcTypes(0 To iProc)
 616                         _ProcDecPositions(iProc) = lPosition
 617                         lPosition = lPosition + Len(sDecProc)
 618                         &apos;  Identify procedure type
 619                         Select Case True
 620                                 Case InStr(UCase(sDecProc), &quot;FUNCTION&quot;) &gt; 0                        :               _ProcTypes(iProc) = vbext_pk_Proc
 621                                 Case InStr(UCase(sDecProc), &quot;SUB&quot;) &gt; 0                             :               _ProcTypes(iProc) = vbext_pk_Proc
 622                                 Case InStr(UCase(sDecProc), &quot;GET&quot;) &gt; 0                             :               _ProcTypes(iProc) = vbext_pk_Get
 623                                 Case InStr(UCase(sDecProc), &quot;LET&quot;) &gt; 0                             :               _ProcTypes(iProc) = vbext_pk_Let
 624                                 Case InStr(UCase(sDecProc), &quot;SET&quot;) &gt; 0                             :               _ProcTypes(iProc) = vbext_pk_Set
 625                         End Select
 626                         &apos;  Identify name of Function/Sub
 627                         sNameProc = _FindPattern(cstName, lPosition)
 628                         If sNameProc = &quot;&quot; Then Exit Do                                        &apos;  Should never happen
 629                         _ProcNames(iProc) = sNameProc
 630                         lPosition = lPosition + Len(sNameProc)
 631                         &apos;  Identify End statement
 632                         sEndProc = _FindPattern(cstEnd, lPosition)
 633                         If sEndProc = &quot;&quot; Then Exit Do                                 &apos;  Should never happen
 634                         _ProcEndPositions(iProc) = lPosition
 635                         lPosition = lPosition + Len(sEndProc)
 636                 End If
 637         Loop
 638
 639         _ProcsParsed = True
 640
 641 End Sub
 642
 643 REM -----------------------------------------------------------------------------------------------------------------------
 644 Private Function _PositionOfLine(ByVal plLine) As Long
 645 &apos;  Return the position of the first character of the given line in _Script
 646
 647 Dim lLine As Long, lPosition As Long
 648         &apos;  Start counting from start or end depending on how close line is
 649         If plLine &lt;= (UBound(_Lines) + 1) / 2 Then
 650                 lPosition = 0
 651                 For lLine = 0 To plLine - 1
 652                         lPosition = lPosition + 1                                                       &apos;  + 1 for line feed
 653                         If lLine &lt; plLine - 1 Then lPosition = lPosition + Len(_Lines(lLine))
 654                 Next lLine
 655         Else
 656                 lPosition = Len(_Script) + 2    &apos;  Anticipate an ending null-string and a line feed
 657                 For lLine = UBound(_Lines) To plLine - 1 Step -1
 658                         lPosition = lPosition - Len(_Lines(lLine)) - 1          &apos;  - 1 for line feed
 659                 Next lLine
 660         End If
 661
 662         _PositionOfLine = lPosition
 663
 664 End Function    &apos;  _LineOfPosition
 665
 666 REM -----------------------------------------------------------------------------------------------------------------------
 667 Private Function _PropertiesList() As Variant
 668
 669          _PropertiesList = Array(&quot;CountOfDeclarationLines&quot;, &quot;CountOfLines&quot;, &quot;Name&quot;, &quot;ObjectType&quot;, &quot;Type&quot;)
 670
 671 End Function    &apos;  _PropertiesList
 672
 673 REM -----------------------------------------------------------------------------------------------------------------------
 674 Private Function _PropertyGet(ByVal psProperty As String) As Variant
 675 &apos;  Return property value of the psProperty property name
 676
 677 Dim cstThisSub As String
 678 Const cstDot = &quot;.&quot;
 679
 680 Dim sText As String
 681
 682         If _ErrorHandler() Then On Local Error Goto Error_Function
 683         cstThisSub = &quot;Module.get&quot; &amp; psProperty
 684         Utils._SetCalledSub(cstThisSub)
 685         _PropertyGet = Null
 686
 687         Select Case UCase(psProperty)
 688                 Case UCase(&quot;CountOfDeclarationLines&quot;)
 689                         If Not _ProcsParsed Then _ParseProcs()
 690                         If UBound(_ProcNames) &gt;= 0 Then
 691                                         _PropertyGet = ProcStartLine(_ProcNames(0), _ProcTypes(0)) - 1
 692                                 Else
 693                                         _PropertyGet = _CountOfLines
 694                                 End If
 695                 Case UCase(&quot;CountOfLines&quot;)
 696                         _PropertyGet = _CountOfLines
 697                 Case UCase(&quot;Name&quot;)
 698                         _PropertyGet = _Storage &amp; cstDot &amp; _LibraryName &amp; cstDot &amp; _Name
 699                 Case UCase(&quot;ObjectType&quot;)
 700                         _PropertyGet = _Type
 701                 Case UCase(&quot;Type&quot;)
 702                         &apos;  Find option statement before any procedure declaration
 703                         sText = _FindPattern(&quot;%^option%Bclassmodule\b|\bfunction\b|\bsub\b|\bproperty\b&quot;)
 704                         If UCase(Left(sText, 6)) = &quot;OPTION&quot; Then _PropertyGet = acClassModule Else _PropertyGet = acStandardModule
 705                 Case Else
 706                         Goto Trace_Error
 707         End Select
 708
 709 Exit_Function:
 710         Utils._ResetCalledSub(cstThisSub)
 711         Exit Function
 712 Trace_Error:
 713         TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
 714         _PropertyGet = Nothing
 715         Goto Exit_Function
 716 Error_Function:
 717         TraceError(TRACEABORT, Err, &quot;Module._PropertyGet&quot;, Erl)
 718         _PropertyGet = Null
 719         GoTo Exit_Function
 720 End Function            &apos;  _PropertyGet
 721
 722 </script:module>