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
)) 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é.