Keskustelu: Koodit: LibreOffice Basic - ScriptForge TableControl muokattavaksi

' Module1
REM  *****  BASIC  *****
REM Lisenssi: DWYFW (tee mitä v***** ikinä haluat)

Private oDlg As Object
Private oTbl As Object
Private oView As Object
Private oMouseListener As Object
Private oFocusListener As Object
Private oKeyListener As Object
Private colors(1 To 1) As Long
Private columns() As Object
Private colRight() As Long
Private columnModel As Object
Private oData() As String
Private basePath As String
Private EditMode As Boolean
Private IsChanged  As Boolean

Sub BuildDialog()

    basePath = Replace(Left(thisComponent.Url, InStrReverse(thisComponent.Url, "/")), "file:///","")
    GlobalScope.BasicLibraries.loadLibrary("ScriptForge")
    oDlg = CreateScriptService("NewDialog", "Dialog1", Array(10, 10, 10, 10))
    oDlg.Width = 200
    oDlg.Height = 150
    oDlg.Caption = "SF_Dialog test with TableControl"
    oDlg.Center

    Dim fso As Object
    Set fso = CreateScriptService("FileSystem")
    If fso.FileExists(basePath & "table.data") Then
        Dim inputFile as Object, allData as String
        Set inputFile = fso.OpenTextFile(basePath & "table.data")
        allData = inputFile.ReadAll()
        oData = SF_String.SplitLines(allData)
        inputFile.CloseFile()
    Else
        ' test data
        oData = Split("To make this,working was,a nightmare" & Chr(10) & _
        "But this,started,working" & Chr(10) & _
        "Because,I put it,working" & Chr(10) & _
        "All UNO,control,objects" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "Seems,to be left,unfinished" & Chr(10) & _
        "This is,especially to,the Dev Team: " & Chr(10) & _
        "To make,coders lives,a little easier" & Chr(10) & _
        "Get rid of,unneccessary,sorting" & Chr(10) & _
        "or make,possible,to disable it", Chr(10))
    End If

    Dim help() As String
    help = Split(oData(0), ",")
    Redim columns(Ubound(help))
    Redim colRight(Ubound(help))
    Erase help : Set fso = Nothing

    oTbl = oDlg.CreateTableControl( _
        "TableControl1", Array(10, 10, 10, 10), _
                                Border := "3D", _
                                RowHeaders := True, _
                                ColumnHeaders := False, _
                                ScrollBars := "B", _
                                GridLines := True): oDlg

    oTbl.Width = 180
    oTbl.Height = 120

    oTbl.setTableData(GetTableData())

    ReDim Preserve colors(1 To oTbl.ListCount + 1)
    For i  = 1 To oTbl.ListCount + 1
        If (i Mod 2) <> 0 Then
            colors(i) = RGB(255,255,255)
        Else
            colors(i) = RGB(240,240,240)
        EndIf
    Next i

    Set oTableCtrl = oDlg.Controls("TableControl1")
    Set oView = oTableCtrl.XControlView
    oView.Model.ShowColumnHeader = True
    oView.Model.TabIndex = 1
    columnModel = oView.Model.ColumnModel
    CreateColumnsAndGetWidths
    oView.Model.TabStop = True
    oView.Model.HeaderBackgroundColor = RGB    (129,129,129)
    oView.Model.VerticalAlign = 2
    oView.Model.SelectionModel = 1
    oView.Model.ActiveSelectionBackgroundColor = RGB(255, 255, 255)
    oView.Model.ActiveSelectionTextColor = RGB(0, 0, 0)
    oView.Model.RowBackgroundColors = colors
    oMouseListener = CreateUnoListener("GridMouse_", "com.sun.star.awt.XMouseListener")
    oView.addMouseListener(oMouseListener)
    oKeyListener = CreateUnoListener("GridKey_", "com.sun.star.awt.XKeyListener")
    oView.addKeyListener(oKeyListener)
    oFocusListener = CreateUnoListener("GridFocus_","com.sun.star.awt.XFocusListener")
    oView.addFocusListener(oFocusListener)

    oDlg.Execute
    If IsChanged Then
        result = MsgBox("Do you wish to save changes", MB_OKCANCEL, "System")
        If result = IDOK Then
            Dim outData As String
            For i = Lbound(oData) To Ubound(oData)
                outData = outData  & oData(i)
                If  i < Ubound(oData) Then outData = outData & Chr(13) & Chr(10)
            Next i
            Set fso = CreateScriptService("FileSystem")
            If fso.FileExists(basePath & "table.data") Then fso.DeleteFile(basePath & "table.data")
                sFile = fso.BuildPath(basePath, "table.data")
                oFile = fso.CreateTextFile(sFile)
                oFile.WriteLine(outData)
                oFile.CloseFile()
                Wait 500
                 If fso.FileExists(basePath & "table.data") Then
                    MsgBox "Saved"
                Else
                    MsgBox "Failed"
                End If
            Set fso = Nothing
        End If
    End If

    oDlg.Terminate()

