VBA/pivot.cls

123 lines
2.8 KiB
OpenEdge ABL

VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "pivot"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = True
Option Explicit
Private Sub Worksheet_Activate()
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, ActiveSheet.Range("b8:v100000")) Is Nothing Then
Exit Sub
End If
On Error GoTo nopiv
If Target.Cells.PivotTable Is Nothing Then
Exit Sub
End If
Cancel = True
Dim i As Long
Dim j As Long
Dim k As Long
Dim ri As PivotItemList
Dim ci As PivotItemList
Dim df As Object
Dim rd As Object
Dim cd As Object
Dim dd As Object
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim wapi As New Windows_API
Set ri = Target.Cells.PivotCell.RowItems
Set ci = Target.Cells.PivotCell.ColumnItems
Set df = Target.Cells.PivotCell.DataField
Set rd = Target.Cells.PivotTable.RowFields
Set cd = Target.Cells.PivotTable.ColumnFields
ReDim handler.sc(ri.Count, 1)
Set pt = Target.Cells.PivotCell.PivotTable
handler.sql = ""
handler.jsql = ""
For i = 1 To ri.Count
If i <> 1 Then handler.sql = handler.sql & vbCrLf & "AND "
If i <> 1 Then handler.jsql = handler.jsql & vbCrLf & ","
handler.sql = handler.sql & rd(piv_pos(rd, i)).Name & " = '" & escape_sql(ri(i).Name) & "'"
jsql = jsql & """" & rd(piv_pos(rd, i)).Name & """:""" & escape_json(ri(i).Name) & """"
handler.sc(i - 1, 0) = rd(piv_pos(rd, i)).Name
handler.sc(i - 1, 1) = ri(i).Name
Next i
scenario = "{" & handler.jsql & "}"
Call handler.load_config
Call handler.load_fpvt
nopiv:
End Sub
Function piv_pos(list As Object, target_pos As Long) As Long
Dim i As Long
For i = 1 To list.Count
If list(i).Position = target_pos Then
piv_pos = i
Exit Function
End If
Next i
'should not get to this point
End Function
Function piv_fld_index(field_name As String, ByRef pt As PivotTable) As Integer
Dim i As Integer
For i = 1 To pt.PivotFields.Count
If pt.PivotFields(i).Name = field_name Then
piv_fld_index = i
Exit Function
End If
Next i
End Function
Function escape_json(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", "\""")
If text = "(blank)" Then text = ""
escape_json = text
End Function
Function escape_sql(ByVal text As String) As String
text = Replace(text, "'", "''")
text = Replace(text, """", """""")
If text = "(blank)" Then text = ""
escape_sql = text
End Function