Makro:vložení datumu z datového pole

Toto makro umí vložit do libolné buňky na aktuálním listu datum vybraný v datovém poli.Je trochu něco jiného než makro "vložení aktuálního datumu",které se objevilo již v předchozím článku.

Po vytvoření datového pole přes ovládací prvky je třeba ve vlastnostech datového pole upravit na kartě OBECNÉ název,který se musí shodovat s názvem v makru (zvýrazněno červeně) a nebo naopak upravit příkaz select case podle vašeho názvu datového pole.(V ukázkovém souboru "datum1") a příkaz "ROZBALIT"nastavit na ANO.

Na závěr už jen zbývá na kartě UDÁLOSTI přiřadit makro do pole "Uvlněno tlačítko myši" a je hotovo.

Na listu,kde je vytvořené takovéto datové pole klikněte do libovolné buňky,kde chcete zobrazit výdledek a klikněte na datové pole nebo datum vyberte přes rozbalovací seznam....

Makro:

 

REM  *****  BASIC  *****

 

Sub ZapisDatum 'zapise datum zadane datumovym polem do bunky s kurzorem

dim oDoc, oSelect  as object

dim Result, shtname, DatPole as string, sht as integer

 DatPole = "datum1" ' nazev ve vlastnostech datumoveho pole musi souhlasit 

 oDoc = ThisComponent  

 oSelect=oDoc.CurrentSelection.getRangeAddress

 'oBrowser(oDoc.CurrentSelection.getRangeAddress)

 sht=oSelect.Sheet ' index listu s kurzorem

 shtname=oDoc.sheets(sht).name 'jmeno listu

 oDatum = oDoc.Sheets(sht).DrawPage.Forms(shtname).getByName(DatPole) ' odkaz na datumove pole

 'oDatum.HelpText="Zadejte nebo vyberte datum které bude vloženo na místo kurzoru."

 Result= oDatum.text

On Local Error GoTo NODOCUMENTTYPE ' ignoruje chyby - např nesmyslne zadane datum

 ' zapsat do bunky na ktere je kurzor.

 if result <> "" then

  oDoc.sheets(sht).getCellByPosition(oSelect.StartColumn,oSelect.StartRow).Value = dateValue(Result) 

 else

  oDoc.sheets(sht).getCellByPosition(oSelect.StartColumn,oSelect.StartRow).string = ""

 end if 

 exit sub

NODOCUMENTTYPE:

 beep 

End Sub

Prozkoumejte toto makro,třeba se bude někomu někdy hodit.

Ještě se sluší uvést zdroj.Bohužel mám makro již delší dobu uloženo v pc a nevzpomínám si kde jsem ho objevil.Rozhodně není toto makro moje tvorba:)

• Soubor ke stažení ZDE