Fórum pro uživatele kancelářského balíku OpenOffice | LibreOffice
 

#1 20. 2. 2020 20:38:31

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Hromadná komprimace fotografii

Nevíte jak hromadně zmenšit velikost obrázků v calcu. Po jednom to funguje výborně ale když jich jsou stovky ba tisíce...

Asi by to chtělo Makro alá vše zmenšit na px krát px.

Offline

#2 21. 2. 2020 10:30:54

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Co se týká samotné konverze obrázků tak nejsnáze to jde v nějakém programu co umí dávkové zpracování, já na to používám XnView.

Nicméně otázkou je jak dostat tu hromadu obrázků z Calcu a pak zase do Calcu, že :-)?


Po víkendu bych to makro nejspíš zkusil napsat, ostatně není to těžké, ale včera mě zase chytli záda :-(.


Velikost obrázku změníte makrem snadno, viz. ukázka zde
https://forum.openoffice.cz/viewtopic.p … 996#p23996
takže jde jen o to ve smyčce vybrat všechny obrázky a nastavit jim jiné parametry.

Offline

#3 22. 2. 2020 12:33:48

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Tak asi mi nezbude je pomocí makra dostat ven a hromadně mimo zmenšit, a pomocí jiného makra zase dostat zpět. Ale přijde mi to tak trochu nepraktické zvláště když výchozí komprimátor funguje dokonale akorát že po jednom.

Editoval barevnej (22. 2. 2020 12:34:12)

Offline

#4 22. 2. 2020 12:39:46

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Jestli zvládnete makro na export obrázků, resp. jestli zvládnete makrem vybrat každý obrázek, tak pro každý vybraný obrázek namísto exportu jen změníte velikost.
Já bych se k tomu mohl dostat snad již v pondělí, záda se mi zlepšují :-).

Offline

#5 22. 2. 2020 17:37:25

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Upřímně expert nejsem, používám Makra které jsem různě posbíral po netu a moc je upravovat neumím. Toto používám na export všech fotek ven a nahrání jejich jmen do původních buněk.

sub EXPORT_FOTEK
   doc = thiscomponent
   a_url = split(doc.URL, "/")

   GP = createUnoService("com.sun.star.graphic.GraphicProvider")
   dim props(1) as new com.sun.star.beans.PropertyValue
   props(0).Name = "URL"
   props(1).Name = "MimeType"

   for each sheet in doc.Sheets
      drawpage = sheet.DrawPage
      for n = drawpage.Count-1 to 0 step -1
         elem = drawpage.getByIndex(n)
         if elem.supportsService("com.sun.star.drawing.GraphicObjectShape") then
           a_url(ubound(a_url)) =  elem.Name & ".jpg"
           props(0).Value = convertToURL(join(a_url, "/"))
           props(1).Value = elem.Graphic.MimeType
           GP.storeGraphic(elem.Graphic, props)
           on error resume next   'image could be anchored to page
           elem.Anchor.setString(elem.Name)
           drawpage.remove(elem)
         end if      
      next n
   next sheet
   msgbox "done"
end sub

Offline

#6 23. 2. 2020 11:54:45

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Zkuste toto, je to upravené to vaše makro. Neřeší to moc změnu rozměrů buňky ve které je obrázek - byť můžete zkusit odkomentovat zakomentovaný řádek pro změnu výšky buňky dle obrázku, což mi fungovalo dobře pro zvětšování obrázků, avšak nějak to zmenšovalo některé řádky až moc při zmenšování obrázků.

sub ZMENSENI_OBRAZKU 'mělo by zmenšit velikost všech obrázků v dokumentu dle koeficientu iC
	on local error resume next 'při chybě pokračovat dál
	
	const iC=0.5 'koeficient jímž se vynásobí šířka a výška obrázku

	doc = thiscomponent
	for each sheet in doc.Sheets 'pro každý List v dokumentu
		drawpage = sheet.DrawPage
		dim p(drawpage.Count-1)
		for n = drawpage.Count-1 to 0 step -1
			elem = drawpage.getByIndex(n) 'aktuální obrázek
			if elem.supportsService("com.sun.star.drawing.GraphicObjectShape") then		
				oSize=elem.size 'rozměry obrázku
				oSize.width=CLng(oSize.width*iC) 'znásobit šířku obrázku
				oSize.height=CLng(oSize.height*iC) 'znásobit výšku obrázku
				elem.size=oSize 'dát obrázku novou velikost
				rem změna výšky řádku - nějak blbne pro zmenšování řádků
				'elem.anchor.rows.height=oSize.height '+ 100 'nastavit novou výšku řádku
			end if
		next n
	next sheet
	msgbox "hotovo"
