Quelle  Module.xba   Sprache: unbekannt

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="Module" script:language="StarBasic">
REM =======================================================================================================================
REM ===     The Access2Base library is a part of the LibreOffice project.         ===
REM ===     Full documentation is available on http://www.access2base.com         ===
REM =======================================================================================================================

Option Compatible
Option ClassModule

Option Explicit

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS ROOT FIELDS                               ---
REM -----------------------------------------------------------------------------------------------------------------------

Private _Type     As String    ' Must be MODULE
Private _This     As Object    ' Workaround for absence of This builtin function
Private _Parent     As Object
Private _Name     As String
Private _Library    As Object    ' com.sun.star.container.XNameAccess
Private _LibraryName   As String
Private _Storage    As String    ' GLOBAL or DOCUMENT
Private _Script     As String    ' Full script (string with vbLf's)
Private _Lines     As Variant    ' Array of script lines
Private _CountOfLines   As Long
Private _ProcsParsed   As Boolean    ' To test before use of proc arrays
Private _ProcNames()   As Variant    ' All procedure names
Private _ProcDecPositions()  As Variant    ' All procedure declarations
Private _ProcEndPositions()  As Variant    ' All end procedure statements
Private _ProcTypes()   As Variant    ' One of the vbext_pk_* constants

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CONSTRUCTORS / DESTRUCTORS                            ---
REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Initialize()
 _Type = OBJMODULE
 Set _This = Nothing
 Set _Parent = Nothing
 _Name = ""
 Set _Library = Nothing
 _LibraryName = ""
 _Storage = ""
 _Script = ""
 _Lines = Array()
 _CountOfLines = 0
 _ProcsParsed = False
 _ProcNames = Array()
 _ProcDecPositions = Array()
 _ProcEndPositions = Array()
End Sub  ' Constructor

REM -----------------------------------------------------------------------------------------------------------------------
Private Sub Class_Terminate()
 On Local Error Resume Next
 Call Class_Initialize()
End Sub  ' Destructor

REM -----------------------------------------------------------------------------------------------------------------------
Public Sub Dispose()
 Call Class_Terminate()
End Sub  ' Explicit destructor

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS GET/LET/SET PROPERTIES                           ---
REM -----------------------------------------------------------------------------------------------------------------------

REM -----------------------------------------------------------------------------------------------------------------------
Property Get CountOfDeclarationLines() As Long
 CountOfDeclarationLines = _PropertyGet("CountOfDeclarationLines")
End Property  ' CountOfDeclarationLines (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get CountOfLines() As Long
 CountOfLines = _PropertyGet("CountOfLines")
End Property  ' CountOfLines (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get Name() As String
 Name = _PropertyGet("Name")
End Property  ' Name (get)

REM -----------------------------------------------------------------------------------------------------------------------
Property Get ObjectType() As String
 ObjectType = _PropertyGet("ObjectType")
End Property  ' ObjectType (get)

REM -----------------------------------------------------------------------------------------------------------------------
Public Function Lines(Optional ByVal pvLine As Variant, Optional ByVal pvNumLines As Variant) As String
' Returns a string containing the contents of a specified line or lines in a standard module or a class module

Const cstThisSub = "Module.Lines"
 Utils._SetCalledSub(cstThisSub)

Dim sLines As String, lLine As Long
 sLines = ""

 If IsMissing(pvLine) Or IsMissing(pvNumLines) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
 If Not Utils._CheckArgument(pvNumLines, 1, _AddNumeric()) Then GoTo Exit_Function
 
 lLine = pvLine
 Do While lLine < _CountOfLines And lLine < pvLine + pvNumLines
  sLines = sLines & _Lines(lLine - 1) & vbLf
  lLine = lLine + 1
 Loop
 If Len(sLines) > 0 Then sLines = Left(sLines, Len(sLines) - 1)

Exit_Function:
 Lines = sLines
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
End Function ' Lines

REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcBodyLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
' Return the number of the line at which the body of a specified procedure begins

Const cstThisSub = "Module.ProcBodyLine"
 Utils._SetCalledSub(cstThisSub)