End Sub

Sub GridMouse_mousePressed(oEvent As Object)

    oDlg.Caption = CStr(oEvent.X) & " " & CStr(oEvent.Y)

    Dim mouseY As Long : mouseY = oEvent.Y
    Dim appW As Long : appW = oDlg.Width
    Dim pxW As Long : pxW = oEvent.Source.getSize().Width
    Dim scaleX As Double : scaleX = appW / pxW
    Dim mouseX As Long : mouseX = CLng(oEvent.X * scaleX)
    If mouseY < 20 And MouseX > 20 Then
        If MouseX < colRight(0) - 2 Then
            MsgBox "Sortting disabled","48","System" : Exit Sub
        Elseif MouseX > colRight(0) + 2  And MouseX < colRight(1) - 2 Then
            MsgBox "Sortting disabled","48","System" : Exit Sub
        Elseif MouseX > colRight(1) + 2  And MouseX < colRight(2) - 2 Then
            MsgBox "Sortting disabled","48","System" : Exit Sub
        End If
    End If

    If oEvent.ClickCount = 2  And mouseX > 20 And mouseX < oEvent.Source.Model.Width + 10 Then
        oDlg.Caption = ""
        Dim inputStr As String
        inputStr = InputBox ("Enter a new string value", "", "")
        If inputStr = "" Then Exit Sub

        Dim Data : Data = oTbl.Value
        oData(oTbl.ListIndex ) = Replace(oData(oTbl.ListIndex), Data(oEvent.Source.CurrentColumn), inputStr)
        EditMode = True : oTbl.setTableData(GetTableData())

        For i = 0 To Ubound(columns)
            columns(i) = columnModel.getColumn(i)
            columns(i).Title = "        Column" & Cstr(i + 1)
        Next i

        oView.Model.ShowColumnHeader = True : EditMode = False
        oView.Model.TabIndex = 1
        oView.Model.TabStop = True
        oView.Model.SelectionModel = 1
        oView.Model.ActiveSelectionBackgroundColor = RGB(255, 255, 255)
        oView.Model.ActiveSelectionTextColor = RGB(0, 0, 0)
        oView.Model.RowBackgroundColors = colors
        IsChanged = True
        oView.setFocus

    End If

End Sub

Sub GridMouse_mouseReleased
    UpdateColumnWidths
End Sub

Sub GridMouse_mouseEntered : End Sub
Sub GridMouse_mouseExited : End Sub
Sub GridMouse_disposing : End Sub