end sub

Editoval kamlan (23. 2. 2020 11:54:56)

Offline

#7 24. 2. 2020 10:20:07

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Ono to ale zmenší obrázek vizuálně ale nekomprimuje, naopak nepotřebuji měnit vizuálně ale zmenšit jeho datovovou velikost. Po tomto makru se zmenšil viditelný rozměr ale stále mají obrázky třeba 2000KiB. Pokud dám obrázek ručně komprimovat tak výsledná velikost je třeba jen 5KiB
.
Před makrem
01.png
.
.
Po makru
02.png
.
.
Velikost i po makru zůstala, potřebuji ale komprimovat viz obrázek.
03.png

Offline

#8 24. 2. 2020 16:15:42

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Já to nějak nepřesně pochopil a vyvozoval z toho, že jde jen o tu vizuální velikost, nicméně zkouším tedy kompresi.
Nikde jsem však nenašel makro které by používalo ten komprimační nástroj. Jestli ho někdo má, byl bych za něj rád. Já vím jen UNO příkaz CompressGraphic, ale nehledal jsem k němu parametry; nicméně makro nepoužívající UNO by bylo lepší.


Spusťe makro EXPORT_IMPORT_FOTEK, exportuje vám to ty obrázky a zmenší velikost řádků ve kterých byly a zapíše si do buněk místo obrázků jejich exportované URL. Pak se objeví  hláška Exportováno, nahrát?. NEŽ JI POTVRDÍTE, tak holt v nějakém externím programu zpracujte ty exportované obrázky. Nepřejmenovávajte je však přitom! Pak potvrďte hlášku a mělo by je to naimportovat a přizpůsobit jim i rozměry buněk.

sub EXPORT_IMPORT_FOTEK
	dim GP, p(1000000), i&, s$, sLom$
	sLom="/"
	doc = thiscomponent
	a_url = split(doc.URL, sLom)

	GP = createUnoService("com.sun.star.graphic.GraphicProvider")
	dim props(1) as new com.sun.star.beans.PropertyValue
	props(0).Name = "URL"
	props(1).Name = "MimeType"

	i=0
	for each sheet in doc.Sheets
		drawpage = sheet.DrawPage
		for n = drawpage.Count-1 to 0 step -1
			elem = drawpage.getByIndex(n)
			if elem.supportsService("com.sun.star.drawing.GraphicObjectShape") then
				a_url(ubound(a_url)) =  elem.Name & ".jpg"
				props(0).Value = convertToURL(join(a_url, sLom))
				props(1).Value = elem.Graphic.MimeType
				GP.storeGraphic(elem.Graphic, props)
				on local error resume next   'image could be anchored to page
				s=join(a_url,sLom) 'url obrázku
				elem.Anchor.setString(s)
				p(i)=elem.Anchor
				elem.Anchor.rows.height=10 'NASTAVIT VÝŠKU ŘÁDKU NA MALOU HODNOTU ABY JÍ PAK ZVĚTŠIL DLE VELIKOSTI VLOŽENÉHO OBRÁZKU
				drawpage.remove(elem)
				i=i+1
			end if
		next n
	next sheet
	redim preserve p(i-1)
	if msgbox("Exportováno, nahrát?",20)<>6 then exit sub
	for i=ubound(p()) to lbound(p()) step -1
		o=p(i)
		doc.currentController.select(o)
		insertImagesFromURL(doc.CurrentSelection, 0, 0, sUrl)
	next i
end sub

Rem zdroj https://forum.openoffice.org/en/forum/viewtopic.php?f=9&t=97425#p467351
'Sub specialCaller() 'vloží obrázky vedle vybraných buněk jež obsahují url obrázků
'	theRgURL = ThisComponent.CurrentSelection
'	insertImagesFromURL(theRgURL, 1, 0)
'End Sub