Dim iIndex As Integer

 If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
 If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

 iIndex = _FindProcIndex(pvProc, pvProcType)
 If iIndex >= 0 Then ProcBodyLine = _LineOfPosition(_ProcDecPositions(iIndex)) Else ProcBodyLine = iIndex

Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
End Function ' ProcBodyline

REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcCountLines(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
' Return the number of lines in the specified procedure

Const cstThisSub = "Module.ProcCountLines"
 Utils._SetCalledSub(cstThisSub)

Dim iIndex As Integer, lStart As Long, lEnd As Long

 If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
 If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

 iIndex = _FindProcIndex(pvProc, pvProcType)
 lStart = ProcStartLine(pvProc, pvProcType)
 lEnd = _LineOfPosition(_ProcEndPositions(iIndex))
 ProcCountLines = lEnd - lStart + 1
 
Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
End Function ' ProcCountLines

REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcOfLine(Optional ByVal pvLine As Variant, Optional ByRef pvProcType As Variant) As String
' Return the name and type of the procedure containing line pvLine

Const cstThisSub = "Module.ProcOfLine"
 Utils._SetCalledSub(cstThisSub)

Dim sProcedure As String, iProc As Integer, lLineDec As Long, lLineEnd As Long

 If IsMissing(pvLine) Or IsMissing(pvProcType) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvLine, 1, _AddNumeric()) Then GoTo Exit_Function
 If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

 If Not _ProcsParsed Then _ParseProcs()

 sProcedure = ""
 For iProc = 0 To UBound(_ProcNames)
  lLineEnd = _LineOfPosition(_ProcEndPositions(iProc))
  If pvLine <= lLineEnd Then
   lLineDec = _LineOfPosition(_ProcDecPositions(iProc))
   If pvLine < lLineDec Then  ' Line between 2 procedures
    sProcedure = ""
   Else
     sProcedure = _ProcNames(iProc)
    pvProcType = _ProcTypes(iProc)
   End If
   Exit For
  End If
 Next iProc

Exit_Function:
 ProcOfLine = sProcedure
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
End Function ' ProcOfline

REM -----------------------------------------------------------------------------------------------------------------------
Public Function ProcStartLine(Optional ByVal pvProc As Variant, Optional ByVal pvProcType As Variant) As Long
' Return the number of the line at which the specified procedure begins

Const cstThisSub = "Module.ProcStartLine"
 Utils._SetCalledSub(cstThisSub)

Dim lLine As Long, lIndex As Long, sLine As String

 If IsMissing(pvProc) Or IsMissing(pvProcType) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvProc, 1, vbString) Then GoTo Exit_Function
 If Not Utils._CheckArgument(pvProcType, 2, _AddNumeric()) Then GoTo Exit_Function

 lLine = ProcBodyLine(pvProc, pvProcType)
 ' Search baclIndexward for comment lines
 lIndex = lLine - 1
 Do While lIndex > 0
  sLine = _Trim(_Lines(lIndex - 1))
  If UCase(Left(sLine, 4)) = "REM " Or Left(sLine, 1) = "'" Then
   lLine = lIndex
  Else
   Exit Do
  End If
  lIndex = lIndex - 1
 Loop

 ProcStartLine = lLine

Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
End Function ' ProcStartLine

REM -----------------------------------------------------------------------------------------------------------------------
Public Function Properties(ByVal Optional pvIndex As Variant) As Variant
' Return
'  a Collection object if pvIndex absent
'  a Property object otherwise

Const cstThisSub = "Module.Properties"
 Utils._SetCalledSub(cstThisSub)

Dim vProperty As Variant, vPropertiesList() As Variant, sObject As String

 vPropertiesList = _PropertiesList()
 sObject = Utils._PCase(_Type)
 If IsMissing(pvIndex) Then
  vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList)
 Else
  vProperty = PropertiesGet._Properties(sObject, _This, vPropertiesList, pvIndex)
  vProperty._Value = _PropertyGet(vPropertiesList(pvIndex))
 End If
 
Exit_Function:
 Set Properties = vProperty
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
End Function ' Properties