Sub GridKey_KeyPressed(oEvent)

    Select Case oEvent.KeyCode

        Case 1280

            Dim inputStr As String
            inputStr = InputBox ("Enter a new string value", "", "")
            If inputStr = "" Then Exit Sub

            Dim Data : Data = oTbl.Value
            oData(oTbl.ListIndex ) = Replace(oData(oTbl.ListIndex), Data(oEvent.Source.CurrentColumn), inputStr)
            EditMode = True : oTbl.setTableData(GetTableData())

            For i = 0 To Ubound(columns)
                columns(i) = columnModel.getColumn(i)
                columns(i).Title = "        Column" & Cstr(i + 1)
            Next i

            oView.Model.ShowColumnHeader = True : EditMode = False
            oView.Model.TabIndex = 1
            oView.Model.TabStop = True
            oView.Model.SelectionModel = 1
            oView.Model.ActiveSelectionBackgroundColor = RGB(255, 255, 255)
            oView.Model.ActiveSelectionTextColor = RGB(0, 0, 0)
            oView.Model.RowBackgroundColors = colors
            IsChanged = True
            oView.setFocus

        Case Else
    End Select

End Sub

Sub  GridKey_KeyReleased : End Sub
Sub  GridKey_disposing : End Sub

Sub GridFocus_focusGained(oEvent)
    SimulateClick 60,30
End Sub

Sub GridFocus_focusLost : End Sub
Sub GridFocus_disposing : End Sub

Sub SimulateClick(x As Long, y As Long)

    Dim oEvt
    oEvt = CreateUnoStruct("com.sun.star.awt.MouseEvent")

    With oEvt
        .Source = oView
        .X = x
        .Y = y
        .Buttons = 1
        .ClickCount = 1
        .Modifiers = 0
        .PopupTrigger = False
    End With

    GridMouse_mousePressed(oEvt)
    GridMouse_mouseReleased(oEvt)

End Sub

Sub CreateColumnsAndGetWidths

     Dim factor As Long, prevEdge As Long
     factor = 4

    For i = 0 to Ubound(columns)
        columns(i) = columnModel.getColumn(i)
        columns(i).Title = "        Column" & Cstr(i + 1)
        If i = 0 Then
            colRight(i) = CLng(20 + columns(i).ColumnWidth - factor)
            prevEdge = colRight(i) : factor = factor + 2
        Else
            colRight(i) =CLng(prevEdge + columns(i).ColumnWidth + (factor))
            prevEdge = colRight(i)
        End If
    Next i

End Sub

Sub UpdateColumnWidths()

    Dim factor As Long, prevEdge As Long
     factor = 4

    For i = 0 to Ubound(columns)
        If i = 0 Then
            colRight(i) = CLng(20 + columns(i).ColumnWidth - factor)
            prevEdge = colRight(i) : factor = factor + 2
        Else
            colRight(i) =CLng(prevEdge + columns(i).ColumnWidth + (factor))
            prevEdge = colRight(i)
        End If
    Next i

End Sub

Function GetTableData() As Variant

    Dim i As Long, j As Long
    Dim tempData As Variant
    Dim maxCols As Long
    Dim rowCount As Long
    Dim tableData() As Variant
    Dim hlp As String

    If EditMode Then oView.Model.ShowColumnHeader = False

    rowCount = UBound(oData) - LBound(oData) + 1

    For i = LBound(oData) To UBound(oData)
        tempData = Split(oData(i), ",")
        If UBound(tempData) > maxCols Then
            maxCols = UBound(tempData)
        End If
    Next i

    ReDim tableData(rowCount - 1, maxCols + 1)

    For i = 0 To rowCount - 1

        hlp = Right("   " & CStr(i + 1), 3)
        tableData(i, 0) = hlp

        tempData = Split(oData(i), ",")

        For j = 0 To UBound(tempData)
            tableData(i, j + 1) = tempData(j)
        Next j

    Next i

    GetTableData = tableData : Erase tableData

End Function

Function InStrReverse(sText As String, search As String) As Long

    If sText = "" Or search = "" Or Len(search) > Len(sText) Then
        InStrReverse = 0
        Exit Function
    End If

    Dim i As Long

    For i = Len(sText) To 1 Step -1
        If Mid(sText, i, Len(search)) = search Then
            InStrReverse = i : Exit Function
        End If
    Next i

End Function

REM NO WARRANTY 😎