Function focusCell(Optional pCtrl) As Object
	REM Concept by "uros", "Villeroy"
	REM Responsible for this variant: Wolfgang Jäger
	REM 2017-09-28 V0
	If IsMissing(pCtrl) Then pCtrl = ThisComponent.CurrentController
	If  NOT pCtrl.SupportsService("com.sun.star.sheet.SpreadsheetView") Then Exit Function
	Dim theSheet As Object, fC As Object, sheetNum As Long, sInfo As String, sInfoDelim As String
	Dim vD, vDSplit, sInfoSplit
	vD             = pCtrl.ViewData
	vDSplit        = Split(vD, ";")
	theSheet       = pCtrl.ActiveSheet
	sheetNum       = theSheet.RangeAddress.Sheet
	sInfo          = vDSplit(sheetNum + 3)
	REM For CellAddress.Row >= 8192 the "+" is used as the subdelimiter in ViewData. WHY?
	If InStr(sInfo, "+")>0 Then
		sInfoDelim = "+"
	Else
		sInfoDelim = "/"
	End If
	sInfoSplit     = Split(sInfo, sInfoDelim)
	fC             = theSheet.GetCellByPosition(sInfoSplit(0), sInfoSplit(1))
	focusCell      = fC
End Function 

Function getAndCheckRg(Optional pRg As Object, pcO As Long, prO As Long) As Object
	If IsMissing(pRg) Then pRg = ThisComponent.CurrentSelection
	If NOT pRg.supportsService("com.sun.star.sheet.SheetCellRange") Then Exit Function
	theSheet = pRg.Spreadsheet
	mc = theSheet.RangeAddress.EndColumn
	mr = theSheet.RangeAddress.EndRow
	With pRg.RangeAddress
		IF (.StartColumn+pcO>=0) AND (.EndColumn+pcO<=mc) AND _
		(.StartRow   +prO>=0) AND (.EndRow   +prO<=mr) Then
		getAndCheckRg = theSheet.getCellRangeByPosition(.StartColumn+pcO, .StartRow+prO, _
		.EndColumn  +pcO, .EndRow  +prO)
	End If
	End With
End Function

Function _cellInsertImageErr(ByRef pGO As Object, pURL As String, Optional pAnchorCell As Object, Optional pDoc As Object) As String
	_cellInsertImageErr = ":bad:URL:"
	On Local Error Goto leExit
	pURL               = convertToURL(pURL)
	If NOT FileExists(pURL) Then Exit Function
	If IsMissing(pDoc) Then pDoc = ThisComponent
	_cellInsertImageErr = ":bad:model:"
	If NOT pDoc.supportsService("com.sun.star.sheet.SpreadsheetDocument") Then Exit Function
	_cellInsertImageErr = ":unknown:"
	If IsMissing(pAnchorCell) Then pAnchorCell = focusCell(pDoc.CurrentController)
	Dim dispProvider  As Object
	Dim dispHelper    As Object
	cCtrl              = pDoc.CurrentController
	cCtrl.select(pAnchorCell)
	dispProvider       = cCtrl.Frame
	dispHelper         = createUnoService("com.sun.star.frame.DispatchHelper")
	Dim args(1) As New com.sun.star.beans.PropertyValue
	args(0).Name       = "FileName" REM URL
	args(0).Value      = pURL REM Example: "http://www.psilosoph.de/imageForURLdemoPictures/1.jpg"
	args(1).Name       = "AsLink"
	args(1).Value      = False
	cellInsertImageErr = ":bad:content:"
	dispHelper.executeDispatch(dispProvider, ".uno:InsertGraphic", "", 0, args())
	dp = pAnchorCell.Spreadsheet.DrawPage
	uS = dp.Count - 1
	pGO = dp(uS)
	_cellInsertImageErr = ""
leExit:
End Function

Sub insertImagesFromURL(Optional pRgURL As Object, pColOffset As Long, pRowOffset As Long)
	Const maxEL     As Long = 15000 'unit 1/100 mm
	'Const mm100thPx As Long = 20    '20/100 mm per Pixel
	doc0 = ThisComponent
	If IsMissing(pRgURL) THen pRgURL = ThisComponent.CurrentSelection
	theRgGr  = getAndCheckRg(pRgURL, pColOffset, pRowOffset)
	If IsNull(theRgGr) Then Exit Sub
	theSheet = theRgGr.Spreadsheet
	theDP    = theSheet.DrawPage
	uC = pRgURL.Columns.Count - 1
	uR = pRgURL.Rows.Count - 1
	Dim maxWidth As Long, maxHeight(uR) As Long
	For j = 0 To uR
		maxHeight(j) = theRgGr.Rows(j).Height
	Next j
	For c = 0 To uC
		maxWidth = theRgGr.Columns(c).Width
		For r = 0 To uR
			theCellURL = pRgURL.getCellByPosition(c, r)
			theCellGr  = theRgGr.getCellByPosition(c, r)
			If theCellURL.FormulaResultType=2 Then
				theURL = convertToURL(theCellURL.String)
				theCellURL.string="" 'SMAZAT URL OBRÁZKU Z BUŇKY
				ReDim gobj As Object
				Select Case _cellInsertImageErr(gobj, theURL, theCellGr, doc0)
				Case ""
					sz = gobj.Size
					With sz
						f       = maxEL / .Height
						fWidth  = maxEL / .Width
						If fWidth<f Then f = fWidth
						If f<1      Then
							.Height = .Height * f
							.Width  = .Width  * f
						End If
						If .Width>maxWidth      Then maxWidth     = .Width
						If .Height>maxHeight(r) Then maxHeight(r) = .Height
						gobj.Size = sz
					End With
				Case Else
					REM nothing implmented yet.
				End Select
			Else
			End If
		Next r
		theRgGr.Columns(c).Width = maxWidth
	Next c
	For j = 0 To uR
		theRgGr.Rows(j).Height = maxHeight(j)
	Next j
	doc0.CurrentController.select(pRgURL)