REM -----------------------------------------------------------------------------------------------------------------------
Property Get pType() As String
 pType = _PropertyGet("Type")
End Property  ' Type (get)

REM -----------------------------------------------------------------------------------------------------------------------
REM --- CLASS METHODS                                ---
REM -----------------------------------------------------------------------------------------------------------------------

REM -----------------------------------------------------------------------------------------------------------------------
Public Function Find(Optional ByVal pvTarget As Variant _
     , Optional ByRef pvStartLine As Variant _
     , Optional ByRef pvStartColumn As Variant _
     , Optional ByRef pvEndLine As Variant _
     , Optional ByRef pvEndColumn As Variant _
     , Optional ByVal pvWholeWord As Boolean _
     , Optional ByVal pvMatchCase As Boolean _
     , Optional ByVal pvPatternSearch As Boolean _
     ) As Boolean
' Finds specified text in the module
' xxLine and xxColumn arguments are mainly to return the position of the found string
'  If they are initialized but nonsense, the function returns False

Const cstThisSub = "Module.Find"
 Utils._SetCalledSub(cstThisSub)
 If _ErrorHandler() Then On Local Error Goto Error_Function

Dim bFound As Boolean, lPosition As Long, lStartLine As Long, lStartColumn As Long, lStartPosition As Long
Dim lEndLine As Long, lEndColumn As Long, lEndPosition As Long
Dim sMatch As String, vOptions As Variant, sPattern As String
Dim i As Integer, sSpecChar As String

