Quelle  ModuleControls.xba   Sprache: unbekannt

<?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE script:module PUBLIC "-//OpenOffice.org//DTD OfficeDocument 1.0//EN" "module.dtd">
<!--
 * This file is part of the LibreOffice project.
 *
 * This Source Code Form is subject to the terms of the Mozilla Public
 * License, v. 2.0. If a copy of the MPL was not distributed with this
 * file, You can obtain one at http://mozilla.org/MPL/2.0/.
 *
 * This file incorporates work covered by the following license notice:
 *
 *   Licensed to the Apache Software Foundation (ASF) under one or more
 *   contributor license agreements. See the NOTICE file distributed
 *   with this work for additional information regarding copyright
 *   ownership. The ASF licenses this file to you under the Apache
 *   License, Version 2.0 (the "License"); you may not use this file
 *   except in compliance with the License. You may obtain a copy of
 *   the License at http://www.apache.org/licenses/LICENSE-2.0 .
-->
<script:module xmlns:script="http://openoffice.org/2000/script" script:name="ModuleControls" script:language="StarBasic">Option Explicit

Public DlgOverwrite as Object
Public Const SBOVERWRITEUNDEFINED as Integer = 0
Public Const SBOVERWRITECANCEL as Integer = 2
Public Const SBOVERWRITEQUERY as Integer = 7
Public Const SBOVERWRITEALWAYS as Integer = 6
Public Const SBOVERWRITENEVER as Integer = 8
Public iGeneralOverwrite as Integer



' Accepts the name of a control and returns the respective control model as object
' The Container can either be a whole document or a specific sheet of a Calc-Document
' 'CName' is the name of the Control
Function getControlModel(oContainer as Object, CName as String)
Dim aForm, oForms as Object
Dim i as Integer
 oForms = oContainer.Drawpage.GetForms
 For i = 0 To oForms.Count-1
  aForm = oForms.GetbyIndex(i)
  If aForm.HasByName(CName) Then
   GetControlModel = aForm.GetbyName(CName)
   Exit Function
  End If
 Next i
 Msgbox("No Control with the name '" & CName & "' found" , 16, GetProductName())
End Function



' Gets the Shape of a Control( e. g. to reset the size or Position of the control
' Parameters:
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' 'CName' is the Name of the Control
Function GetControlShape(oContainer as Object,CName as String)
Dim i as integer
Dim aShape as Object
 For i = 0 to oContainer.DrawPage.Count-1
  aShape = oContainer.DrawPage(i)
  If HasUnoInterfaces(aShape, "com.sun.star.drawing.XControlShape") then
   If ashape.Control.Name = CName then
    GetControlShape = aShape
    exit Function
   End If
  End If
 Next
End Function


' Returns the View of a Control
' Parameters:
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' The 'oController' is always directly attached to the Document
' 'CName' is the Name of the Control
Function getControlView(oContainer , oController as Object, CName as String) as Object
Dim aForm, oForms, oControlModel as Object
Dim i as Integer
 oForms = oContainer.DrawPage.Forms
 For i = 0 To oForms.Count-1
  aForm = oforms.GetbyIndex(i)
  If aForm.HasByName(CName) Then
   oControlModel = aForm.GetbyName(CName)
   GetControlView = oController.GetControl(oControlModel)
   Exit Function
  End If
 Next i
 Msgbox("No Control with the name '" & CName & "' found" , 16, GetProductName())
End Function



' Parameters:
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' 'CName' is the Name of the Control
Function DisposeControl(oContainer as Object, CName as String) as Boolean
Dim aControl as Object

 aControl = GetControlModel(oContainer,CName)
 If not IsNull(aControl) Then
  aControl.Dispose()
  DisposeControl = True
 Else
  DisposeControl = False
 End If
End Function


' Returns a sequence of a group of controls like option buttons or checkboxes
' The 'oContainer' is the Document or a specific sheet of a Calc - Document
' 'sGroupName' is the Name of the Controlgroup
Function GetControlGroupModel(oContainer as Object, sGroupName as String )
Dim aForm, oForms As Object
Dim aControlModel() As Object
Dim i as integer

 oForms = oContainer.DrawPage.Forms
 For i = 0 To oForms.Count-1
  aForm = oForms(i)
  If aForm.HasbyName(sGroupName) Then
   aForm.GetGroupbyName(sGroupName,aControlModel)
   GetControlGroupModel = aControlModel
   Exit Function
  End If
 Next i
 Msgbox("No Controlgroup with the name '" & sGroupName & "' found" , 16, GetProductName())
End Function


' Returns the Referencevalue of a group of e.g. option buttons or check boxes
' 'oControlGroup' is a sequence of the Control objects
Function GetRefValue(oControlGroup() as Object)
Dim i as Integer
 For i = 0 To Ubound(oControlGroup())
'  oControlGroup(i).DefaultState = oControlGroup(i).State
  If oControlGroup(i).State Then
   GetRefValue = oControlGroup(i).RefValue
   exit Function
  End If
 Next
 GetRefValue() = -1