End Sub

Editoval kamlan (24. 2. 2020 16:44:32)

Offline

#9 25. 2. 2020 09:43:07

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

chyba01.png

Offline

#10 25. 2. 2020 10:05:50

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

To sUrl je tam z mého rychlého pokusu o alespoň nějakou optimalizaci který jsem ale pak rychle vzdal :-). Při testování mi to šlo, ale asi vznikla chyba když jsem smolil odpověď na fórum a měl již překopírovaný kód, nejspíš to byl předchozí kód ze kterého jsem to nesmazal.


Správně je ten řádek tedy bez sUrl

insertImagesFromURL(doc.currentSelection,0,0)

Offline

#11 25. 2. 2020 10:12:23

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Furt se mu to nějak nelíbí. Je fakt že jsem měl třeba makra v LO 6.2 a fungovala i když tam třeba nebyly uzavřené závorky a od 6.4 mi chyby neodpouští a musel jsem to opravit. Tady ovšem nevím jak to opravit.

chyba02.png

Offline

#12 25. 2. 2020 10:17:59

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Stahuji 6.4.1.2, zkusím to v tom

Offline

#13 25. 2. 2020 10:41:11

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Já mám teda 6.4.0 ale snad to bude stejné.

Offline

#14 25. 2. 2020 11:00:39

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

V 6.4.1.2 (Win10 x64) chodí. Hláška "chyba v syntaxi" ale ukazuje nejspíš na to, že je něco špatně zapsaného v kódu, nikoliv že se až někde špatně vykonal kód. Měla by se též objevit když se dá v Basic Editoru z menu Spustit/ Zkompilovat.


Mě se tohle párkrát stalo, když jsem přepnul na arabskou klávesnici a někam zmáčkl třeba nějakou arabskou samohlásku která v tom Basicu osamělá v latinkovém kódu není vidět, pak to pořád psalo nějakou podobnou chybu a já až po nějaké době přišel na to, že tam je "neviditelný" arabský znak. Ale asi 4 dny jsem s arabštinou vůbec nic nedělal, takže by kód měl být čistý, jinak by mi tady nefungoval.


Ještě je občas chyba když se ty makra nahrají do nějakého modulu ve kterém jsou definované globální proměnné, které mají stejný název jako proměnné v makru, to se pak také může prát. Proto tam mám hned ze začátku třeba dim GP, neboť v pokusném modulu už jsem měl globální proměnnou gP a nechtělo se mi zrovna nějak vytvářet pro úlohu která vypadala jednoduše další modul. Nicméně možná by si to zasloužilo namísto splácání z různých maker udělat pořádně - ono jak to je tak by taky mohl přizpůsobit šířku celého sloupce nejužšímu obrázku když ten bude poslední. No uvidíme.


Připojuji pro jistotu znovu kód těch funkcí, přidal jsem tam chybová hlášení. Možná to bude blbnout když bude nějaký obrázek ukotven ke stránce a nikoliv k buňce, to bylo poznamenáno v tom exportním makru, to by pak místo počátečního řádku on local error goto chyba bylo původní on local error resume next.

