152 lines
4.7 KiB
QBasic
152 lines
4.7 KiB
QBasic
Attribute VB_Name = "ex_Excel"
|
|
'================ Äîïîëíèòåëüíûé ôóíêöèîíàë Excel =============
|
|
' Shared module version: 20220623
|
|
' Tested in:
|
|
' Depends on:
|
|
' Required reference: Scripting
|
|
Option Private Module
|
|
Option Explicit
|
|
|
|
Public Const XLUTIL_GRAPH_PADDING = 0.1
|
|
Public Const XL_DEFAULT_FIRST_ROW = 2
|
|
Public Const XL_INVALID_ROW = -1
|
|
|
|
Private Const XL_INFINITY_THRESHOLD = 255
|
|
|
|
Public Function XLFirstEmptyCell(iRange As Excel.Range) As Long
|
|
Dim nItem&: nItem = 1
|
|
Dim iCell As Excel.Range
|
|
For Each iCell In iRange
|
|
If iCell = vbNullString Then
|
|
XLFirstEmptyCell = nItem
|
|
Exit Function
|
|
End If
|
|
nItem = nItem + 1
|
|
Next iCell
|
|
|
|
XLFirstEmptyCell = -1
|
|
End Function
|
|
|
|
Public Function XLGetCallerCell() As Excel.Range
|
|
On Error GoTo RETURN_NOTHING
|
|
If TypeName(Application.Caller) = "Range" Then
|
|
Set XLGetCallerCell = Application.Caller
|
|
Exit Function
|
|
End If
|
|
|
|
RETURN_NOTHING:
|
|
On Error GoTo 0
|
|
Set XLGetCallerCell = Nothing
|
|
End Function
|
|
|
|
Public Function XLWorksheetExists(sName$, iWhere As Excel.Workbook) As Boolean
|
|
On Error Resume Next
|
|
Dim iSheet As Excel.Worksheet
|
|
Set iSheet = iWhere.Sheets(sName)
|
|
On Error GoTo 0
|
|
XLWorksheetExists = Not iSheet Is Nothing
|
|
End Function
|
|
|
|
Public Function XLShowAllData(target As Excel.Worksheet, Optional bKeepRows As Boolean = False, Optional bKeepColumns As Boolean = False)
|
|
On Error Resume Next
|
|
Call target.ShowAllData
|
|
On Error GoTo 0
|
|
|
|
If Not bKeepRows Then _
|
|
target.Rows.EntireRow.Hidden = False
|
|
If Not bKeepColumns Then _
|
|
target.Columns.EntireColumn.Hidden = False
|
|
End Function
|
|
|
|
Public Function XLUpdateHyperlink(iCellAnchor As Excel.Range, sAddress$, Optional sSubAddress$ = "")
|
|
Call iCellAnchor.Hyperlinks.Delete
|
|
If sAddress = vbNullString Then _
|
|
Exit Function
|
|
Call iCellAnchor.Hyperlinks.Add(iCellAnchor, sAddress, sSubAddress)
|
|
End Function
|
|
|
|
Public Function AutoScaleGraphAxis(target As Excel.Chart, tValueRange As Excel.Range)
|
|
Dim dMinValue As Double: dMinValue = WorksheetFunction.Min(tValueRange)
|
|
Dim dMaxValue As Double: dMaxValue = WorksheetFunction.Max(tValueRange)
|
|
If dMaxValue = dMinValue Then _
|
|
Exit Function
|
|
|
|
Dim dPrecision&: dPrecision = -(CLng(VBA.Log(dMaxValue - dMinValue) / VBA.Log(10#)) - 1)
|
|
|
|
If VBA.Sgn(dMinValue) = VBA.Sgn(dMaxValue) Then
|
|
dMinValue = dMinValue * IIf(dMinValue > 0, 1 - XLUTIL_GRAPH_PADDING, 1 + XLUTIL_GRAPH_PADDING)
|
|
dMaxValue = dMaxValue * IIf(dMaxValue > 0, 1 + XLUTIL_GRAPH_PADDING, 1 - XLUTIL_GRAPH_PADDING)
|
|
dMinValue = WorksheetFunction.Round(dMinValue, dPrecision)
|
|
dMaxValue = WorksheetFunction.Round(dMaxValue, dPrecision)
|
|
|
|
target.Axes(xlValue, xlPrimary).MinimumScale = dMinValue
|
|
target.Axes(xlValue, xlPrimary).MaximumScale = dMaxValue
|
|
End If
|
|
|
|
If dPrecision > 0 Then
|
|
target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0," & VBA.Replace(VBA.Space(dPrecision), " ", "0")
|
|
Else
|
|
target.Axes(xlValue, xlPrimary).TickLabels.NumberFormat = "# ##0"
|
|
End If
|
|
End Function
|
|
|
|
Public Function XLFindOrCreateID(sID$, nIdColumn&, target As Excel.Worksheet, _
|
|
Optional nFirstRow& = XL_DEFAULT_FIRST_ROW) As Long
|
|
' Note: this function is precise but slow. Consider using Range.Find but beware of filtered cells being ignored
|
|
Dim nRow&: nRow = nFirstRow
|
|
Dim sTxt$
|
|
Do
|
|
sTxt = target.Cells(nRow, nIdColumn)
|
|
If sTxt = vbNullString Then _
|
|
Exit Do
|
|
If sTxt = sID Then
|
|
XLFindOrCreateID = nRow
|
|
Exit Function
|
|
End If
|
|
nRow = nRow + 1
|
|
Loop
|
|
target.Cells(nRow, nIdColumn) = sID
|
|
XLFindOrCreateID = nRow
|
|
End Function
|
|
|
|
Public Function XLBruteFindRow(sTarget$, nIdColumn&, wsWhere As Excel.Worksheet, _
|
|
Optional nFirstRow = XL_DEFAULT_FIRST_ROW) As Long
|
|
XLBruteFindRow = XL_INVALID_ROW
|
|
Dim nRow&: nRow = nFirstRow
|
|
Dim sTxt$
|
|
Do
|
|
sTxt = wsWhere.Cells(nRow, nIdColumn)
|
|
If sTxt = vbNullString Then
|
|
Exit Function
|
|
ElseIf sTxt = sTarget Then
|
|
XLBruteFindRow = nRow
|
|
Exit Function
|
|
End If
|
|
nRow = nRow + 1
|
|
Loop
|
|
End Function
|
|
|
|
Public Function FlipColumnsOrder(target As Excel.Worksheet, nStart&, nFinish&)
|
|
Dim nItem&
|
|
For nItem = 0 To nFinish - nStart - 1 Step 1
|
|
Call target.Columns(nStart).Cut
|
|
Call target.Columns(nFinish - nItem + 1).Insert
|
|
Next nItem
|
|
End Function
|
|
|
|
Public Function XLForEachNonEmptyCell(target As Excel.Range, oCallback As Object, sFuncName$)
|
|
Dim aCell As Excel.Range
|
|
Dim blankCount%: blankCount = 0
|
|
For Each aCell In target
|
|
If aCell = vbNullString Then
|
|
blankCount = blankCount + 1
|
|
If blankCount > XL_INFINITY_THRESHOLD Then _
|
|
Exit Function
|
|
Else
|
|
blankCount = 0
|
|
Call CallByName(oCallback, sFuncName, VbMethod, aCell)
|
|
End If
|
|
Next aCell
|
|
End Function
|
|
|