Quelle  ReadDir.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="ReadDir" script:language="StarBasic">Option Explicit
Public Const SBPAGEX = 800
Public Const SBPAGEY = 800
Public Const SBRELDIST = 1.3

' Names of the second Dimension of the Array iLevelPos
Public Const SBBASEX = 0
Public Const SBBASEY = 1

Public Const SBOLDSTARTX = 2
Public Const SBOLDSTARTY = 3

Public Const SBOLDENDX = 4
Public Const SBOLDENDY = 5

Public Const SBNEWSTARTX = 6
Public Const SBNEWSTARTY = 7

Public Const SBNEWENDX = 8
Public Const SBNEWENDY = 9

Public ConnectLevel As Integer
Public iLevelPos(1,9) As Long
Public Source as String
Public iCurLevel as Integer
Public nConnectLevel as Integer
Public nOldWidth, nOldHeight As Long
Public nOldX, nOldY, nOldLevel As Integer
Public oOldLeavingLine As Object
Public oOldArrivingLine As Object
Public DlgReadDir as Object
Dim oProgressBar as Object
Dim oDocument As Object
Dim oPage As Object


Sub Main()
Dim oStandardTemplate as Object
 BasicLibraries.LoadLibrary("Tools")
 oDocument = CreateNewDocument("sdraw")
 If Not IsNull(oDocument) Then
  oPage = oDocument.DrawPages(0)
  oStandardTemplate = oDocument.StyleFamilies.GetByName("graphics").GetByName("standard")
  oStandardTemplate.CharHeight = 10
  oStandardTemplate.TextLeftDistance = 100
  oStandardTemplate.TextRightDistance = 100
  oStandardTemplate.TextUpperDistance = 50
  oStandardTemplate.TextLowerDistance = 50
  DlgReadDir = LoadDialog("Gimmicks","ReadFolderDlg")
  oProgressBar = DlgReadDir.Model.ProgressBar1
  DlgReadDir.Model.TextField1.Text = ConvertFromUrl(GetPathSettings("Work"))
  DlgReadDir.Model.cmdGoOn.DefaultButton = True
  DlgReadDir.GetControl("TextField1").SetFocus()
  DlgReadDir.Execute
 End If
End Sub


