LibreOffice Writer / Calc Macro to find text typed in a particular font family and replace it with another

I am using Ubuntu 22.04 and LibreOffice 24.2.0.3. I have a document typed in font Kruti Dev 055, Kruti Dev 011 and so on (Kruti Dev XXX) . There are nearabout hundreds of fonts in the family of Kruti Dev. I have created a find and replace macro which is presently finding text typed in any font and replacing it. I just want the macro should find all text typed in Kruti Dev XXX and replace it with Lohit Devnagari.

Use the Styles instead of the direct formatting method. Then you will able to change all of same formatted properties in one place: in the applied Sytle.

(And never format cell containing constant strings, partially:


| This method is so unmanageable |.


Set the constants cFont and cNewFont to your fonts. And also change the property CharFontName to CharFontNameAsian or CharFontNameComplex in two lines with condition, there is the comment '!!! - I don’t know what is used for Lohit Devanagari etc.

Sub replaceFonts
	dim oDoc as object, oSheet as object, oCur as object, oRange as object, i&, j&, data(), oCell as object, oEnum as object, o as object, oEnum2 as object, o2 as object
	const cFont="Linux" 'part of old font name
	const cNewFont="Liberation Serif" 'new font
	oDoc=ThisComponent
	oSheet=oDoc.CurrentController.ActiveSheet
	rem detect used area
	oCur=oSheet.createCursor
	oCur.goToEndOfUsedArea(false)
	oRange=oSheet.getCellRangeByPosition(0, 0, oCur.RangeAddress.EndColumn, oCur.RangeAddress.EndRow)
	data=oRange.getDataArray
	rem check the cells
	for i=0 to ubound(data) 'rows
		for j=0 to ubound(data(i)) 'columns
			if data(i)(j)<>"" then
				oCell=oSheet.getCellByPosition(j, i)
				oCur=oCell.createTextCursor 'text cursor in cell
				oEnum=oCur.Text.createEnumeration
				o=oEnum.nextElement
				oEnum2=o.createEnumeration
				do while oEnum2.hasMoreElements
					o2=oEnum2.nextElement
					
					rem test the font name
					if inStr(o2.CharFontName, cFont)>0  then '!!! CharFontName / CharFontNameAsian / CharFontNameComplex
						o2.CharFontName=cNewFont '!!! CharFontName / CharFontNameAsian / CharFontNameComplex
					end if
					
				loop
			end if
		next j
	next i
End Sub
1 Like

This macro is working in calc. But in writer it is showing error in the following line.

    oSheet=oDoc.CurrentController.ActiveSheet

Now my further requirement is I had created a find and replace macro and I want that macro to find text typed only in Kruti Dev XXX font and replace the text and change its font to Lohit Devnagari.

I overlooked the label writer, so I wrote macro only for calc :-).

For Writer it can be more complicated if there are the text tables or frames in document. Can you upload example ODT?

Hello Aniruddha,
test this macro, it is lightcore version with repeated F&R for every font that contains the constant cOldFont in its name. So if you will have 100 fonts “Kruti Dev XXX(Kruti Dev 001, Kruti Dev 002 … Krut Devi 100), it will do 100x F&R in document.
Firstly set the constants at the start of macro.

Theoretically it should be possible to create hardcore version → unzip the ODT and do F&R in inner XMLs and then zip back to ODT, but it could be really unsafe to edit the inner XMLs handly.

