com!online 2001 December/COMCD1201.iso/openoffice/f_0020/DlgTools.xba

Extensible Markup Language | 2001-06-15 | 15.2 KB | 507 lines

<?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="DlgTools" script:language="StarBasic">
Option Explicit

Global const INC_TABLES        as integer = 1
Global const INC_QUERIES    as integer = 2
Global const INC_FORMS        as integer = 4
Global const INC_REPORTS    as integer = 8


' -----------------------------------------------------------------------------
Sub InitDlgTools()
        ' You should call this after your BasicLibraries.LoadLibrary("Tools"). If the lib is loaded for the
    ' first time (after starting the application), LoadLibrary doesn't ensure the
    ' accessibility of the globals declared herein, but a call to any of the methods in
    ' this module does. So you should make this dummy call.
    ' (It's a bug in LoadLibrary, isn't it ?)
End Sub

' -----------------------------------------------------------------------------
Function isVersionColumn(_aFields as Object, _sField as String) as Boolean
    On Local Error goto _return_false_
    isVersionColumn = _aFields.getByName(_sField).IsVersioning
    Exit Function
_return_false_:
    isVersionColumn = false
End Function

' -----------------------------------------------------------------------------

' -----------------------------------------------------------------------------
Function UNOQuoteTableName(sQualifiedName as String, aConn as Object) As String

    Dim aMetaData as Object
    Dim sSeparator as String
    Dim sQuoteChar as String
    Dim nSeparatorPos as Integer

    aMetaData = aConn.getMetaData()
    sQuoteChar = aMetaData.getInfo(26)    ' 26 = quote character
    sSeparator = aMetaData.getInfo(28)    ' 28 = qualifier separator

    Dim sQuotedName As String

    Dim nCatalogUsage as Integer
    Dim nSchemaUsage as Integer
    nCatalogUsage = aMetaData.getInfo(12)    ' 12 = position flags for catalog usage
    nSchemaUsage = aMetaData.getInfo(11)    ' 11 = position flags for schema usage

    If (nCatalogUsage and 1) <> 0 Then    ' 1 = use catalog names in DML
        nSeparatorPos = InStr(sQualifiedName, sSeparator)
        If nSeparatorPos > 0 Then
            Dim sDBName as String
            sDBName = Mid(sQualifiedName, 1, nSeparatorPos - 1)
            sQuotedName = sQuotedName & sQuoteChar & sDBName & sQuoteChar
            sQuotedName = sQuotedName & sSeparator
            sQualifiedName = Mid(sQualifiedName, nSeparatorPos + 1, Len(sQualifiedName) - nSeparatorPos)
        End If
    End If

    If (nSchemaUsage And 1) <> 0 Then    ' 1 = use schema names in DML
        nSeparatorPos = InStr(sQualifiedName, ".")
        If (nSeparatorPos > 0) And (InStr(Mid(sQualifiedName, nSeparatorPos + 1), ".") = 0) Then
            ' there is exactly one "." in sQualifiedName -> it is the separator between the schema and the object name
            sQuotedName = sQuotedName & sQuoteChar & Mid(sQualifiedName, 1, nSeparatorPos - 1) & sQuoteChar
            sQuotedName = sQuotedName & "."
            sQuotedName = sQuotedName & sQuoteChar & Mid(sQualifiedName, nSeparatorPos + 1, Len(sQualifiedName) - nSeparatorPos) & sQuoteChar
        Else
            sQuotedName = sQuotedName & sQuoteChar & sQualifiedName & sQuoteChar
        End If

    Else
        sQuotedName = sQuotedName & sQuoteChar & sQualifiedName & sQuoteChar
    End If

    UNOQuoteTableName = sQuotedName
End Function

