diff options
| author | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-27 16:51:28 +0000 |
|---|---|---|
| committer | Daniel Baumann <daniel.baumann@progress-linux.org> | 2024-04-27 16:51:28 +0000 |
| commit | 940b4d1848e8c70ab7642901a68594e8016caffc (patch) | |
| tree | eb72f344ee6c3d9b80a7ecc079ea79e9fba8676d /wizards/source/access2base/Module.xba | |
| parent | Initial commit. (diff) | |
| download | libreoffice-940b4d1848e8c70ab7642901a68594e8016caffc.tar.xz libreoffice-940b4d1848e8c70ab7642901a68594e8016caffc.zip | |
Adding upstream version 1:7.0.4.upstream/1%7.0.4upstream
Signed-off-by: Daniel Baumann <daniel.baumann@progress-linux.org>
Diffstat (limited to '')
| -rw-r--r-- | wizards/source/access2base/Module.xba | 722 |
1 files changed, 722 insertions, 0 deletions
diff --git a/wizards/source/access2base/Module.xba b/wizards/source/access2base/Module.xba new file mode 100644 index 000000000..d3095d645 --- /dev/null +++ b/wizards/source/access2base/Module.xba @@ -0,0 +1,722 @@ +<?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>
\ No newline at end of file |