Hier http://de.openoffice.info/viewtopic.php?t=65995 wurde ein Calc Makro veröffentlicht, mit dem man einen Begriff x in einer Calc-Tabelle suchen kann und das dann alle Fundzeilen in Blatt x des aktiven Sheets schreibt.
Ich möchte dieses Makro so abändern, dass die Ausgabe nicht in ein neues Sheet (Blatt) DERSELBEN Calc-Tabelle schreibt, sondern in Blatt x eines NEUEN Calc-Dokumentes.
(Grund: Das veröffentlichte Makro funktioniert zwar gut, aber ich will das Blatt mit den Suchergebnissen hinterher löschen und nicht unbeabsichtigt ein falsches Blatt dieses aktiven Dokumentes.)
Folgendermaßen habe ich das Makro abgeändert - und jeweils die ersetzten Zeilen des Makros auskommentiert (s. Code unten).
Im neuen Calc-Dokument wird zwar das Blatt für die gefundenen Ergebnisse erzeugt, jedoch bleibt das Blatt leer
Könnte bitte jemand mit besseren Skills als ich, mal checken, warum nichts ins neue Blatt geschrieben wird ?
Vielen Dank !
Hier der Makro-Code:
Code: Alles auswählen
sub FindeStringKopiereFundzeile
oCalc = ThisComponent
oSheet = oCalc.CurrentSelection.Spreadsheet
Dim oDialog as object
Dim iDlgOK as integer
Dim oTargetFile As Object '--
Dim oTargetSheet As Object '--
Dim sFilePath As String '--
' Set the file path
sFilePath = "file:///C:/Users/GHL/Downloads/TargetFile.ods" '--
' Open the target file
oTargetFile = StarDesktop.loadComponentFromURL(sFilePath, "_blank", 0, Array()) '--
DialogLibraries.loadLibrary( "Standard")
oDialogLib = DialogLibraries.getByName("Standard")
oDialog = CreateUnoDialog(oDialogLib.getByName("Dialog1"))
iDlgOK = oDialog.Execute()
if iDlgOK = 1 then
bHL = oDialog.Model.CheckBox1.state
Sel = oDialog.Model.CheckBox2.state
myString = oDialog.GetControl("TextField1").Text
end if
oDialog.dispose()
if Len(myString) = 0 then exit sub
oCalc.lockcontrollers
mAllText = split(myString,";")
for i=0 to uBound(mAllText)
result = FindeAlle( mAllText(i), Sel)
if result(0) = "-" then
mAllText(i) = mAllText(i) & " - nicht gefunden, keine weitere Aktion"
goto jumpover
else
ix=1
newTable = mAllText(i)
'do while oCalc.Sheets.hasByName(newTable)
do while oTargetFile.Sheets.hasByName(newTable)
ix = ix+1
newTable = mAllText(i) & "(" & ix &")"
'if oCalc.Sheets.count > 255 then
if oTargetFile.Sheets.count > 255 then
msgbox "zu viele Tabellenblätter"
exit sub
endif
loop
'Sheet=oCalc.createInstance("com.sun.star.sheet.Spreadsheet")
'oCalc.Sheets.insertByName(newTable, sheet)
TargetSheet = oTargetFile.createinstance("com.sun.star.sheet.Spreadsheet")
oTargetFile.Sheets.insertByName(newTable, TargetSheet)
endif
if bHL = 1 then
'oSheet2 = oCalc.Sheets.getByName(newTable)
oSheet2 = oTargetFile.Sheets.getByName(newTable)
oSourceRange = oSheet.getCellRangeByPosition(0,0,1023,0)
oSourceRangeAddresse = oSourceRange.getRangeAddress
oTarget = oSheet2.getCellByPosition(0,0)
oTargetCellAdresse = oTarget.getCellAddress
oSheet2.copyRange(oTargetCellAdresse,oSourceRangeAddresse)
end if
for iR = 0 to uBound(result)
'oSheet2 = oCalc.Sheets.getByName(newTable)
oSheet2 = oTargetFile.Sheets.getByName(newTable)
oSourceRange = oSheet.getCellRangeByPosition(0,result(ir),1023,result(iR))
oSourceRangeAddresse = oSourceRange.getRangeAddress
oTarget = oSheet2.getCellByPosition(0,iR+1)
oTargetCellAdresse = oTarget.getCellAddress
oSheet2.copyRange(oTargetCellAdresse,oSourceRangeAddresse)
oSheet2.Columns.OptimalWidth = True
next
jumpover:
next
oCalc.unlockcontrollers
end sub
'==============================================================================
function FindeAlle (sText$, iSel )
SFlag = 71696
rem ----------------------------------------------------------------------
rem define variables
dim document as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
if iSel = 0 then
SFlag = 65552
rem ----------------------------------------------------------------------
dim args1(0) as new com.sun.star.beans.PropertyValue
args1(0).Name = "Sel"
args1(0).Value = false
dispatcher.executeDispatch(document, ".uno:GoToStart", "", 0, args1())
endif
rem ----------------------------------------------------------------------
dim args2(17) as new com.sun.star.beans.PropertyValue
args2(0).Name = "SearchItem.StyleFamily"
args2(0).Value = 2
args2(1).Name = "SearchItem.CellType"
args2(1).Value = 0
args2(2).Name = "SearchItem.RowDirection"
args2(2).Value = true
args2(3).Name = "SearchItem.AllTables"
args2(3).Value = false
args2(4).Name = "SearchItem.Backward"
args2(4).Value = false
args2(5).Name = "SearchItem.Pattern"
args2(5).Value = false
args2(6).Name = "SearchItem.Content"
args2(6).Value = false
args2(7).Name = "SearchItem.AsianOptions"
args2(7).Value = false
args2(8).Name = "SearchItem.AlgorithmType"
args2(8).Value = 0
args2(9).Name = "SearchItem.SearchFlags"
args2(9).Value = SFlag '71696 ' 65552 '
args2(10).Name = "SearchItem.SearchString"
args2(10).Value = sText
args2(11).Name = "SearchItem.ReplaceString"
args2(11).Value = ""
args2(12).Name = "SearchItem.Locale"
args2(12).Value = 255
args2(13).Name = "SearchItem.ChangedChars"
args2(13).Value = 2
args2(14).Name = "SearchItem.DeletedChars"
args2(14).Value = 2
args2(15).Name = "SearchItem.InsertedChars"
args2(15).Value = 2
args2(16).Name = "SearchItem.TransliterateFlags"
args2(16).Value = 1024
args2(17).Name = "SearchItem.Command"
args2(17).Value = 1
dispatcher.executeDispatch(document, ".uno:ExecuteSearch", "", 0, args2())
oCalc = thisComponent
Selected = oCalc.CurrentSelection
if Selected.supportsService("com.sun.star.sheet.SheetCell" ) then
dim eRow(0)
eRow(0) = Selected.CellAddress.Row
if Selected.String = sText then
FindeAlle = eRow()
else
eRow(0) = "-"
FindeAlle = eRow()
endif
end if
if Selected.supportsService("com.sun.star.sheet.SheetCellRanges" ) then
nR = uBound(Selected.RangeAddresses())
dim xRows(nR) as String
for i=0 to nR
xRows(i) = Selected.rangeAddresses(i).StartRow
next
FindeAlle = xRows()
end if
end function
sub FindeAlleSelection
rem ----------------------------------------------------------------------
rem define variables
dim document as object
dim dispatcher as object
rem ----------------------------------------------------------------------
rem get access to the document
document = ThisComponent.CurrentController.Frame
dispatcher = createUnoService("com.sun.star.frame.DispatchHelper")
rem ----------------------------------------------------------------------
dim args1(17) as new com.sun.star.beans.PropertyValue
args1(0).Name = "SearchItem.StyleFamily"
args1(0).Value = 2
args1(1).Name = "SearchItem.CellType"
args1(1).Value = 0
args1(2).Name = "SearchItem.RowDirection"
args1(2).Value = true
args1(3).Name = "SearchItem.AllTables"
args1(3).Value = false
args1(4).Name = "SearchItem.Backward"
args1(4).Value = false
args1(5).Name = "SearchItem.Pattern"
args1(5).Value = false
args1(6).Name = "SearchItem.Content"
args1(6).Value = false
args1(7).Name = "SearchItem.AsianOptions"
args1(7).Value = false
args1(8).Name = "SearchItem.AlgorithmType"
args1(8).Value = 0
args1(9).Name = "SearchItem.SearchFlags"
args1(9).Value = 71696
args1(10).Name = "SearchItem.SearchString"
args1(10).Value = "Frank"
args1(11).Name = "SearchItem.ReplaceString"
args1(11).Value = ""
args1(12).Name = "SearchItem.Locale"
args1(12).Value = 255
args1(13).Name = "SearchItem.ChangedChars"
args1(13).Value = 2
args1(14).Name = "SearchItem.DeletedChars"
args1(14).Value = 2
args1(15).Name = "SearchItem.InsertedChars"
args1(15).Value = 2
args1(16).Name = "SearchItem.TransliterateFlags"
args1(16).Value = 1280
args1(17).Name = "SearchItem.Command"
args1(17).Value = 1
dispatcher.executeDispatch(document, ".uno:ExecuteSearch", "", 0, args1())
end sub