Const cstSpecialCharacters = "\[^$.|?*+()"

 bFound = False

 If IsMissing(pvTarget) Or IsMissing(pvStartLine) Or IsMissing(pvStartColumn) Or IsMissing(pvEndLine) Or IsMissing(pvEndColumn) Then Call _TraceArguments()
 If Not Utils._CheckArgument(pvTarget, 1, vbString) Then GoTo Exit_Function
 If Len(pvTarget) = 0 Then GoTo Exit_Function
 If Not IsEmpty(pvStartLine) Then
  If Not Utils._CheckArgument(pvStartLine, 2, _AddNumeric()) Then GoTo Exit_Function
 End If
 If Not IsEmpty(pvStartColumn) Then
  If Not Utils._CheckArgument(pvStartColumn, 3, _AddNumeric()) Then GoTo Exit_Function
 End If
 If Not IsEmpty(pvEndLine) Then
  If Not Utils._CheckArgument(pvEndLine, 4, _AddNumeric()) Then GoTo Exit_Function
 End If
 If Not IsEmpty(pvEndColumn) Then
  If Not Utils._CheckArgument(pvEndColumn, 5, _AddNumeric()) Then GoTo Exit_Function
 End If
 If IsMissing(pvWholeWord) Then pvWholeWord = False
 If Not Utils._CheckArgument(pvWholeWord, 6, vbBoolean) Then GoTo Exit_Function
 If IsMissing(pvMatchCase) Then pvMatchCase = False
 If Not Utils._CheckArgument(pvMatchCase, 7, vbBoolean) Then GoTo Exit_Function
 If IsMissing(pvPatternSearch) Then pvPatternSearch = False
 If Not Utils._CheckArgument(pvPatternSearch, 8, vbBoolean) Then GoTo Exit_Function

 ' Initialize starting values
 If IsEmpty(pvStartLine) Then lStartLine = 1 Else lStartLine = pvStartLine
 If lStartLine <= 0 Or lStartLine > UBound(_Lines) + 1 Then GoTo Exit_Function
 If IsEmpty(pvStartColumn) Then lStartColumn = 1 Else lStartColumn = pvStartColumn
 If lStartColumn <= 0 Then GoTo Exit_Function
 If lStartColumn > 1 And lStartColumn > Len(_Lines(lStartLine + 1)) Then GoTo Exit_Function
 lStartPosition = _PositionOfLine(lStartline) + lStartColumn - 1
 If IsEmpty(pvEndLine) Then lEndLine = UBound(_Lines) + 1 Else lEndLine = pvEndLine
 If lEndLine < lStartLine Or lEndLine > UBound(_Lines) + 1 Then GoTo Exit_Function
 If IsEmpty(pvEndColumn) Then lEndColumn = Len(_Lines(lEndLine - 1)) Else lEndColumn = pvEndColumn
 If lEndColumn < 0 Then GoTo Exit_Function
 If lEndColumn = 0 Then lEndColumn = 1
 If lEndColumn > Len(_Lines(lEndLine - 1)) + 1 Then GoTo Exit_Function
 lEndPosition = _PositionOfLine(lEndline) + lEndColumn - 1

 If pvMatchCase Then
  Set vOptions = _A2B_.SearchOptions
  vOptions.transliterateFlags = 0
 End If

 ' Define pattern to search for
 sPattern = pvTarget
 ' Protect special characters in regular expressions
 For i = 1 To Len(cstSpecialCharacters)
  sSpecChar = Mid(cstSpecialCharacters, i, 1)
  sPattern = Replace(sPattern, sSpecChar, "\" & sSpecChar)
 Next i
 If pvPatternSearch Then sPattern = Replace(Replace(sPattern, "\*", ".*"), "\?", ".")
 If pvWholeWord Then sPattern = "\b" & sPattern & "\b"

 lPosition = lStartPosition
 sMatch = Utils._RegexSearch(_Script, sPattern, lPosition)
 ' Re-establish default options for later searches
 If pvMatchCase Then vOptions.transliterateFlags = com.sun.star.i18n.TransliterationModules.IGNORE_CASE

 ' Found within requested bounds ?
 If sMatch <> "" And lPosition >= lStartPosition And lPosition <= lEndPosition Then
  pvStartLine = _LineOfPosition(lPosition)
  pvStartColumn = lPosition - _PositionOfLine(pvStartLine) + 1
  pvEndLine = _LineOfPosition(lPosition + Len(sMatch) - 1)
  If pvEndLine > pvStartLine Then
   pvEndColumn = lPosition + Len(sMatch) - 1 - _PositionOfLine(pvEndLine)
  Else
   pvEndColumn = pvStartColumn + Len(sMatch) - 1
  End If
  bFound = True
 End If

Exit_Function:
 Find = bFound
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Error_Function:
 TraceError(TRACEABORT, Err, "Module.Find", Erl)
 bFound = False
 GoTo Exit_Function
End Function ' Find

REM -----------------------------------------------------------------------------------------------------------------------
Public Function getProperty(Optional ByVal pvProperty As Variant) As Variant
' Return property value of psProperty property name

Const cstThisSub = "Module.Properties"

 Utils._SetCalledSub(cstThisSub)
 If IsMissing(pvProperty) Then Call _TraceArguments()
 getProperty = _PropertyGet(pvProperty)
 Utils._ResetCalledSub(cstThisSub)
 
End Function  ' getProperty

REM --------------------------------Mid(a._Script, iCtl, 25)---------------------------------------------------------------------------------------
Public Function hasProperty(ByVal Optional pvProperty As Variant) As Boolean
' Return True if object has a valid property called pvProperty (case-insensitive comparison !)

Const cstThisSub = "Module.hasProperty"

 Utils._SetCalledSub(cstThisSub)
 If IsMissing(pvProperty) Then hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList()) Else hasProperty = PropertiesGet._hasProperty(_Type, _PropertiesList(), pvProperty)
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
 
End Function ' hasProperty

REM -----------------------------------------------------------------------------------------------------------------------
REM --- PRIVATE FUNCTIONS                               ---
REM -----------------------------------------------------------------------------------------------------------------------

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _BeginStatement(ByVal plStart As Long) As Long
' Return the position in _Script of the beginning of the current statement as defined by plStart

Dim sProc As String, iProc As Integer, iType As Integer
Dim lPosition As Long, lPrevious As Long, sFind As String

 sProc = ProcOfLine(_LineOfPosition(plStart), iType)
 iProc = _FindProcIndex(sProc, iType)
 If iProc < 0 Then lPosition = 1 Else lPosition = _ProcDecPositions(iProc)

 sFind = "Any"
 Do While lPosition < plStart And sFind <> ""
  lPrevious = lPosition
  sFind = _FindPattern("%^\w", lPosition)
  If sFind = "" Then Exit Do
 Loop

 _BeginStatement = lPrevious