sub EXPORT_IMPORT_FOTEK
	'on local error resume next 'původní ošetření chyb - pokračovat při chybě dál
	on local error goto chyba
	dim GP, p(1000000), i&, s$, sLom$
	sLom="/"
	doc = thiscomponent
	a_url = split(doc.URL, sLom)

	GP = createUnoService("com.sun.star.graphic.GraphicProvider")
	dim props(1) as new com.sun.star.beans.PropertyValue
	props(0).Name = "URL"
	props(1).Name = "MimeType"

	i=0
	for each sheet in doc.Sheets
		drawpage = sheet.DrawPage
		for n = drawpage.Count-1 to 0 step -1
			elem = drawpage.getByIndex(n)
			if elem.supportsService("com.sun.star.drawing.GraphicObjectShape") then
				a_url(ubound(a_url)) =  elem.Name & ".jpg"
				props(0).Value = convertToURL(join(a_url, sLom))
				props(1).Value = elem.Graphic.MimeType
				GP.storeGraphic(elem.Graphic, props)
				s=join(a_url,sLom) 'url obrázku
				elem.Anchor.setString(s)
				p(i)=elem.Anchor
				elem.Anchor.rows.height=10 'NASTAVIT VÝŠKU ŘÁDKU NA MALOU HODNOTU ABY JÍ PAK ZVĚTŠIL DLE VELIKOSTI VLOŽENÉHO OBRÁZKU
				drawpage.remove(elem)
				i=i+1
			end if
		next n
	next sheet
	redim preserve p(i-1)
	if msgbox("Exportováno, nahrát?",20)<>6 then exit sub
	for i=ubound(p()) to lbound(p()) step -1
		o=p(i)
		doc.currentController.select(o)
		insertImagesFromURL(doc.CurrentSelection, 0, 0)
	next i
	exit sub
chyba:
	msgbox ("Chyba!" & chr(13) & "kód: " & Err & chr(13) & Error & chr(13) & "řádek: " & Erl,16)
end sub

Rem zdroj https://forum.openoffice.org/en/forum/viewtopic.php?f=9&t=97425#p467351

'Sub specialCaller() 'vloží obrázky vedle vybraných buněk jež obsahují url obrázků
'	theRgURL = ThisComponent.CurrentSelection
'	insertImagesFromURL(theRgURL, 1, 0)
'End Sub

Function focusCell(Optional pCtrl) As Object
	REM Concept by "uros", "Villeroy"
	REM Responsible for this variant: Wolfgang Jäger
	REM 2017-09-28 V0
	If IsMissing(pCtrl) Then pCtrl = ThisComponent.CurrentController
	If  NOT pCtrl.SupportsService("com.sun.star.sheet.SpreadsheetView") Then Exit Function
	Dim theSheet As Object, fC As Object, sheetNum As Long, sInfo As String, sInfoDelim As String
	Dim vD, vDSplit, sInfoSplit
	vD             = pCtrl.ViewData
	vDSplit        = Split(vD, ";")
	theSheet       = pCtrl.ActiveSheet
	sheetNum       = theSheet.RangeAddress.Sheet
	sInfo          = vDSplit(sheetNum + 3)
	REM For CellAddress.Row >= 8192 the "+" is used as the subdelimiter in ViewData. WHY?
	If InStr(sInfo, "+")>0 Then
		sInfoDelim = "+"
	Else
		sInfoDelim = "/"
	End If
	sInfoSplit     = Split(sInfo, sInfoDelim)
	fC             = theSheet.GetCellByPosition(sInfoSplit(0), sInfoSplit(1))
	focusCell      = fC
End Function 

Function getAndCheckRg(Optional pRg As Object, pcO As Long, prO As Long) As Object
	If IsMissing(pRg) Then pRg = ThisComponent.CurrentSelection
	If NOT pRg.supportsService("com.sun.star.sheet.SheetCellRange") Then Exit Function
	theSheet = pRg.Spreadsheet
	mc = theSheet.RangeAddress.EndColumn
	mr = theSheet.RangeAddress.EndRow
	With pRg.RangeAddress
		IF (.StartColumn+pcO>=0) AND (.EndColumn+pcO<=mc) AND _
		(.StartRow   +prO>=0) AND (.EndRow   +prO<=mr) Then
		getAndCheckRg = theSheet.getCellRangeByPosition(.StartColumn+pcO, .StartRow+prO, _
		.EndColumn  +pcO, .EndRow  +prO)
	End If
	End With
End Function