Sub multireplaceFontsInWriter 'it takes all fonts in Wroter, separate only the fonts that have the cOldFont in name, and repeatedly Find&Replace these old fonts to cNewFont
	on local error goto bug

	rem !!! set these constants !!!
	const cOldFont="Linux" 'part of name of font to replace
	const cNewFont="DejaVu Sans" 'new font
	const cType="CharFontName" ' or "CharFontNameAsian" or "CharFontNameComplex"
	
	
	const cUndo="Replace fonts" 'string for undo manager
	
	dim oDoc as object, oDesc as object, oFound as object, oFontDesc as object, oWindow as object, oFonts as object, undoMgr as object
	dim searchAttr(0) as new com.sun.star.beans.PropertyValue, replAttr(0) as new com.sun.star.beans.PropertyValue
	oDoc=ThisComponent
	oWindow=oDoc.CurrentController.Frame.ContainerWindow
	oFonts=oWindow.FontDescriptors	
	
	on local error resume next 'there could be some unexpected problem with collection
	dim i%, s$, col as new collection
	for i=0 to ubound(oFonts)
		s=oFonts(i).Name 'font name
		rem is old name the part of found font name?
		if InStr(s, cOldFont)>0 then col.add(s, s) 'add the name of found font to collection
	next i
	
	on local error goto bug
	dim aFonts(0 to col.Count-1)
	for i=0 to col.Count-1 'from collection to array
		aFonts(i)=col(i+1)
	next i
	if ubound(aFonts)=-1 then exit sub

	oDoc.lockControllers 'no rendering of screen during replacing
	undoMgr=oDoc.UndoManager
	undoMgr.enterUndoContext(cUndo)
	rem search document for all old fonts
	oDesc=oDoc.createReplaceDescriptor
	searchAttr(0).Name=cType
	replAttr(0).Name=cType
	replAttr(0).Value=cNewFont
	oDesc.setReplaceAttributes(replAttr)
	for i=lbound(aFonts) to ubound(aFonts)
		searchAttr(0).Value=aFonts(i)
		oDesc.setSearchAttributes(searchAttr)
		oDoc.replaceAll(oDesc)
	next i
	undoMgr.leaveUndoContext(cUndo)
	oDoc.unlockControllers
	exit sub
bug:
	if oDoc.hasControllersLocked then oDoc.unlockControllers
	msgbox(Error & chr(13) & "Line: " & Erl & chr(13) & Err & chr(13), 16, "bug")
End Sub
1 Like

2nd version, it checks only the fonts used in document (because there could be fonts in document that aren’t installed in OS)

Sub multireplaceFontsInDocument 'it takes all fonts from Document, separate only the fonts that have the cOldFont in name, and repeatedly Find&Replace these old fonts to cNewFont
	on local error goto bug

	rem !!! set these constants !!!
	const cOldFont="Linux" 'part of name of font to replace
	const cNewFont="DejaVu Sans" 'new font
	const cType="CharFontName" ' or "CharFontNameAsian" or "CharFontNameComplex"
	
	
	const cUndo="Replace fonts" 'string for undo manager
	dim oDoc as object, oDesc as object, oFound as object, undoMgr as object, o as object, i%
	dim searchAttr(0) as new com.sun.star.beans.PropertyValue, replAttr(0) as new com.sun.star.beans.PropertyValue
	oDoc=ThisComponent
	
	rem detect the fonts used in document, source: https://extensions.openoffice.org/en/project/testfonts
	searchAttr(0).Name=cType
	oDesc=oDoc.createSearchDescriptor()
	with oDesc
		.SearchAll=true
		.ValueSearch=false ' true=search for the property; false=search only the occurence of property
		.SearchStyles=false  'find attributes of text including the ones set via Style
		.SetSearchAttributes(searchAttr)
	end with
	oFound=oDoc.findAll(oDesc)
	if oFound.Count=0 then exit sub
	
	rem list of used fonts
	dim aFonts(oFound.Count-1)
	for i=0 to oFound.Count-1
		o=oFound.getByIndex(i)
		aFonts(i)=o.getPropertyValue(cType)
	next i
	
	oDoc.lockControllers 'no rendering of screen during replacing
	undoMgr=oDoc.UndoManager
	undoMgr.enterUndoContext(cUndo)
	rem search document for all old fonts
	oDesc=oDoc.createReplaceDescriptor
	searchAttr(0).Name=cType
	replAttr(0).Name=cType
	replAttr(0).Value=cNewFont
	oDesc.setReplaceAttributes(replAttr)
	for i=lbound(aFonts) to ubound(aFonts)
		searchAttr(0).Value=aFonts(i)
		oDesc.setSearchAttributes(searchAttr)
		oDoc.replaceAll(oDesc)
	next i
	undoMgr.leaveUndoContext(cUndo)
	oDoc.unlockControllers
	exit sub
bug:
	if oDoc.hasControllersLocked then oDoc.unlockControllers
	msgbox(Error & chr(13) & "Line: " & Erl & chr(13) & Err & chr(13), 16, "bug")
End Sub
1 Like

Both the codes work fine. Now further task is to find a particular text typed in any Kruti Dev font and replace it with another text in Lohit Devnagari Font.

I suppose it will be faster only one searching with testing the fontName for each found string.