' -----------------------------------------------------------------------------
Function getNames(aNameAccess as Object, aNames as Strings) as String
    Dim i%
    Dim aIterator as Object
    Dim aNameSequence()
    aNameSequence = aNameAccess.getElementNames()
    For i%=lbound(aNameSequence) To ubound(aNameSequence)
        aNames.Add(aNameSequence(i%))
    Next i%

'    while aIterator.hasMoreElements()
'        aNames.Add(aIterator.nextElement().Name)
'    Wend
End Function

' -----------------------------------------------------------------------------
Function UNO_GetAllInstalledNamesInDatabase(aDatabase as Object, aNames as Strings, nIncludeFlags as Integer) as Strings
    Application.EnterWait()
    Wait(0)

    aNames.Clear()
'    On Local Error Goto OuttaHere
    If (nIncludeFlags And INC_TABLES) <> 0 Then
        getNames(aDatabase.getTables(), aNames)
    End If
    If (nIncludeFlags And INC_QUERIES) <> 0 Then
        getNames(aDatabase.getQueries(), aNames)
    End If
    If (nIncludeFlags And INC_FORMS) <> 0 Then
        getNames(aDatabase.getForms(), aNames)
    End If
    If (nIncludeFlags And INC_REPORTS) <> 0 Then
        getNames(aDatabase.getReports(), aNames)
    End If

OuttaHere:
    While (Application.IsWait())
        Application.LeaveWait()
    Wend
End Function

Sub ReplaceTokenInString (ByVal TokenToReplace$, ByVal TokenToInsert$, sReplaceIn$)

    Dim sLeft$, sRight$
    Dim nActSearchPos%

    nActSearchPos% = 1

    While (0 <> InStr (nActSearchPos%, sReplaceIn$, TokenToReplace$))

        sLeft$ = Left (sReplaceIn$, InStr (nActSearchPos%, sReplaceIn$, TokenToReplace$) - 1)
        nActSearchPos% = Len (sLeft$) + Len (TokenToReplace$) + 1
        sRight = Mid (sReplaceIn$, nActSearchPos%)

        sReplaceIn$ = sLeft$ + TokenToInsert$ + sRight$
    Wend
End Sub

Sub ReplaceStringInStrings(aStrings As Strings, ByVal sFind$, ByVal sReplace$)
    Dim NewStrings As New Strings
    Dim nCount%

    NewStrings.Clear()
    For nCount% = 1 To aStrings.Count()
        NewStrings.Add(aStrings.Item (nCount%))
    Next

    aStrings.Clear()
    For nCount% = 1 To NewStrings.Count()
        If (NewStrings.Item (nCount%) = sFind$) Then
            aStrings.Add(sReplace$)
        Else
            aStrings.Add(NewStrings.Item (nCount%))
        End If
    Next
    Erase NewStrings
End Sub

Function StrInStrings%(ByVal AvailNames As Strings, ByVal ActiveName$)
    Dim Result%, nCount%
    Dim bNotFound%

    bNotFound% = True
    nCount% = 1
    ActiveName$ = UCase(ActiveName$)
    While (nCount%<=AvailNames.Count() And bNotFound%)
        If (UCase(AvailNames.Item(nCount%))=UCase(ActiveName$)) Then
            bNotFound%=False
        Else
            nCount% = nCount% + 1
        End If
    Wend

    If (bNotFound%) Then
        StrInStrings% = -1
    Else
        StrInStrings% = nCount%
    End If
End Function

Function SuggestTitleStr$(ByVal AvailNames As Strings, ByVal ActiveName$)

    Dim nMaxTitleLen%
    nMaxTitleLen = 31

    Dim SuggestCount%, index%
    Dim oldName$

    oldName$ = ActiveName$
    SuggestCount% = 1

    While ((-1 <> StrInStrings%(AvailNames, UCase(ActiveName$)) Or (Len (ActiveName$) > nMaxTitleLen)))
        ActiveName$ = Left (oldName$, 1 + nMaxTitleLen - Len (Str (Trim (SuggestCount%))))
        ActiveName$ = ActiveName$ + Trim(Str(SuggestCount%))
        SuggestCount% = SuggestCount% + 1
    Wend
    SuggestTitleStr$ = ActiveName$