Function _cellInsertImageErr(ByRef pGO As Object, pURL As String, Optional pAnchorCell As Object, Optional pDoc As Object) As String
	_cellInsertImageErr = ":bad:URL:"
	On Local Error Goto leExit
	pURL               = convertToURL(pURL)
	If NOT FileExists(pURL) Then Exit Function
	If IsMissing(pDoc) Then pDoc = ThisComponent
	_cellInsertImageErr = ":bad:model:"
	If NOT pDoc.supportsService("com.sun.star.sheet.SpreadsheetDocument") Then Exit Function
	_cellInsertImageErr = ":unknown:"
	If IsMissing(pAnchorCell) Then pAnchorCell = focusCell(pDoc.CurrentController)
	Dim dispProvider  As Object
	Dim dispHelper    As Object
	cCtrl              = pDoc.CurrentController
	cCtrl.select(pAnchorCell)
	dispProvider       = cCtrl.Frame
	dispHelper         = createUnoService("com.sun.star.frame.DispatchHelper")
	Dim args(1) As New com.sun.star.beans.PropertyValue
	args(0).Name       = "FileName" REM URL
	args(0).Value      = pURL REM Example: "http://www.psilosoph.de/imageForURLdemoPictures/1.jpg"
	args(1).Name       = "AsLink"
	args(1).Value      = False
	cellInsertImageErr = ":bad:content:"
	dispHelper.executeDispatch(dispProvider, ".uno:InsertGraphic", "", 0, args())
	dp = pAnchorCell.Spreadsheet.DrawPage
	uS = dp.Count - 1
	pGO = dp(uS)
	_cellInsertImageErr = ""
leExit:
End Function

Sub insertImagesFromURL(Optional pRgURL As Object, pColOffset As Long, pRowOffset As Long)
	on local error goto chyba
	Const maxEL     As Long = 15000 'unit 1/100 mm
	'Const mm100thPx As Long = 20    '20/100 mm per Pixel
	doc0 = ThisComponent
	If IsMissing(pRgURL) Then pRgURL = ThisComponent.CurrentSelection
	theRgGr  = getAndCheckRg(pRgURL, pColOffset, pRowOffset)
	If IsNull(theRgGr) Then Exit Sub
	theSheet = theRgGr.Spreadsheet
	theDP    = theSheet.DrawPage
	uC = pRgURL.Columns.Count - 1
	uR = pRgURL.Rows.Count - 1
	Dim maxWidth As Long, maxHeight(uR) As Long
	For j = 0 To uR
		maxHeight(j) = theRgGr.Rows(j).Height
	Next j
	For c = 0 To uC
		maxWidth = theRgGr.Columns(c).Width
		For r = 0 To uR
			theCellURL = pRgURL.getCellByPosition(c, r)
			theCellGr  = theRgGr.getCellByPosition(c, r)
			If theCellURL.FormulaResultType=2 Then
				theURL = convertToURL(theCellURL.String)
				theCellURL.string="" 'SMAZAT URL OBRÁZKU Z BUŇKY
				ReDim gobj As Object
				Select Case _cellInsertImageErr(gobj, theURL, theCellGr, doc0)
				Case ""
					sz = gobj.Size
					With sz
						f       = maxEL / .Height
						fWidth  = maxEL / .Width
						If fWidth<f Then f = fWidth
						If f<1      Then
							.Height = .Height * f
							.Width  = .Width  * f
						End If
						If .Width>maxWidth      Then maxWidth     = .Width
						If .Height>maxHeight(r) Then maxHeight(r) = .Height
						gobj.Size = sz
					End With
				Case Else
					REM nothing implmented yet.
				End Select
			Else
			End If
		Next r
		theRgGr.Columns(c).Width = maxWidth
	Next c
	For j = 0 To uR
		theRgGr.Rows(j).Height = maxHeight(j)
	Next j
	doc0.CurrentController.select(pRgURL)
	exit sub
chyba:
	msgbox ("Chyba!" & chr(13) & "kód: " & Err & chr(13) & Error & chr(13) & "řádek: " & Erl,16)
End Sub

Offline

#15 25. 2. 2020 11:09:14

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Stále stejná chyba a hodí to tu chybu syntaxe 4x za sebou. Nemohl by jsem poprosit o vzorovou tabulku na které to testujete? Třeba je problém v názvu listu nebo že některé fotky nejsou jpg ale třeba i png... Asi bych to z vzorového souboru uměl odvodit.

Offline

#16 25. 2. 2020 11:15:35

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Aha funguje to, musel jsem smazat všechny ostatní makra co tam mám. Jen ještě poladit tu velikost jelikož to pak změní tu velikost řádků což není žádoucí. Jde to nějak vypnout aby to neměnilo velikost řádků?