Sub findAndReplaceWithFonts 'F&R the strings fonted as cOldFont
	on local error goto bug
	const cUndo="F&R in fonts" 'string for undo manager
	dim oDoc as object, oDesc as object, oFound as object, undoMgr as object, o as object, sSearch$, sRepl$

	rem !!! set !!!
	const cOldFont="linux" 'the part of name of font to replace
	const cNewFont="DejaVu Sans" 'new font
	const cType="CharFontName" ' or "CharFontNameAsian" or "CharFontNameComplex"	
	sSearch="ice" 'string to search
	sRepl="PIE" 'replacement
	
	rem search the text
	oDoc=ThisComponent
	oDesc=oDoc.createSearchDescriptor()
	oDesc.SearchString=sSearch 'string to find
	oFound=oDoc.findAll(oDesc)
	if oFound.Count=0 then exit sub 'nothing is found

	oDoc.lockControllers 'no rendering of screen during replacing
	undoMgr=oDoc.UndoManager
	undoMgr.enterUndoContext(cUndo)
	rem test found for fontName and replace
	for each o in oFound
		if InStr(o.getPropertyValue(cType), cOldFont)>0 then 'there is only one fontName in found text that includes cOldFont
			with o
				.setPropertyValue(cType, cNewFont)
				.String=sRepl
			end with
		end if
	next
	
	undoMgr.leaveUndoContext(cUndo)
	oDoc.unlockControllers
	exit sub
bug:
	if oDoc.hasControllersLocked then oDoc.unlockControllers
	msgbox(Error & chr(13) & "Line: " & Erl & chr(13) & Err & chr(13), 16, "bug")
End Sub

What if I have to search hundreds of text strings and replace it. And also I want to change the language of the replaced text to Marathi

For hundreds replacements in one document is becoming the progressbar. There is also oLocaleComplex to set complex language (but I tested it with Arabic).

Sub FindReplComplexFonts 'F&R with Complex font
	on local error goto bug
	const cUndo="F&R in fonts" 'string for undo manager
	dim oDoc as object, oDesc as object, oFound as object, undoMgr as object, o as object, sSearch$, sRepl$, oLocaleComplex as new com.sun.star.lang.Locale, _
	oStatusbar as object, iStep&

	const cType="CharFontNameComplex"

	rem !!! set !!!
	const cOldFont="Amiri" 'the part of complex font name to replace
	const cNewFont="Lohit Devanagari" 'new font		
	with oLocaleComplex 'language: Marathi
		.Country="IN"
		.Language="mr"
	end with
	
	sSearch="فف" 'string to search
	sRepl="ظظ" 'replacement

	rem search the text
	oDoc=ThisComponent
	oDesc=oDoc.createSearchDescriptor()
	oDesc.SearchString=sSearch 'string to find
	oFound=oDoc.findAll(oDesc)
	if oFound.Count=0 then exit sub 'nothing is found

	oDoc.lockControllers 'no rendering of screen during replacing
	undoMgr=oDoc.UndoManager
	undoMgr.enterUndoContext(cUndo)
	oStatusbar=oDoc.CurrentController.StatusIndicator 'show statusbar
	oStatusbar.Start("", oFound.Count)
	oStatusbar.Value=1
	
	rem test found for fontName and replace
	for each o in oFound
		if InStr(o.getPropertyValue(cType), cOldFont)>0 then 'there is only one fontName in found text that includes cOldFont
			with o
				.setPropertyValue(cType, cNewFont)
				.CharLocaleComplex=oLocaleComplex
				.String=sRepl
			end with
		end if
		iStep=iStep+1 'count for statusbar
		if iStep MOD 10=0 then oStatusbar.Value=iStep 'update statusbar after 10 founds
	next
	
	oStatusbar.end
	oStatusbar.reset
	undoMgr.leaveUndoContext(cUndo)
	oDoc.unlockControllers
	exit sub
bug:
	if oDoc.hasControllersLocked then oDoc.unlockControllers
	msgbox(Error & chr(13) & "Line: " & Erl & chr(13) & Err & chr(13), 16, "bug")
End Sub

But if you will need the replacement in more files, are you able to copy all files to one directory?

I have recorded a macro then by using mail merge I placed args1043. I have to find every letter of Kruti Dev font and replace it with another letter of Lohit Devnagari Font. Similarly, I have to find some combination of letters of Kruti Dev font and replace it with some combination of letters of Lohit Devnagari font. Therefore, I need the code for multiple find and replace.

Kruti Dev to Unicode Macro Code.odt (176.5 KB)