Sub TreeInfo()
Dim oCurTextShape As Object
Dim i as Integer
Dim bStartUpRun As Boolean
Dim CurFilename as String
Dim BaseLevel as Integer
Dim oController as Object
Dim MaxFileIndex as Integer
Dim FileNames() as String
 ToggleDialogControls(False)
 oProgressBar.ProgressValueMin = 0
 oProgressBar.ProgressValueMax = 100
 bStartUpRun = True
 nOldHeight = 200
 nOldY = SBPAGEY
 nOldX = SBPAGEX
 nOldWidth = SBPAGEX
 oController = oDocument.GetCurrentController
 Source = ConvertToURL(DlgReadDir.Model.TextField1.Text)
 BaseLevel = CountCharsInString(Source, "/", 1)
 oProgressBar.ProgressValue = 5
 DlgReadDir.Model.Label3.Enabled = True
 FileNames() = ReadSourceDirectory(Source)
 DlgReadDir.Model.Label4.Enabled = True
 DlgReadDir.Model.Label3.Enabled = False
 oProgressBar.ProgressValue = 12
 FileNames() = BubbleSortList(FileNames())
 DlgReadDir.Model.Label5.Enabled = True
 DlgReadDir.Model.Label4.Enabled = False
 oProgressBar.ProgressValue = 20
 MaxFileIndex = Ubound(FileNames(),1)
 For i = 0 To MaxFileIndex
  oProgressBar.ProgressValue = 20 + (i/MaxFileIndex * 80)
  CurFilename = FileNames(i,1)
  SetNewLevels(FileNames(i,0), BaseLevel)
  oCurTextShape = CreateTextShape(oPage, CurFilename)
  CheckPageWidth(oCurTextShape.Size.Width)
  iLevelPos(iCurLevel,SBBASEY) = oCurTextShape.Position.Y
  If i = 0 Then
   AdjustPageHeight(oCurTextShape.Size.Height, MaxFileIndex + 1)
  End If
  ' The Current TextShape has To be connected with a TextShape one Level higher
  ' except for a TextShape In Level 0:
  If Not bStartUpRun Then
   ' A leaving Line Is only drawn when level is not 0
   If iCurLevel<> 0 Then
    ' Determine the Coordinates of the arriving Line
    iLevelPos(iCurLevel,SBOLDSTARTX) = iLevelPos(nConnectLevel,SBNEWSTARTX)
    iLevelPos(iCurLevel,SBOLDSTARTY) = oCurTextShape.Position.Y + 0.5 * oCurTextShape.Size.Height

    iLevelPos(iCurLevel,SBOLDENDX) = iLevelPos(iCurLevel,SBBASEX)
    iLevelPos(iCurLevel,SBOLDENDY) = oCurTextShape.Position.Y + 0.5 * oCurTextShape.Size.Height

    oOldArrivingLine = DrawLine(iCurLevel, SBOLDSTARTX, SBOLDSTARTY, SBOLDENDX, SBOLDENDY, oPage)

    ' Determine the End-Coordinates of the last leaving Line
    iLevelPos(nConnectLevel,SBNEWENDX) = iLevelPos(nConnectLevel,SBNEWSTARTX)
    iLevelPos(nConnectLevel,SBNEWENDY) = oCurTextShape.Position.Y + 0.5 * oCurTextShape.Size.Height
   Else
    ' On Level 0 the last Leaving Line's Endpoint is the upper edge of the TextShape
    iLevelPos(nConnectLevel,SBNEWENDY) = oCurTextShape.Position.Y
    iLevelPos(nConnectLevel,SBNEWENDX) = iLevelPos(nConnectLevel,SBNEWSTARTX)
   End If
   ' Draw the Connectors To the previous TextShapes
   oOldLeavingLine = DrawLine(nConnectLevel, SBNEWSTARTX, SBNEWSTARTY, SBNEWENDX, SBNEWENDY, oPage)
  Else
   ' StartingPoint of the leaving Edge
   bStartUpRun = FALSE
  End If

  ' Determine the beginning Coordinates of the leaving Line
  iLevelPos(iCurLevel,SBNEWSTARTX) = iLevelPos(iCurLevel,SBBASEX) + 0.5 * oCurTextShape.Size.Width
  iLevelPos(iCurLevel,SBNEWSTARTY) = iLevelPos(iCurLevel,SBBASEY) + oCurTextShape.Size.Height

  ' Save the values For the Next run
  nOldHeight = oCurTextShape.Size.Height
  nOldX = oCurTextShape.Position.X
  nOldWidth = oCurTextShape.Size.Width
  nOldLevel = iCurLevel
 Next i
 ToggleDialogControls(True)
 DlgReadDir.Model.cmdGoOn.Enabled = False
End Sub


Function CreateTextShape(oPage as Object, Filename as String)
Dim oTextShape As Object
Dim aPoint As New com.sun.star.awt.Point

 aPoint.X = CalculateXPoint()
 aPoint.Y = nOldY + SBRELDIST * nOldHeight
 nOldY = aPoint.Y

 oTextShape = oDocument.createInstance("com.sun.star.drawing.TextShape")
 oTextShape.LineStyle = 1
 oTextShape.Position = aPoint

 oPage.add(oTextShape)
 oTextShape.TextAutoGrowWidth = TRUE
 oTextShape.TextAutoGrowHeight = TRUE
 oTextShape.String = FileName

 ' Configure Size And Position of the TextShape according to its Scripting
 aPoint.X = iLevelPos(iCurLevel,SBBASEX)
 oTextShape.Position = aPoint
 CreateTextShape() = oTextShape
End Function


Function CalculateXPoint()
 ' The current level Is lower than the Old one
 If (iCurLevel< nOldLevel) And (iCurLevel<> 0) Then
 ' ClearArray(iLevelPos(),iCurLevel+1)
 Elseif iCurLevel= 0 Then
  iLevelPos(iCurLevel,SBBASEX) = SBPAGEX
 ' The current level Is higher than the old one
 Elseif iCurLevel> nOldLevel Then
  iLevelPos(iCurLevel,SBBASEX) = iLevelPos(iCurLevel-1,SBBASEX) + nOldWidth + 100
 End If
 CalculateXPoint = iLevelPos(iCurLevel,SBBASEX)
End Function


