<?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>