End Function

Function SuggestTableTitleStr$(ByVal AvailNames As Strings, ByVal ActiveName$)
    Dim SuggestCount%, index%, nMaxTitleLen&
    Dim oldName$

    nMaxTitleLen& = Application.GetDatabaseLimits (1)
    If ((0 = nMaxTitleLen&) Or (50 < nMaxTitleLen&)) Then nMaxTitleLen& = 50

    oldName$ = ActiveName$
    SuggestCount% = 1

    While ((-1 <> StrInStrings%(AvailNames, UCase (ActiveName$)) Or (Len (ActiveName$) > nMaxTitleLen&)))
        ActiveName$ = Left (oldName$, 1 + nMaxTitleLen& - Len (Str (Trim (SuggestCount%))))
        ActiveName$ = ActiveName$ + Trim(Str(SuggestCount%))
        SuggestCount% = SuggestCount% + 1
    Wend
    SuggestTableTitleStr$ = ActiveName$
End Function

Function CheckTitleUnique(ByVal DatabaseTitles(), txtNewTitle As Object, _
                     ByVal sErrTitleExist$, sWizardName$) as Boolean
' Todo: Abfrage ob binärer oder textueller Vergleich
    If FieldInArray(DatabaseTitles(), Ubound(DatabaseTitles()),TxtNewTitle) Then
'    If (-1 <> StrInStrings%(DatabaseTitles, UCase(txtNewTitle.Text))) Then
        MsgBox (sErrTitleExist$, 64, sWizardName$)
        txtNewTitle.Text = SuggestTitleStr$(DatabaseTitles, txtNewTitle.Text)
        If ("" = txtNewTitle.Text) Then
            txtNewTitle.Text = txtNewTitle.Tag
        Else
            txtNewTitle.Tag = txtNewTitle.Text
        End If
        txtNewTitle.SetFocus()
        txtNewTitle.tag = "ERROR"
        CheckTitleUnique = False
        Exit Function
    End If
    CheckTitleUnique = True
End Function

'Function CheckTableTitleUnique(ByVal DatabaseTitles As Strings, txtNewTitle As Object, _
'                     ByVal sErrTitleExist$, sWizardName$) As Boolean

'    CheckTableTitleUnique = True
'    If (-1 <> StrInStrings%(DatabaseTitles, UCase(txtNewTitle.Text))) Then
'        MsgBox (sErrTitleExist$, 64, sWizardName$)
'        txtNewTitle.Text = SuggestTableTitleStr$(DatabaseTitles, txtNewTitle.Text)
'        If ("" = txtNewTitle.Text) Then
'            txtNewTitle.Text = txtNewTitle.Tag
'        Else
'            txtNewTitle.Tag = txtNewTitle.Text
'        End If
'        txtNewTitle.SetFocus()
'        txtNewTitle.tag = "ERROR"
'        CheckTableTitleUnique = False
'    End If
'End Function

'Sub CheckFullTitleUnique(ByVal DatabaseTitles As Strings, txtNewTitle As Object, _
'                     ByVal sErrTitleExist$, sWizardName$, vDB as Variant)
'
'    Dim sFullName as String
'    sFullName = UCase(GetFullTableName (txtNewTitle.Text, vDB))
'    If (-1 <> StrInStrings%(DatabaseTitles, sFullName)) Then
'        MsgBox (sErrTitleExist$, 64, sWizardName$)
'        txtNewTitle.Text = SuggestTitleStr$(DatabaseTitles, txtNewTitle.Text)
'        If ("" = txtNewTitle.Text) Then
'            txtNewTitle.Text = txtNewTitle.Tag
'        Else
'            txtNewTitle.Tag = txtNewTitle.Text
'        End If
'        txtNewTitle.SetFocus()
'        txtNewTitle.tag = "ERROR"
'    End If
'End Sub

