15fec4ee1c
To get faster access to parents from controls Top classes (form, dialog and commandbar) should return Parent = Nothing
722 lines
No EOL
30 KiB
XML
722 lines
No EOL
30 KiB
XML
<?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> |