Editoval barevnej (25. 2. 2020 11:32:53)

Offline

#17 25. 2. 2020 11:29:31

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Dělám pokusy, vše jsem zmenšil v průběhu makra na výšku 75px ale v reálu jsou importované fotky různě jinak vysoké, skoro jako by to vypočítávalo výšku řádku z šířky obrázku.
pokus1.png

Nešlo by aby vzal výšku obrázku a ze zhora a třeba i ze spoda přidal 5px aby nebyla fotka tak nalepená na spodní a vrchní buňce. Doprostřed vycentrovat to zvládnu to je hračka.
Predstava_01.png

Offline

#18 25. 2. 2020 11:36:23

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Jinak teda export proběhne v pořádku a chyba je až po potvrzení exportní hlášky? Nebo to hlásí 4x chybu při kompilaci?

Aby tam při exportu nebyly třeba chyby v té zapsané URL ze které se pak snaží importovat - když jste na linuxu a já win, nebo problémy s diakritikou v názvech souborů. Pro tohle lze zakomentovat řádek 27 elem.Anchor.rows.height=10, tím se nezmenší řádky po exportu obrázků a budou v nich vidět url obrázků které se bude snažit importovat.

Zde je testovací soubor
https://uloz.to/file/ztndhGYKBBZg/calc- … ku-kl1-ods


Kdyžtak nasdílejte i tu vaší ukázku, zkusil bych to s ní.

Offline

#19 25. 2. 2020 11:42:50

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Takže tedy chodí :-). Zřejmě se tam praly nějaké názvy funkcí či proměnných s jinými makry. Na tohle je fakt dobrá volba option explicit. Takže jdu zkoušet tu výšku řádků, ale musím to více předělat ať je to tedy pořádně :-), takhle to bylo fakt v podstatě splácnutí ze dvou fór. Čili je to na dýl takže možná až zítra, uvidím jak se bude dařit.

Editoval kamlan (25. 2. 2020 11:43:34)

Offline

#20 25. 2. 2020 12:17:09

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Tak bohužel pořádně nechápu jak tam autor počítá tu výšku řádku či šířku sloupce, dělá to nějak přes pole a hledá nejvyšší hodnoty - neb jak to má univerzální na celý Sešit tak zřejmě počítá s tím, že v řádku mohou být různě vysoké obrázky stejně jako ve sloupci že mohou být různě široké obrázky. Na tom přizpůsobování výšek/šířek jsem se zasekl před pár dny a pro zmenšování buněk mi to blblo - a jak tak vidím, nejsem o moc chytřejší. Čili nezbývá než dále nějaká ta částečná prasizace splácnutého kódu, neboť vidím, že předělání by mohlo být taky na vícero dní než bych tomu všemu fakt porozuměl a to tomu obětovat nemohu.


Takže uvádím jedinou změněnou proceduru, je tam na začátku konstanta iVyska která by měla ke každému řádku přidat nějaké to odsazení na výšku, ale jak se to přepočítává na pixely nevím, tudíž potřebnou hodnotu budete asi muset vyzkoušet.


Mimochodem jak centrujete ty obrázky doprostřed? Mě to nešlo, zkoušel jsem svislé centrování obsahu buňky a nic.

Sub insertImagesFromURL(Optional pRgURL As Object, pColOffset As Long, pRowOffset As Long)
	const iVyska as long = 200 'o kolik zvýšit výšku řádku oproti obrázku
	on local error goto chyba
	Const maxEL     As Long = 15000 'unit 1/100 mm
	'Const mm100thPx As Long = 20    '20/100 mm per Pixel
	doc0 = ThisComponent
	If IsMissing(pRgURL) Then pRgURL = ThisComponent.CurrentSelection
	theRgGr  = getAndCheckRg(pRgURL, pColOffset, pRowOffset)
	If IsNull(theRgGr) Then Exit Sub
	theSheet = theRgGr.Spreadsheet
	theDP    = theSheet.DrawPage
	uC = pRgURL.Columns.Count - 1
	uR = pRgURL.Rows.Count - 1
	Dim maxWidth As Long, maxHeight(uR) As Long
	For j = 0 To uR
		maxHeight(j) = theRgGr.Rows(j).Height
	Next j
	For c = 0 To uC
		maxWidth = theRgGr.Columns(c).Width
		For r = 0 To uR
			theCellURL = pRgURL.getCellByPosition(c, r)
			theCellGr  = theRgGr.getCellByPosition(c, r)
			If theCellURL.FormulaResultType=2 Then
				theURL = convertToURL(theCellURL.String)
				theCellURL.string="" 'SMAZAT URL OBRÁZKU Z BUŇKY
				ReDim gobj As Object
				Select Case _cellInsertImageErr(gobj, theURL, theCellGr, doc0)
				Case ""
					sz = gobj.Size
					With sz
						f       = maxEL / .Height
						fWidth  = maxEL / .Width
						If fWidth<f Then f = fWidth
						If f<1      Then
							.Height = .Height * f
							.Width  = .Width  * f
						End If
						If .Width>maxWidth      Then maxWidth     = .Width
						If .Height>maxHeight(r) Then maxHeight(r) = .Height
						gobj.Size = sz
					End With
				Case Else
					REM nothing implmented yet.
				End Select
			Else
			End If
		Next r
		theRgGr.Columns(c).Width = maxWidth
	Next c
	For j = 0 To uR
		theRgGr.Rows(j).Height = maxHeight(j) + iVyska 'přidat odsazení k výšce řádku
	Next j
	doc0.CurrentController.select(pRgURL)
	exit sub