End Function ' _EndStatement

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _EndStatement(ByVal plStart As Long) As Long
' Return the position in _Script of the end of the current statement as defined by plStart
' plStart is assumed not to be in the middle of a comment or a string

Dim sMatch As String, lPosition As Long
 lPosition = plStart
 sMatch = _FindPattern("%$", lPosition)
 _EndStatement = lPosition

End Function ' _EndStatement

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _FindPattern(ByVal psPattern As Variant, Optional ByRef plStart As Long) As String
' Find first occurrence of any of the patterns in |-delimited string psPattern
' Special escapes
'    - for word breaks: "%B" (f.i. for searching "END%BFUNCTION")
'    - for statement start: "%^" (f.i. for searching "%^END%BFUNCTION"). Necessarily first 2 characters of pattern
'    - for statement end: "%$". Pattern should not contain anything else
' If quoted string searched, pattern should start and end with a double quote
' Return "" if none found, otherwise returns the matching string
' plStart = start position of _Script to search (starts at 1)
' In output plStart contains the first position of the matching string or is left unchanged
' To search again the same or another pattern => plStart = plStart + Len(matching string)
' Comments and strings are skipped

' Common patterns
Const cstComment = "('|\bREM\b)[^\n]*$"
Const cstString = """[^""\n]*"""
Const cstBeginStatement = "(^|:|\bthen\b|\belse\b|\n)[ \t]*"
Const cstEndStatement = "[ \t]*($|:|\bthen\b|\belse\b|\n)"
Const cstContinuation = "[ \t]_\n"
Const cstWordBreak = "\b[ \t]+(_\n[ \t]*)?\b"
Const cstAlt = "|"

