diff options
| -rw-r--r-- | wizards/source/tools/Misc.xba | 267 | ||||
| -rw-r--r-- | wizards/source/tools/Strings.xba | 7 |
2 files changed, 76 insertions, 198 deletions
diff --git a/wizards/source/tools/Misc.xba b/wizards/source/tools/Misc.xba index 1e99ed8cf448..576bc58c525c 100644 --- a/wizards/source/tools/Misc.xba +++ b/wizards/source/tools/Misc.xba @@ -7,18 +7,69 @@ Const SBUSER = 1 Dim Taskindex as Integer Dim oResSrv as Object +Sub Main() +Dim PropList(3,1)' as String + PropList(0,0) = "URL" + PropList(0,1) = "sdbc:odbc:Erica_Test_Unicode" + PropList(1,0) = "User" + PropList(1,1) = "extra" + PropList(2,0) = "Password" + PropList(2,1) = "extra" + PropList(3,0) = "IsPasswordRequired" + PropList(3,1) = True +' RegisterNewDataSource("Doc_Erica_Test_Unicode", PropList()) +End Sub + + +Function RegisterNewDataSource(DSName as String, PropertyList(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) +Dim oDataSource as Object +Dim oDBContext as Object +Dim oPropInfo as Object +Dim i as Integer + oDBContext = createUnoService("com.sun.star.sdb.DatabaseContext") + oDataSource = createUnoService("com.sun.star.sdb.DataSource") + For i = 0 To Ubound(PropertyList(), 1) + sPropName = PropertyList(i,0) + sPropValue = PropertyList(i,1) + oDataSource.SetPropertyValue(sPropName,sPropValue) 'GetByName(sPropName) = sPropValue 'oPropInfo.GetPropertyByName(sPropName)) = sPropValue ' PropertyList(i,0))) = PropertyList(i,1) + Next i + If Not IsMissing(DriverProperties()) Then + oDataSource.Info() = DriverProperties() + End If + oDBContext.RegisterObject(DSName, oDataSource) + RegisterNewDataSource () = oDataSource +End Function + + ' Connects to a registered Database -Function ConnecttoDatabase(DBName as String, UserID as String, Password as String ) +Function ConnecttoDatabase(DSName as String, UserID as String, Password as String, Optional Propertylist(), Optional DriverProperties() as New com.sun.star.beans.PropertyValue) Dim oDBContext as Object Dim oDBSource as Object + On Local Error Goto NOCONNECTION oDBContext = CreateUnoService("com.sun.star.sdb.DatabaseContext") - If oDBContext.HasbyName(DBName) Then - oDBSource = oDBContext.GetByName(DBName) + If oDBContext.HasbyName(DSName) Then + oDBSource = oDBContext.GetByName(DSName) ConnectToDatabase = oDBSource.GetConnection(UserID, Password) Else - Msgbox("DataSource " & DBName & " is not registered" , 16, GetProductname) - ConnectToDatabase() = NULL + If Not IsMissing(Namelist()) Then + If Not IsMissing(DriverProperties()) Then + RegisterNewDataSource(DSName, PropertyList(), DriverProperties()) + Else + RegisterNewDataSource(DSName, PropertyList()) + End If + oDBSource = oDBContext.GetByName(DSName) + ConnectToDatabase = oDBSource.GetConnection(UserID, Password) + Else + Msgbox("DataSource " & DSName & " is not registered" , 16, GetProductname()) + ConnectToDatabase() = NULL + End If End If +NOCONNECTION: + If Err <> 0 Then + Msgbox(Error$, 16, GetProductName()) + Resume LEAVESUB + LEAVESUB: + End If End Function @@ -107,98 +158,6 @@ Dim MaxArrIndex as integer End Function -' clears up a Listbox and refills it with the delivered Array 'ValList()' -Sub FillUpCombo(LocListbox as Object, ValList() as String) -Dim i as integer -Dim a as Integer - LocListbox.Clear - ' Trage die ??bersetzungsrelevanten Verzeichnisnamen in die Listbox ein - a = 0 - For i = 0 to Ubound(ValList()) - If ValList(i) <> "" Then - LocListbox.List(a) = ValList(i) - a = a + 1 - End If - Next -End Sub - - -Sub WritedbgInfo(LocObject as Object) -Dim locUrl as String -Dim oLocDocument as Object -Dim oLocText as Object -Dim oLocCursor as Object -Dim NoArgs() -Dim sObjectStrings(2) as String -Dim sProperties() as String -Dim n as Integer -Dim m as Integer - sObjectStrings(0) = LocObject.dbg_Properties - sObjectStrings(1) = LocObject.dbg_Methods - sObjectStrings(2) = LocObject.dbg_SupportedInterfaces - LocUrl = "private:factory/swriter" - oLocDocument = StarDesktop.LoadComponentFromURL(LocUrl,"_blank",0,NoArgs) - oLocText = oLocDocument.text - oLocCursor = oLocText.createTextCursor() - oLocCursor.gotoStart(False) - If Vartype(LocObject) = 9 then ' an Object Variable - For n = 0 To 2 - sProperties() = ArrayoutofString(sObjectStrings(n),";", MaxIndex) - For m = 0 To MaxIndex - oLocText.insertString(oLocCursor,sProperties(m),False) - oLocText.insertControlCharacter(oLocCursor,com.sun.star.text.ControlCharacter.PARAGRAPH_BREAK,False) - Next m - Next n - Elseif Vartype(LocObject) = 8 Then ' a String Variable - oLocText.insertString(oLocCursor,LocObject,False) - ElseIf Vartype(LocObject) = 1 Then - Msgbox("Variable is Null!", 16, GetProductName()) - End If -End Sub - - -Sub WriteDbgString(LocString as string) -Dim oLocDesktop as object -Dim LocUrl as String -Dim oLocDocument as Object -Dim oLocCursor as Object -Dim oLocText as Object - - LocUrl = "private:factory/swriter" - oLocDocument = StarDesktop.LoadComponentFromURL(LocUrl,"_blank",0,NoArgs) - oLocText = oLocDocument.text - oLocCursor = oLocText.createTextCursor() - oLocCursor.gotoStart(False) - oLocText.insertString(oLocCursor,LocString,False) -End Sub - - -Sub printdbgInfo(LocObject) - If Vartype(LocObject) = 9 then - Msgbox LocObject.dbg_properties - Msgbox LocObject.dbg_methods - Msgbox LocObject.dbg_supportedinterfaces - Elseif Vartype(LocObject) = 8 Then ' a String Variable - Msgbox LocObject - ElseIf Vartype(LocObject) = 0 Then - Msgbox("Variable is Null!", 16, GetProductName()) - Else - Msgbox("Type of Variable: " & Typename(LocObject), 48, GetProductName()) - End If -End Sub - - -Sub ShowArray(LocArray()) -Dim i as integer -Dim msgstring - msgstring = "" - For i = Lbound(LocArray()) to Ubound(LocArray()) - msgstring = msgstring + LocArray(i) + chr(13) - Next - Msgbox msgstring -End Sub - - ' Gets a special configured PathSetting Function GetPathSettings(sPathType as String, Optional bshowall as Boolean, Optional ListIndex as integer) as String Dim oSettings, oPathSettings as Object @@ -268,103 +227,6 @@ Dim MaxIndex as Integer End Function -Sub ShowPropertyValues(oLocObject as Object) -Dim PropName as String -Dim sValues as String - On Local Error Goto NOPROPERTYSETINFO: - sValues = "" - For i = 0 To Ubound(oLocObject.PropertySetInfo.Properties) - Propname = oLocObject.PropertySetInfo.Properties(i).Name - sValues = sValues & PropName & " = " & oLocObject.GetPropertyValue(PropName) & chr(13) - Next i - Msgbox(sValues , 64, GetProductName()) - Exit Sub - -NOPROPERTYSETINFO: - Msgbox("Sorry, No PropertySetInfo attached to the object", 16, GetProductName()) - Resume LEAVEPROC - LEAVEPROC: -End Sub - - -Sub ShowNameValuePair(Pair()) -Dim i as Integer -Dim ShowString as String - ShowString = "" - On Local Error Resume Next - For i = 0 To Ubound(Pair()) - ShowString = ShowString & Pair(i).Name & " = " - ShowString = ShowString & Pair(i).Value & chr(13) - Next i - Msgbox ShowString -End Sub - - -' Retrieves all the Elements of aSequence of an object, with the -' possibility to define a filter(sfilter <> "") -Sub ShowElementNames(oLocElements() as Object, Optional sFiltername as String) -Dim i as Integer -Dim NameString as String - NameString = "" - For i = 0 To Ubound(oLocElements()) - If Not IsMissIng(sFilterName) Then - If Instr(1, oLocElements(i), sFilterName) Then - NameString = NameString & oLocElements(i) & chr(13) - End If - Else - NameString = NameString & oLocElements(i) & chr(13) - End If - Next i - Msgbox(NameString, 64, GetProductName()) -End Sub - - -' Retrieves all the supported servicenames of an object, with the -' possibility to define a filter(sfilter <> "") -Sub ShowSupportedServiceNames(oLocObject as Object, Optional sFilterName as String) - On Local Error Goto NOSERVICENAMES - If IsMissing(sFilterName) Then - ShowElementNames(oLocobject.SupportedServiceNames()) - Else - ShowElementNames(oLocobject.SupportedServiceNames(), sFilterName) - End If - Exit Sub - - NOSERVICENAMES: - Msgbox("Sorry, No 'SupportedServiceNames' - Property attached to the object", 16, GetProductName()) - Resume LEAVEPROC - LEAVEPROC: -End Sub - - -' Retrieves all the available Servicenames of an object, with the -' possibility to define a filter(sfilter <> "") -Sub ShowAvailableServiceNames(oLocObject as Object, Optional sFilterName as String) - On Local Error Goto NOSERVICENAMES - If IsMissing(sFilterName) Then - ShowElementNames(oLocobject.AvailableServiceNames) - Else - ShowElementNames(oLocobject.AvailableServiceNames, sFilterName) - End If - Exit Sub - - NOSERVICENAMES: - Msgbox("Sorry, No 'AvailableServiceNames' - Property attached to the object", 16, GetProductName()) - Resume LEAVEPROC - LEAVEPROC: -End Sub - - -Sub ShowCommands(oLocObject as Object) - On Local Error Goto NOCOMMANDS - ShowElementNames(oLocObject.QueryCommands) - Exit Sub - NOCOMMANDS: - Msgbox("Sorry, No 'QueryCommands' - Property attached to the object", 16, GetProductName()) - Resume LEAVEPROC - LEAVEPROC: -End Sub - Function InitResources(Description, ShortDescription as String) as boolean On Error Goto ErrorOcurred @@ -534,6 +396,7 @@ Function GetDocumentType(oDocument) End Function + Function GetNumberFormatType(oDocFormats, oFormatObject as Object) as Integer Dim ThisFormatKey as Long Dim oObjectFormat as Object @@ -729,6 +592,7 @@ Dim PropValue(1) as new com.sun.star.beans.PropertyValue End Sub + Function ModifyPropertyValue(oContent() as Object, TargetProperties() as New com.sun.star.beans.PropertyValue ) Dim MaxIndex as Integer Dim i as Integer @@ -794,4 +658,19 @@ Dim oDisp as Object oDisp.dispatch(oUrl, oArg()) End Sub + +'returns the type of the office application +'FatOffice = 0, WebTop = 1 +'This routine has to be changed if the Product Name is being changed! +Function IsFatOffice() As Boolean + If sProductname = "" Then + sProductname = GetProductname() + End If + IsFatOffice = TRUE + 'The following line has to include the current productname + If Instr(1,sProductname,"WebTop",1) <> 0 Then + IsFatOffice = FALSE + End If +End Function + </script:module>
\ No newline at end of file diff --git a/wizards/source/tools/Strings.xba b/wizards/source/tools/Strings.xba index c478804e5f08..2e70535b9d49 100644 --- a/wizards/source/tools/Strings.xba +++ b/wizards/source/tools/Strings.xba @@ -58,7 +58,6 @@ Dim BigLen%,PreLen%,PostLen% End Function - ' Deletes the String 'SmallString' out of the String 'BigString' ' in case SmallString's Position in BigString is right at the end Function RTrimStr(ByVal BigString, SmallString as String) as String @@ -247,7 +246,7 @@ Dim Separator as String sProductname = GetProductname() End If If BigString <> "" Then - If Instr(1,sProductname,"Sun Webtop") = 0 Then + If IsFatOffice() Then Separator = GetPathSeparator() ' Is the delivered Path already a URL If Instr(1,UCase(BigString),"FILE:///") = 0 Then @@ -333,10 +332,10 @@ Dim SepList() as String End Function -Function DirectorynameoutofPath(sPath as String, Separator as String) as String +Function DirectoryNameoutofPath(sPath as String, Separator as String) as String Dim LocFileName as String LocFileName = FileNameoutofPath(sPath, Separator) - DirectoryNameoutofPath = DeleteStr(sPath, Separator & LocFileName) + DirectoryNameoutofPath = RTrimStr(sPath, Separator & LocFileName) End Function |