Function DrawLine(nLevel, nStartX, nStartY, nEndX, nEndY As Integer, oPage as Object)
Dim oConnect As Object
Dim aPoint As New com.sun.star.awt.Point
Dim aSize As New com.sun.star.awt.Size
 aPoint.X = iLevelPos(nLevel,nStartX)
 aPoint.Y = iLevelPos(nLevel,nStartY)
 aSize.Width = iLevelPos(nLevel,nEndX) - iLevelPos(nLevel,nStartX)
 aSize.Height = iLevelPos(nLevel,nEndY) - iLevelPos(nLevel,nStartY)
 oConnect = oDocument.createInstance("com.sun.star.drawing.LineShape")
 oConnect.Position = aPoint
 oConnect.Size = aSize
 oPage.Add(oConnect)
 DrawLine() = oConnect
End Function


Sub GetSourceDirectory()
 GetFolderName(DlgReadDir.Model.TextField1)
End Sub


Function ReadSourceDirectory(ByVal Source As String)
Dim i as Integer
Dim m as Integer
Dim n as Integer
Dim s as integer
Dim FileName as string
Dim FileNameList(100,1) as String
Dim DirList(0) as String
Dim oUCBobject as Object
Dim DirContent() as String
Dim SystemPath as String
Dim PathSeparator as String
Dim MaxFileIndex as Integer
 PathSeparator = GetPathSeparator()
 oUcbobject = createUnoService("com.sun.star.ucb.SimpleFileAccess")
 m = 0
 s = 0
 DirList(0) = Source
 FileNameList(n,0) = Source
 SystemPath = ConvertFromUrl(Source)
 FileNameList(n,1) = FileNameoutofPath(SystemPath, PathSeparator)
 n = 1
 Do
  Source = DirList(m)
  m = m + 1
  DirContent() = oUcbObject.GetFolderContents(Source,True)
  If Ubound(DirContent()) <> -1 Then
   MaxFileIndex = Ubound(DirContent())
   For i = 0 to MaxFileIndex
    FileName = DirContent(i)
    FileNameList(n,0) = FileName
    SystemPath = ConvertFromUrl(FileName)
    FileNameList(n,1) = FileNameOutofPath(SystemPath, PathSeparator)
    n = n + 1
    If n > Ubound(FileNameList(),1) Then
     ReDim Preserve FileNameList(n + 10,1) as String
    End If
    If oUcbObject.IsFolder(FileName) Then
     s = s + 1
     ReDim Preserve DirList(s) as String
     DirList(s) = FileName
    End If
   Next i
  End If
 Loop Until m > Ubound(DirList())
 ReDim Preserve FileNameList(n-1,1) as String
 ReadSourceDirectory() = FileNameList()
End Function


Sub CloseDialog
 DlgReadDir.EndExecute
End Sub


Sub AdjustPageHeight(lShapeHeight, FileCount)
Dim lNecHeight as Long
Dim lBorders as Long
 oDocument.LockControllers
 lBorders = oPage.BorderTop + oPage.BorderBottom
 lNecHeight = SBPAGEY + (FileCount * SBRELDIST * lShapeHeight)
 If lNecHeight > (oPage.Height - lBorders) Then
  oPage.Height = lNecHeight + lBorders + 500
 End If
 oDocument.UnlockControllers
End Sub


Sub SetNewLevels(FileName as String, BaseLevel as Integer)
 iCurLevel= CountCharsInString(FileName, "/", 1) - BaseLevel
 If iCurLevel <> 0 Then
  nConnectLevel = iCurLevel- 1
 Else
  nConnectLevel = iCurLevel
 End If
 If iCurLevel > Ubound(iLevelPos(),1) Then
  ReDim Preserve iLevelPos(iCurLevel,9) as Long
 End If
End Sub


Sub CheckPageWidth(TextWidth as Long)
Dim PageWidth as Long
Dim BaseX as Long
 PageWidth = oPage.Width
 BaseX = iLevelPos(iCurLevel,SBBASEX)
 If BaseX + TextWidth > PageWidth - 1000 Then
  oPage.Width = 1000 + BaseX + TextWidth
 End If
End Sub


Sub ToggleDialogControls(bDoEnable as Boolean)
 With DlgReadDir.Model
  .cmdGoOn.Enabled = bDoEnable
  .cmdGetDir.Enabled = bDoEnable
  .Label1.Enabled = bDoEnable
  .Label2.Enabled = bDoEnable
  .TextField1.Enabled = bDoEnable
 End With
End Sub</script:module>