End Function


Function GetRefValueOfControlGroup(oContainer as Object, GroupName as String)
Dim oOptGroup() as Object
Dim iRef as Integer
 oOptGroup() = GetControlGroupModel(oContainer, GroupName)
 iRef = GetRefValue(oOptGroup())
 GetRefValueofControlGroup = iRef
End Function


Function GetOptionGroupValue(oContainer as Object, OptGroupName as String) as Boolean
Dim oRulesOptions() as Object
 oRulesOptions() = GetControlGroupModel(oContainer, OptGroupName)
 GetOptionGroupValue = oRulesOptions(0).State
End Function



Function WriteOptValueToCell(oSheet as Object, OptGroupName as String, iCol as Integer, iRow as Integer) as Boolean
Dim bOptValue as Boolean
Dim oCell as Object
 bOptValue = GetOptionGroupValue(oSheet, OptGroupName)
 oCell = oSheet.GetCellByPosition(iCol, iRow)
 oCell.SetValue(ABS(CInt(bOptValue)))
 WriteOptValueToCell() = bOptValue
End Function


Function LoadDialog(Libname as String, DialogName as String, Optional oLibContainer)
Dim oLib as Object
Dim oLibDialog as Object
Dim oRuntimeDialog as Object
 If IsMissing(oLibContainer ) then
  oLibContainer = DialogLibraries
 End If
 oLibContainer.LoadLibrary(LibName)
 oLib = oLibContainer.GetByName(Libname)
 oLibDialog = oLib.GetByName(DialogName)
 oRuntimeDialog = CreateUnoDialog(oLibDialog)
 LoadDialog() = oRuntimeDialog
End Function


Sub GetFolderName(oRefModel as Object)
Dim oFolderDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim InitPath as String
Dim RefControlName as String
Dim oUcb as object
 'Note: The following services have to be called in the following order
 ' because otherwise Basic does not remove the FileDialog Service
 oFolderDialog = CreateUnoService("com.sun.star.ui.dialogs.FolderPicker")
 oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
 InitPath = ConvertToUrl(oRefModel.Text)
 If InitPath = "" Then
  InitPath = GetPathSettings("Work")
 End If
 If oUcb.Exists(InitPath) Then
  oFolderDialog.SetDisplayDirectory(InitPath)
 End If
 iAccept = oFolderDialog.Execute()
 If iAccept = 1 Then
  sPath = oFolderDialog.GetDirectory()
  If oUcb.Exists(sPath) Then
   oRefModel.Text = ConvertFromUrl(sPath)
  End If
 End If
End Sub


Sub GetFileName(oRefModel as Object, Filternames())
Dim oFileDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim InitPath as String
Dim RefControlName as String
Dim oUcb as object
'Dim ListAny(0)
 'Note: The following services have to be called in the following order
 ' because otherwise Basic does not remove the FileDialog Service
 oFileDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
 oUcb = createUnoService("com.sun.star.ucb.SimpleFileAccess")
 'ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILEOPEN_SIMPLE
 'oFileDialog.initialize(ListAny())
 AddFiltersToDialog(FilterNames(), oFileDialog)
 InitPath = ConvertToUrl(oRefModel.Text)
 If InitPath = "" Then
  InitPath = GetPathSettings("Work")
 End If
 If oUcb.Exists(InitPath) Then
  oFileDialog.SetDisplayDirectory(InitPath)
 End If
 iAccept = oFileDialog.Execute()
 If iAccept = 1 Then
  sPath = oFileDialog.Files(0)
  If oUcb.Exists(sPath) Then
   oRefModel.Text = ConvertFromUrl(sPath)
  End If
 End If
 oFileDialog.Dispose()
End Sub


Function StoreDocument(oDocument as Object, FilterNames() as String, DefaultName as String, DisplayDirectory as String, Optional iAddProcedure as Integer) as String
Dim NoArgs() as New com.sun.star.beans.PropertyValue
Dim oStoreProperties(0) as New com.sun.star.beans.PropertyValue
Dim oStoreDialog as Object
Dim iAccept as Integer
Dim sPath as String
Dim ListAny(0) as Long
Dim UIFilterName as String
Dim FilterName as String
Dim FilterIndex as Integer
 ListAny(0) = com.sun.star.ui.dialogs.TemplateDescription.FILESAVE_AUTOEXTENSION_PASSWORD
 oStoreDialog = CreateUnoService("com.sun.star.ui.dialogs.FilePicker")
 oStoreDialog.Initialize(ListAny())
 AddFiltersToDialog(FilterNames(), oStoreDialog)
 oStoreDialog.SetDisplayDirectory(DisplayDirectory)
 oStoreDialog.SetDefaultName(DefaultName)
 oStoreDialog.setValue(com.sun.star.ui.dialogs.ExtendedFilePickerElementIds.CHECKBOX_AUTOEXTENSION,0, true)

 iAccept = oStoreDialog.Execute()
 If iAccept = 1 Then
  sPath = oStoreDialog.Files(0)
  UIFilterName = oStoreDialog.GetCurrentFilter()
  FilterIndex = IndexInArray(UIFilterName, FilterNames())
  FilterName = FilterNames(FilterIndex,2)
  If Not IsMissing(iAddProcedure) Then
   Select Case iAddProcedure
    Case 1
     CommitLastDocumentChanges(sPath)
   End Select
  End If
  On Local Error Goto NOSAVING
  If FilterName = ""  Then
   ' Todo: Catch the case that a document that has to be overwritten is writeprotected (e.g. it is open)
   oDocument.StoreAsUrl(sPath, NoArgs())
  Else
   oStoreProperties(0).Name = "FilterName"
   oStoreProperties(0).Value = FilterName
   oDocument.StoreAsUrl(sPath, oStoreProperties())
  End If
 End If
 oStoreDialog.dispose()
 StoreDocument() = sPath
 Exit Function
