mirror of
https://gitee.com/kekingcn/file-online-preview.git
synced 2026-03-16 14:13:46 +08:00
移除office-plugin, 使用新版jodconverter
This commit is contained in:
陈精华
722
server/windows-office/share/basic/Access2Base/Module.xba
Normal file
722
server/windows-office/share/basic/Access2Base/Module.xba
Normal file
@@ -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>
|
||||
Reference in New Issue
Block a user