Sub FixODBCBug()
    On Error Resume Next
    Dim nTempValue
    nTempValue = Application.DataColumnNumber()
End Sub


'    Dialog tools
Sub PaintPicOnPreview(Preview As Object, ByVal Filename$, ByVal Width%, ByVal Height%, ByVal bDrawFrame%)

    Dim Bitmap As Object
    Dim TWIPSPicHeight%, TWIPSPicWidth%, StartX%, StartY%
    Dim bFittingX%, bFittingY%, DlgWidth%, DlgHeight%, nXMove%, nYMove%
    Dim x#, y#

    Set Bitmap = LoadPicture (FileName$)

    If (1 = GetGUIType()) Then
        DlgHeight% = CInt (Preview.Height * GetDialogZoomFactorY (Preview.Height))
        DlgWidth% = CInt (Preview.Width * GetDialogZoomFactorX (Preview.Width))
        nXMove% = TwipsPerPixelX() * 3
        nYMove% = TwipsPerPixelX() * 3
    Else
        DlgHeight% = CInt ((Preview.Height - TwipsPerPixelY() * 3) * GetDialogZoomFactorY (Preview.Height))
        DlgWidth% = CInt ((Preview.Width - TwipsPerPixelX() * 3) * GetDialogZoomFactorX (Preview.Width))
        nXMove% = 0
        nYMove% = 0
    End If

    TWIPSPicWidth% = TwipsPerPixelX() * Width%
    TWIPSPicHeight% = TwipsPerPixelY() * Height%

    If (Not ((TWIPSPicWidth% <= DlgWidth%) And (TWIPSPicHeight% <= DlgHeight%))) Then
        x# = (TWIPSPicWidth% / DlgWidth%)
        y# = (TWIPSPicHeight% / DlgHeight%)
        If (x# > y#) Then
            TWIPSPicWidth% = CInt (DlgWidth%)
            TWIPSPicHeight% = CInt (TWIPSPicHeight% / x#)
        Else
            TWIPSPicHeight% = CInt (DlgHeight%)
            TWIPSPicWidth% = CInt (TWIPSPicWidth% / y#)
        End If
    End If

    StartX% = CInt ((DlgWidth% / 2) - (TWIPSPicWidth% / 2)) - nXMove%
    StartY% = CInt ((DlgHeight% / 2) - (TWIPSPicHeight% / 2)) - nYMove%

    Preview.Cls ()
    Preview.DrawPicture (Bitmap, StartX%, StartY%, StartX% + TWIPSPicWidth%, StartY% + TWIPSPicHeight%)
    IF (bDrawFrame%) Then
        Preview.DrawBox (StartX%, StartY%, StartX% + TWIPSPicWidth%, StartY% + TWIPSPicHeight%)
    End If

End Sub


Function SelectionInListBox%(lb As Object)
    Dim n%,count%
    n%=0
    count%=0

    For n%=0 To lb.ListCount()-1
        If lb.Selected(n%) Then
            count% = count% + 1
        End If
    Next
    SelectionInListBox% = Count%
End Function



Sub CopyList_To_Combo(listbox1, listbox2, combobox, ByVal FirstEntry$)
    Dim nCount%

    combobox.Clear()
    If (FirstEntry$<>"") Then
        combobox.AddItem(FirstEntry$)
    End If
    For nCount%=0 To listbox1.ListCount()-1
        combobox.AddItem(listbox1.List(nCount%))
    Next
    For nCount%=0 To listbox2.ListCount()-1
        combobox.AddItem(listbox2.List(nCount%))
    Next
    combobox.ListIndex = 0
End Sub


Sub MoveOrderedSelectedListbox(lbDest As Object, lbSource As Object, OriginalOrder As Strings, ByVal bMoveAll%)

    Dim nOriginalPos%, nSourcePos%, nSourceCount%
    Dim bFound%, nFirstSelected%
    Dim sSelected$, sActField$


    If (bMoveAll%) Then

        nFirstSelected% = -1

        lbSource.Clear()
        lbDest.Clear()

        For nSourceCount% = 1 To OriginalOrder.Count()
            lbDest.AddItem(OriginalOrder.Item(nSourceCount%))
        Next
    Else

        nFirstSelected% = -1

        For nSourceCount% = 0 To lbSource.ListCount() - 1

            nSourcePos% = 0
            nOriginalPos% = 1

            If (lbSource.Selected (nSourceCount%)) Then

                If (-1 = nFirstSelected%) Then nFirstSelected% = nSourceCount%

                bFound% = False
                sSelected$ = lbSource.List(nSourceCount%)

                While ((Not bFound%) And (nOriginalPos% <= OriginalOrder.Count()))

                    sActField$ = OriginalOrder.Item(nOriginalPos%)

                    If (sSelected$ = sActField$) Then
                        bFound% = True
                        lbDest.AddItem(sSelected$, nSourcePos%)
                    Else
                        If (nSourcePos% < lbDest.ListCount()) Then
                            If (lbDest.List(nSourcePos%) = sActField$) Then
                                nSourcePos% = nSourcePos% + 1
                            End If
                        End If
                    End If

                    If (Not bFound%) Then nOriginalPos% = nOriginalPos% + 1
                Wend
            End If
        Next

        Call RemoveSelected (lbSource)
    End If

    '    set selection
    Call SetNewSelection(lbSource, nFirstSelected%)
End Sub

Function GetIndexOfItem%(lb As Object, ByVal FindValue$)
    Dim i%
    For i%=0 To lb.ListCount()-1
        If (lb.List(i%)=FindValue$) Then
            GetIndexOfItem% = i%
            Exit Function
        End If
    Next
    '    Not found
    GetIndexOfItem% = -1
End Function

Function GetSelectionIndexOfListBox%(lb As Object)
    ' get first selection in listbox
    Dim nCount%
    For nCount% = 0 To lb.ListCount() - 1
        If (lb.Selected(nCount%)) Then
            GetSelectionIndexOfListBox% = nCount%
            Exit Function
        End If
    Next
    GetSelectionIndexOfListBox% = -1
End Function

Function ItemInListBox%(lb As Object, ByVal itemName$)

    Dim n%
    For n%=0 To lb.ListCount()-1
        If (lb.List(n%)=itemName$) Then
            ItemInListBox% = True
            Exit Function
        End If
    Next
    ItemInListBox% = False
End Function

Function GetSelectionsInListBox%(lb As Object)

    Dim nResult%, nCount%

    nResult% = 0

    For nCount% = 0 To lb.ListCount() - 1

        If lb.Selected(nCount%) Then
            nResult% = nResult% + 1
        End If
    Next

    GetSelectionsInListBox% = nResult%
End Function


Sub CopyOrderdItemsListBox(lbDest As Object, lbSource As Object, OriginalOrder As Strings)

    Dim nCount%, sSelected$

    '   Select
    If (-1 < lbDest.ListIndex()) Then
        sSelected$ = lbDest.List(lbDest.ListIndex())
    Else
        sSelected$ = ""
    End If

    '   Copy
    lbDest.Clear()
    For nCount% = 1 To OriginalOrder.Count()
        lbDest.AddItem(OriginalOrder.Item(nCount%))
    Next

    '   Delete Source
    lbSource.Clear()

    '   If there eas a Selection, it will be set
    If ("" <> sSelected$) Then
        nCount% = 0
        While (sSelected$ <> lbDest.List(nCount%))
            nCount% = nCount% + 1
        Wend
        lbDest.Selected(nCount%) = True
    End If

End Sub



</script:module>