chyba:
	msgbox ("Chyba!" & chr(13) & "kód: " & Err & chr(13) & Error & chr(13) & "řádek: " & Erl,16)
End Sub

Offline

#21 25. 2. 2020 12:21:11

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Ještě co se týká různé výšky obrázků tak ono záleží i na velikosti DPI toho každého obrázku, s čímž může být též problém a nevím jak ošetřit případná různá DPI.

Offline

#22 25. 2. 2020 13:45:17

kamlan
Člen
Registrace: 15. 9. 2016
Příspěvků: 209

Re: Hromadná komprimace fotografii

Uf, už se mi plete to exportní makro s tím importním. To importní není pro celý Sešit ale pro daný výběr. A ono to importní makro přepočítává výšky a šířky buněk pro zvolený výběr buněk -> a problém je v tom, že já počítal s exportem pro celý Sešit ale ten import není dělaný univerzálně pro celý sešit nýbrž jen pro výběr buněk. Takže správně by mělo být označit všechny buňky do kterých se bude importovat a ten celý výběr předat importnímu makru -> jenže já to v rámci vývoje zjednodušil a označuji pouze vždy jednu buňku, do ní se importuje obrázek a přizpůsobí se velikost buňky; pak se označí další buňka a opět import a změna velikosti buňky -> no a to může způsobovat že pokud bude následující obrázek užší než předchozí, tak se šířka sloupce zmenší podle toho následujícího + to samé to to bude dělat s řádky kdy to bude zmenšovat výšku řádku bude-li následující importovaný obrázek nižší.


Kdyby vám stačilo makro které nebude exportovat z celého dokumentu (jako to vaše exportní), ale jen obrázky z vybraných buněk v jednom sloupci (jednoduchý souvislý výběr v jednom sloupci, žádné multivýběry přes Ctrl) + pro import o nějakou tu konstantu zvětší výšku řádku dle výšky importovaného obrázku, tak by to s tím co již teď umím bylo o dost jednodušší.

Offline

#23 25. 2. 2020 15:05:39

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Je to čím dál lepší, upřímně kdyby to vůbec neměnilo výšku řádku ale prostě jen obrázek vložilo bez ohledu na jeho velikost čily 1:1 tak by to bylo lepší.

kamlan napsal(a)

Mimochodem jak centrujete ty obrázky doprostřed? Mě to nešlo, zkoušel jsem svislé centrování obsahu buňky a nic.

Normálně ručně smile)) Prostě vyberu jeden obrázek a pak Ctrl+A a Formát > Zarovnání > Na střed. Já vím není to moc profi postup ale je to snadné.

Offline

#24 25. 2. 2020 15:19:00

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

kamlan napsal(a)

Ještě co se týká různé výšky obrázků tak ono záleží i na velikosti DPI toho každého obrázku, s čímž může být též problém a nevím jak ošetřit případná různá DPI.

Koukám že tady je taky zakopanej pes... Testuji

Offline

#25 25. 2. 2020 16:08:20

barevnej
Člen
Registrace: 6. 8. 2015
Příspěvků: 75

Re: Hromadná komprimace fotografii

Tak aby se neměnila výška řádku by mi šlo upravit. Jak ale vyřešit to dpi netuším. Hledám jak rovnou při importu nastavit že obrázek se má nastavit třeba na "height 75px" bez ohledu na to jaká je ralita

Offline

Zápatí