NOSAVING:
 If Err <> 0 Then
'  Msgbox("Document cannot be saved under '" & ConvertFromUrl(sPath) & "'", 48, GetProductName())
  sPath = ""
  oStoreDialog.dispose()
  Resume NOERROR
  NOERROR:
 End If
End Function


Sub AddFiltersToDialog(FilterNames() as String, oDialog as Object)
Dim i as Integer
Dim MaxIndex as Integer
Dim ViewFiltername as String
Dim oProdNameAccess as Object
Dim sProdName as String
 oProdNameAccess = GetRegistryKeyContent("org.openoffice.Setup/Product")
 sProdName = oProdNameAccess.getByName("ooName")
 MaxIndex = Ubound(FilterNames(), 1)
 For i = 0 To MaxIndex
  Filternames(i,0) = ReplaceString(Filternames(i,0), sProdName,"%productname%")
  oDialog.AppendFilter(FilterNames(i,0), FilterNames(i,1))
 Next i
 oDialog.SetCurrentFilter(FilterNames(0,0))
End Sub


Sub SwitchMousePointer(oWindowPeer as Object, bDoEnable as Boolean)
Dim oWindowPointer as Object
 oWindowPointer = CreateUnoService("com.sun.star.awt.Pointer")
 If bDoEnable Then
  oWindowPointer.SetType(com.sun.star.awt.SystemPointer.ARROW)
 Else
  oWindowPointer.SetType(com.sun.star.awt.SystemPointer.WAIT)
 End If
 oWindowPeer.SetPointer(oWindowPointer)
End Sub


Sub ShowOverwriteAllDialog(FilePath as String, sTitle as String)
Dim QueryString as String
Dim LocRetValue as Integer
Dim lblYes as String
Dim lblNo as String
Dim lblYesToAll as String
Dim lblCancel as String
Dim OverwriteModel as Object
 If InitResources(GetProductName()) Then
  QueryString = GetResText("RID_COMMON_7")
  QueryString = ReplaceString(QueryString, ConvertFromUrl(FilePath), "<PATH>")
  If Len(QueryString) > 190 Then
   QueryString = DeleteStr(QueryString, ".<BR>")
  End If
  QueryString = ReplaceString(QueryString, chr(13), "<BR>")
  lblYes = GetResText("RID_COMMON_8")
  lblYesToAll = GetResText("RID_COMMON_9")
  lblNo = GetResText("RID_COMMON_10")
  lblCancel = GetResText("RID_COMMON_11")
  DlgOverwrite = LoadDialog("Tools", "DlgOverwriteAll")
  DlgOverwrite.Title = sTitle
  OverwriteModel = DlgOverwrite.Model
  OverwriteModel.cmdYes.Label = lblYes
  OverwriteModel.cmdYesToAll.Label = lblYesToAll
  OverwriteModel.cmdNo.Label = lblNo
  OverwriteModel.cmdCancel.Label = lblCancel
  OverwriteModel.lblQueryforSave.Label = QueryString
  OverwriteModel.cmdNo.DefaultButton = True
  DlgOverwrite.GetControl("cmdNo").SetFocus()
  iGeneralOverwrite = 999
  LocRetValue = DlgOverwrite.execute()
  If iGeneralOverwrite = 999 Then
   iGeneralOverwrite = SBOVERWRITECANCEL
  End If
  DlgOverwrite.dispose()
 Else
  iGeneralOverwrite = SBOVERWRITECANCEL
 End If
End Sub


Sub SetOVERWRITEToQuery()
 iGeneralOverwrite = SBOVERWRITEQUERY
 DlgOverwrite.EndExecute()
End Sub


Sub SetOVERWRITEToAlways()
 iGeneralOverwrite = SBOVERWRITEALWAYS
 DlgOverwrite.EndExecute()
End Sub


Sub SetOVERWRITEToNever()
 iGeneralOverwrite = SBOVERWRITENEVER
 DlgOverwrite.EndExecute()
End Sub
</script:module>