Dim sRegex As String, lStart As Long, bContinue As Boolean, sMatch As String
Dim bEndStatement As Boolean, bQuote As Boolean

 If psPattern = "%$" Then
  sRegex = cstEndStatement
 Else
  sRegex = psPattern
  If Left(psPattern, 2) = "%^" Then sRegex = cstBeginStatement & Right(sRegex, Len(sregex) - 2)
  sregex = Replace(sregex, "%B", cstWordBreak)
 End If
 ' Add all to ignore patterns to regex. If pattern = quoted string do not add cstString
 If Len(psPattern) > 2 And Left(psPattern, 1) = """" And Right(psPattern, 1) = """" Then
  bQuote = True
  sRegex = sRegex & cstAlt & cstComment & cstAlt & cstContinuation
 Else
  bQuote = False
  sRegex = sRegex & cstAlt & cstComment & cstAlt & cstString & cstAlt & cstContinuation
 End If

 If IsMissing(plStart) Then plStart = 1
 lStart = plStart

 bContinue = True
 Do While bContinue
  bEndStatement = False
  sMatch = Utils._RegexSearch(_Script, sRegex, lStart)
  Select Case True
   Case sMatch = ""
    bContinue = False
   Case Left(sMatch, 1) = "'"
    bEndStatement = True
   Case Left(sMatch, 1) = """"
    If bQuote Then
     plStart = lStart
     bContinue = False
    End If
   Case Left(smatch, 1) = ":" Or Left(sMatch, 1) = vbLf
    If psPattern = "%$" Then
     bEndStatement = True
    Else
     bContinue = False
     plStart = lStart + 1
     sMatch = Right(sMatch, Len(sMatch) - 1)
    End If
   Case UCase(Left(sMatch, 4)) = "REM " Or UCase(Left(sMatch, 4)) = "REM" & vbTab Or UCase(Left(sMatch, 4)) = "REM" & vbNewLine
    bEndStatement = True
   Case UCase(Left(sMatch, 4)) = "THEN" Or UCase(Left(sMatch, 4)) = "ELSE"
    If psPattern = "%$" Then
     bEndStatement = True
    Else
     bContinue = False
     plStart = lStart + 4
     sMatch = Right(sMatch, Len(sMatch) - 4)
    End If
   Case sMatch = " _" & vbLf
   Case Else  ' Found
    plStart = lStart
    bContinue = False
  End Select
  If bEndStatement And psPattern = "%$" Then
   bContinue = False
   plStart = lStart - 1
   sMatch = ""
  End If
  lStart = lStart + Len(sMatch)
 Loop
 
 _FindPattern = sMatch

End Function ' _FindPattern

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _FindProcIndex(ByVal psProc As String, ByVal piType As Integer) As Integer
' Return index of entry in _Procnames corresponding with pvProc

Dim i As Integer, iIndex As Integer

 If Not _ProcsParsed Then _ParseProcs

 iIndex = -1
 For i = 0 To UBound(_ProcNames)
  If UCase(psProc) = UCase(_ProcNames(i)) And piType = _ProcTypes(i) Then
   iIndex = i
   Exit For
  End If
 Next i
 If iIndex < 0 Then TraceError(TRACEFATAL, ERRPROCEDURENOTFOUND, Utils._CalledSub(), 0, , Array(psProc, _Name))

Exit_Function:
 _FindProcIndex = iIndex
 Exit Function
End Function ' _FindProcIndex

REM -----------------------------------------------------------------------------------------------------------------------
Public Sub _Initialize()

 _Script = Replace(_Script, vbCr, "")
 _Lines = Split(_Script, vbLf)
 _CountOfLines = UBound(_Lines) + 1

End Sub  ' _Initialize

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _LineOfPosition(ByVal plPosition) As Long
' Return the line number of a position in _Script

Dim lLine As Long, lLength As Long
 ' Start counting from start or end depending on how close position is
 If plPosition <= Len(_Script) / 2 Then
  lLength = 0
  For lLine = 0 To UBound(_Lines)
   lLength = lLength + Len(_Lines(lLine)) + 1  ' + 1 for line feed
   If lLength >= plPosition Then
    _LineOfPosition = lLine + 1
    Exit Function
   End If
  Next lLine
 Else
  If Right(_Script, 1) = vbLf Then lLength = Len(_Script) + 1 Else lLength = Len(_Script)
  For lLine = UBound(_Lines) To 0 Step -1
   lLength = lLength - Len(_Lines(lLine)) - 1  ' - 1 for line feed
   If lLength <= plPosition Then
    _LineOfPosition = lLine + 1
    Exit Function
   End If
  Next lLine
 End If

End Function ' _LineOfPosition

REM -----------------------------------------------------------------------------------------------------------------------
Private Sub _ParseProcs()
' Fills the Proc arrays: name, start and end position
' Executed at first request needing this processing

Dim lPosition As Long, iProc As Integer, sDecProc As String, sEndProc As String, sNameProc As String, sType As String
Const cstDeclaration = "%^(private%B|public%B)?\b(property%Bget|property%Blet|property%Bset|function|sub)\b"
Const cstEnd = "%^end%B(property|function|sub)\b"
Const cstName = "\w*" '"[A-Za-z_][A-Za-z_0-9]*"

 If _ProcsParsed Then Exit Sub  ' Do not redo if already done
 _ProcNames = Array()
 _ProcDecPositions = Array()
 _ProcEndPositions = Array()
 _ProcTypes = Array()
 
 lPosition = 1
 iProc = -1
 sDecProc = "???"
 Do While sDecProc <> ""
  ' Identify Function/Sub declaration string
  sDecProc = _FindPattern(cstDeclaration, lPosition)
  If sDecProc <> "" Then
   iProc = iProc + 1
   ReDim Preserve _ProcNames(0 To iProc)
   ReDim Preserve _ProcDecPositions(0 To iProc)
   ReDim Preserve _ProcEndPositions(0 To iProc)
   ReDim Preserve _ProcTypes(0 To iProc)
   _ProcDecPositions(iProc) = lPosition
   lPosition = lPosition + Len(sDecProc)
   ' Identify procedure type
   Select Case True
    Case InStr(UCase(sDecProc), "FUNCTION") > 0   :  _ProcTypes(iProc) = vbext_pk_Proc
    Case InStr(UCase(sDecProc), "SUB") > 0    :  _ProcTypes(iProc) = vbext_pk_Proc
    Case InStr(UCase(sDecProc), "GET") > 0    :  _ProcTypes(iProc) = vbext_pk_Get
    Case InStr(UCase(sDecProc), "LET") > 0    :  _ProcTypes(iProc) = vbext_pk_Let
    Case InStr(UCase(sDecProc), "SET") > 0    :  _ProcTypes(iProc) = vbext_pk_Set
   End Select
   ' Identify name of Function/Sub
   sNameProc = _FindPattern(cstName, lPosition)
   If sNameProc = "" Then Exit Do     ' Should never happen
   _ProcNames(iProc) = sNameProc
   lPosition = lPosition + Len(sNameProc)
   ' Identify End statement
   sEndProc = _FindPattern(cstEnd, lPosition)
   If sEndProc = "" Then Exit Do     ' Should never happen
   _ProcEndPositions(iProc) = lPosition
   lPosition = lPosition + Len(sEndProc)
  End If
 Loop
 
 _ProcsParsed = True
 
End Sub

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PositionOfLine(ByVal plLine) As Long
' Return the position of the first character of the given line in _Script

Dim lLine As Long, lPosition As Long
 ' Start counting from start or end depending on how close line is
 If plLine <= (UBound(_Lines) + 1) / 2 Then
  lPosition = 0
  For lLine = 0 To plLine - 1
   lPosition = lPosition + 1       ' + 1 for line feed
   If lLine < plLine - 1 Then lPosition = lPosition + Len(_Lines(lLine))
  Next lLine
 Else
  lPosition = Len(_Script) + 2 ' Anticipate an ending null-string and a line feed
  For lLine = UBound(_Lines) To plLine - 1 Step -1
   lPosition = lPosition - Len(_Lines(lLine)) - 1  ' - 1 for line feed
  Next lLine
 End If

 _PositionOfLine = lPosition

End Function ' _LineOfPosition

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertiesList() As Variant

  _PropertiesList = Array("CountOfDeclarationLines", "CountOfLines", "Name", "ObjectType", "Type")

End Function ' _PropertiesList

REM -----------------------------------------------------------------------------------------------------------------------
Private Function _PropertyGet(ByVal psProperty As String) As Variant
' Return property value of the psProperty property name

Dim cstThisSub As String
Const cstDot = "."

Dim sText As String

 If _ErrorHandler() Then On Local Error Goto Error_Function
 cstThisSub = "Module.get" & psProperty
 Utils._SetCalledSub(cstThisSub)
 _PropertyGet = Null
 
 Select Case UCase(psProperty)
  Case UCase("CountOfDeclarationLines")
   If Not _ProcsParsed Then _ParseProcs()
   If UBound(_ProcNames) >= 0 Then
     _PropertyGet = ProcStartLine(_ProcNames(0), _ProcTypes(0)) - 1
    Else
     _PropertyGet = _CountOfLines
    End If
  Case UCase("CountOfLines")
   _PropertyGet = _CountOfLines
  Case UCase("Name")
   _PropertyGet = _Storage & cstDot & _LibraryName & cstDot & _Name
  Case UCase("ObjectType")
   _PropertyGet = _Type
  Case UCase("Type")
   ' Find option statement before any procedure declaration
   sText = _FindPattern("%^option%Bclassmodule\b|\bfunction\b|\bsub\b|\bproperty\b")
   If UCase(Left(sText, 6)) = "OPTION" Then _PropertyGet = acClassModule Else _PropertyGet = acStandardModule
  Case Else
   Goto Trace_Error
 End Select
 
Exit_Function:
 Utils._ResetCalledSub(cstThisSub)
 Exit Function
Trace_Error:
 TraceError(TRACEFATAL, ERRPROPERTY, Utils._CalledSub(), 0, 1, psProperty)
 _PropertyGet = Nothing
 Goto Exit_Function
Error_Function:
 TraceError(TRACEABORT, Err, "Module._PropertyGet", Erl)
 _PropertyGet = Null
 GoTo Exit_Function
End Function  ' _PropertyGet

</script:module>