Příklady PASCAL

Příklady programů ve skriptovacím programovacím jazyku v jazyku Pascal.

Příklad 1 - práce s proměnnými uloženými do databáze

var i: integer;
    s: String;
begin
 s:=IniReadString('ScriptTest', 1, True, _AktualniSklad_, '5');
 ShowMessage(Settings.Values['INI.FirmaJmeno']+chr(13)+Settings.Values['USER.JmenoUziv']+chr(13)+_KonfigDir_);
 LogWrite('Direktivy:'+_Direktivy_);
 if s <> '' then
   i := StrToInt(s)+1
 else
   i := -10;
 if not IniWriteInteger('ScriptTest', 1, True, _AktualniSklad_, i) then
   ShowMessage('V IniWriteInteger se vyskytla chyba');
end.

---

Příklad 2 - spuštění sestavy z generátoru sestav

var 
 s: String; 
 d1, d2: TDateTime; 
 DD, MM, YY : word; 
begin 
 DecodeDate(Date, YY, MM, DD); 
 if MM=1 then begin // Zjisteni predchoziho mesice 
   MM := 12; 
   YY := YY - 1; 
 end else 
   MM := MM - 1; 
 D1 := EncodeDate(YY, MM, 1); 
 D2 := EncodeDate(YY, MM, DaysInMonth(YY, MM)); 
 S := GSRunReport(6, 1, 'KFG_Datum1='+StrDate(D1)+chr(13)+ 'KFG_Datum='+StrDate(D2)+chr(13)+ 'INI_Jmeno=Pokusný sklad');
 //S := GSRunReportV(6, 1, ['KFG_Datum1', 'KFG_Datum', 'INI_Jmeno'],[StrDate(D1), StrDate(D2), 'Pokusný sklad']);
 
 if EnumStr(S, 0, #13)='OK' then
   ShowMessage('Výpočet OK, výsledek sestavy je v '+EnumStr(S, 1, #13))
 else
   ShowMessage(S)
end. 

---

Příklad 3 - odeslání mailu s přílohou pomocí SMTP

var 
 s: String; 
begin 
//From, SendTo, FileAttach, Subject, SMTPServer, SMTPSenderName, SMTPPassword, BodyString, ErrMessage 
  if SendMailBySMTP('odesilatel@posta.cz', 'prijemce@mail.com', 'UZIV\SESTAVA1.SLK'#9'UZIV\SESTAVA2.SES'#13'UZIV\vystup.pdf', 'Test scriptu', 'smtp.posta.cz', 'SMTPjmeno', 'SMTPheslo', 'Testovaci email.'#13'Konec', s) then
    ShowMessage('OK '+ s)
  else
    ShowMessage('CHYBA '+ s); 
end. 

---

Příklad 4 - odeslání souboru pomocí MaximObjServeru

var MOSCommunicator: TMOSCommunicator; 
begin 
 MOSCommunicator := TMOSCommunicator.Create('MOS.bin', '', '', '', 0); 
 if MOSCommunicator.SendFile('C:\DIR\DATA1.xml', 'DATA1.XML', '', '', '', True) then
   LogWrite('Prenos OK')
 else
   LogWrite(MOSCommunicator.ErrMessage); 
 MOSCommunicator.Free; 
end. 

---

Příklad 5 - použití funkcí objektu TMOSCommunicator pro komunikaci s MaximObjServerem

var MOSCommunicator: TMOSCommunicator; 
    Info: String; 
    Velikost: Extended; 
    Cas: TDateTime; 
begin 
 MOSCommunicator := TMOSCommunicator.Create('', '192.168.17.1', 'MOSuser', 'MOSpswd', 1); 
 try 
   if MOSCommunicator.Connect then begin  // pokud se připojím, pak se vše realizuje 
                                          // v rámci jednoho připojení 
                                          //    ShowMessage('Pripojeno'); 
     if MOSCommunicator.Connected then begin // test navic 
       if MOSCommunicator.SendSMS('111222333','Pokus o poslani SMS') then
         ShowMessage('SMS odeslana.') 
       else
         ShowMessage('Chyba pri odesilani SMS:'#13+MOSCommunicator.ErrMessage); 
       if MOSCommunicator.SendFile('C:\DIR\DATA1.xml', 'DATA1.XML', '', '', '', False) then 
       begin 
         ShowMessage('Prenos OK'); 
         if MOSCommunicator.GetFileInfo('Sklad6DOC', 'Stavy.xml', Info, Velikost, Cas) then begin 
           ShowMessage('GetFileInfo:'#13 + Info+ #13 + FloatToStr(Velikost) + #13 + DateTimeToStr(Cas)); 
           if not MOSCommunicator.GetFile('C:\DIR\Stavy2.XML', 'Podslozka\Stavy.xml', 'Sklad6DOC') then
             ShowMessage('GetFile:'#13+MOSCommunicator.ErrMessage); 
         end else 
           ShowMessage('GetFileInfo:'#13+MOSCommunicator.ErrMessage); 
       end else 
         ShowMessage('SendFile'#13+MOSCommunicator.ErrMessage); 
       MOSCommunicator.Disconnect; 
     end else 
       ShowMessage(MOSCommunicator.ErrMessage); 
   end else 
     ShowMessage(MOSCommunicator.ErrMessage); 
 finally 
   MOSCommunicator.Free; 
 end; 
end.

---

Příklad 6 - práce s TKAPBtrTable ve formuláři

var
  t: TKAPBtrTable;
  f: TForm;
  DBGrid: TDBGrid;
  ds: TDataSource;
begin
 ds := nil;
 t := TKAPBtrTable.Create;
 try  // try-finally část není nutná, ale správně se takto řeší problémové situace
   t.TableName := 'CISELNIK.btr';  // jméno tabulky bez cesty
   t.IndexFieldNames := 'TypCis;Klic1';                // index s těmito poli musí v tabulce existovat
   if MsgDlg('Přejete si použít filtr ?', 'Testovací skript', mtConfirmation, 
        msgboxOK + msgboxCancel, 'mbOK=Použít filtr') = mrOK then begin
     t.Filter := '(TypCis=161)AND(PosUp("T",Klic1)=1)';
     t.Filtered := true;
   end;
   t.Open;
   f := TForm.Create(Application);
   try
     f.Caption := 'Zobrazení ' + t.TableName;
     f.Position := poDefault;
     DBGrid:= TDBGrid.Create(f);   // parametr určuje vlastníka prvku DBGrid
     DBGrid.Parent := f;           // Parent určuje, na kterém formuláři se má DBGrid zobrazit
     DBGrid.Align := alClient;     // alClient znamená vyplnit celý formulář
     ds:= TDataSource.Create(f); // TDataSource propojuje tabulku s vizuálními prvky pro editaci (DBGrid)
     DBGrid.DataSource := ds;
     ds.DataSet := t;
     f.ShowModal;                // hlavní okno je třeba vždy otevírat pomocí ShowModal
   finally
     F.Free;                     // objekty, kterým byl určen vlastník (DBGrid) se ruší automaticky
   end;                          // při rušení vlastníka (při F.Free se ruší DBGrid i ds)
 finally
   t.Free;                       // vytvořené objekty je třeba zrušit
 end;
end.

---

Příklad 7 - použití paměťové tabulky TKAPMemTable

var t: TKAPMemTable;
   f:TForm;
   DBGr: TDBGrid;
   ds: TDataSource;
   MinA, x: Integer;
begin
 t := TKAPMemTable.Create;
 try
   t.FieldDefs.Add('A',ftInteger,0, false);
   t.FieldDefs.Add('B',ftString,30, false);
   t.FieldDefs.Add('C',ftfloat,0, false);
   t.FieldDefs.Add('D',ftDate,0, false);
   t.FieldDefs.Add('E',ftTime,0, false);
   t.CreateTable(nil);
//    t.IndexFieldNames := 'A;B';
   t.AddIndex('i1', 'A;B',[ixCaseInsensitive]); // nesmi byt prazdna mnozina
   t.IndexName := 'i1';
   t.Open;
   t.Append;
   t.FieldByName('A').AsInteger := 5555;
   t.FieldByName('B').AsString := 'TEST';
   t.FieldByName('C').AsFloat := 10.5;
   t.Post;
   t.Append;
   t.FieldByName('A').AsInteger := 4444;
   t.FieldByName('D').AsDateTime := Date+1;
   t.Post;
   t.Append;
   t.FieldByName('A').AsInteger := 3333;
   t.Post;
   t.Append;
   t.FieldByName('A').AsInteger := 8888;
   t.Post;
   t.First;
   MinA := t.FieldByName('A').AsInteger;
   while not t.EOF do begin
     if t.FieldByName('A').AsInteger < MinA then MinA := t.FieldByName('A').AsInteger;
     t.Next;
   end;
   ShowMessage('Min: '+IntToStr(MinA));
   f := TForm.Create(Application);
   try
     f.Caption := 'Zobrazení MemTable';
     f.Width := 1024;
     f.Height := 768;
     DBGr:= TDBGrid.Create(f);
     DBGr.Parent := f;
     DBGr.Align := alClient;
     ds:= TDataSource.Create(f);
     DBGr.DataSource :=ds;
     ds.DataSet := t;
     f.ShowModal;
   finally
     f.free;
   end
//    x := t.RecordCount;
 finally
   t.Free;
 end
end.

---

Příklad 8 - použití externího datového zdroje pomocí TKAPADOTable

var
 t: TKAPADOTable;
 f:TForm;
 DBGr: TDBGrid;
 ds: TDataSource;
 spl1: TSplitter;
 lb: TListBox;
 i : integer;
//  Fld : TField;
begin
  f := nil;
  DBGr := nil;
  ds := nil;
  t := TKAPADOTable.Create;
  t.ConnectionString:= 'Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\Slozka\TestData.xls;Extended Properties=Excel 8.0';
  try
    try
      t.TableName := 'Tabulka'; // data v tabulce MS Excel označte pomocí funkce Definovat název
      t.Open;
      f := TForm.Create(nil);
      f.Caption := 'Zobrazení dat z Excelu';
      f.Width := 1024;
      f.Height := 768;
      DBGr:= TDBGrid.Create(f);
      DBGr.Parent := f;
      DBGr.Align := alLeft;
      DBGr.Width := 800;
      DBGr.ReadOnly := true;
      spl1 := TSplitter.Create(f);
      spl1.Parent := f;
      spl1.Align := alLeft;
      spl1.Width := 4;
      spl1.Left := 802;
      lb := TListBox.Create(f);
      lb.Parent := f;
      lb.Left := 1000;
      lb.Top := 300;
      lb.Align := alClient;
      ds:= TDataSource.Create(f);
      DBGr.DataSource := ds;
      ds.DataSet := t;
      DBGr.Options := dgAlwaysShowSelection + dgCancelOnExit + dgColLines + dgColumnResize + dgConfirmDelete + dgIndicator + dgRowLines + dgRowSelect + dgTitles;
      for i := 0 to DBGr.Columns.Count - 1 do begin  // sloupce gridu se připraví po spojení gridu s otevřeným datasetem
        lb.Items.Add(DBGr.Columns[i].FieldName);
        DBGr.Columns[i].Width := 80;
      end;
//      for i := 0 to t.FieldCount - 1 do begin  // jiný způsob jak projít pole tabulky (nezávislý na gridu)
//        lb.Items.Add(t.Fields[i].FieldName);   // takto to nefunguje
//        Fld := t.Fields[i];                    // Field je nutné nejdříve přiřadit do proměnné typu TField
//        lb.Items.Add(Fld.FieldName);
//        Fld.DisplayWidth := 12;
//      end;
      f.ShowModal;
    except
      ShowMessage(ExceptionMessage);
    end;
  Finally
    t.Free;
    if ds <> nil then
      ds.Free;
    if F <> nil then
      F.Free;
  end;
end.

---

Příklad 9 - Spuštění funkce z hlavního menu aplikace

procedure DoOnWaitKey(WaitForKeyInfo: TKAPAppControlWaitForKeyInfo);
begin
  if PosUp('OBDOB', App.ActiveWindowCaption) > 0 then begin
    App.PressFnKeys('F2');
  end;
end;
// hlavní část
begin
  App.OnWaitForKey := @DoOnWaitKey;
//App.RunMenu(KodMenu1, KodMenu2, PristPravo: byte; Keys: string);
//Kód menu lze zjistit v rámci Systémové menu/Menu
  App.RunMenu(1, 15, 9, '"181212" Tab "201212"');
// v rámci spuštění položky menu s kódem KodMenu1 a KodMenu2 lze klávesy "namačkat" dopředu;
// pokud program vyčerpá klávesy ze zásobníku a obslužná procedura nestiskne další klávesu, pak program funkci automaticky ukončuje pomocí ESC
end.

---

Příklad 10 - Spuštění funkce z hlavního menu s obslužnou procedurou menu

procedure DoOnMenu(MenuInfo: TKAPAppControlMenuInfo);
begin
  if MenuInfo <> nil then                                           
    if Trim(App.ActiveWindowCaption) = 'Kontrola' then begin
      if MenuInfo.MenuItemsCount > 1 then
        MenuInfo.SelectedMenuItem := 2;
    end else
      if PosUp('Kontrola datumu spotřeby', App.ActiveWindowCaption) >= 1 then begin
        MenuInfo.SelectedMenuItem := 3;
        App.PressKeys('"50" F2');
      end;
end;
// hlavní část
begin
  App.OnMenu := @DoOnMenu;
  App.RunMenu(3, 4, 9, '');
end.

---

Příklad 11 - Použití objektu TKAPIndPrice

var
 IC: TKAPIndPrice;
 Cena, CenaSDPH: Double;
 UrovenDPH: byte;
 KodKarty : string;
begin
  IC := TKAPIndPrice.Create;
  try
    KodKarty := '1020199';
    Cena := IC.KartaCena(KodKarty, 1, false); // první cenové pásmo z karty - cena bez DPH
    UrovenDPH := IC.KartaUrovenDPH(KodKarty); // pořadové číslo sazby DPH 0, 1, 2...
           // použije se individuální cena MOJEIC nebo aternativní individuální cena IND*
           // Cena musí být naplněna již před voláním IC.IndividualniCena
    if IC.IndividualniCena('MOJEIC', 'IND*', KodKarty, 1, 0, Date, 1, Cena, CenaSDPH) then
      ShowMessage('Výsledná cena: '+FormatFloat('#.00', Cena)+'   cena s DPH: '+FormatFloat('#.00', CenaSDPH))
    else begin
      CenaSDPH := IC.CenaSDPH(Cena, UrovenDPH);
      ShowMessage('Individuální cena nebyla pro dané zboží vyhodnocena'#13+
                  'Základní cena: '+FormatFloat('#.00', Cena)+'   cena s DPH: '+FormatFloat('#.00', CenaSDPH));
    end;
  finally
    IC.Free;
  end;
end.

---

Příklad 12 - Práce s XML za pomocí Msxml2.DOMDocument

var
 XMLDoc: Variant;
 ZaznamList, FieldNode : Variant;
 InfoStr: string;
 I, Cnt: integer;
begin
//  XMLDoc:=CreateOLEObject('Msxml2.DOMDocument.6.0');   -- potřebuje novější verzi MSXML; umožňuje ale např. práci s XSD šablonami
 XMLDoc :=CreateOLEObject('Msxml2.DOMDocument');
 try
   XMLDoc.async:= False;
   XMLDoc.resolveExternals:= False;
   XMLDoc.Load('Respons.XML');
// XMLDoc.LoadXML(textXML)  -- umožňuje načíst XML ve formě textu
{
<?xml version="1.0" encoding="UTF-8"?>
<soapenv:Envelope xmlns:soapenv="http://schemas.xmlsoap.org/soap/envelope/">
 <soapenv:Body>
  <StatusNespolehlivyPlatceResponse xmlns="http://adis.mfcr.cz/rozhraniCRPDPH/">
   <status odpovedGenerovana="2013-03-31" statusCode="0" statusText="OK"/>
   <statusPlatceDPH dic="CZ6301050074" nespolehlivyPlatce="NENALEZEN"/>
   <statusPlatceDPH dic="CZ27495132" nespolehlivyPlatce="NENALEZEN"/>
  </StatusNespolehlivyPlatceResponse>
 </soapenv:Body>
</soapenv:Envelope>
}
   if XMLDoc.parseError.errorCode = 0 then begin
     ZaznamList:= XMLDoc.getElementsByTagName('soapenv:Body');
     if ZaznamList.Length > 0 then begin
       ZaznamList:= ZaznamList.item(0).childNodes;   // zanoří se do dané větve XML
       if ZaznamList.Length > 0 then begin
         FieldNode := ZaznamList.item(0);
         if FieldNode.NodeName = 'StatusNespolehlivyPlatceResponse' then begin
           ZaznamList:= FieldNode.childNodes;
           Cnt := 0;
           InfoStr := ' ';
           for I := 0 to ZaznamList.Length - 1 do begin
             FieldNode := ZaznamList.item(I);
             if FieldNode.NodeName = 'statusPlatceDPH' then
               inc(Cnt)
             else
               if FieldNode.NodeName = 'status' then
                 InfoStr := Format('Ze dne %s', [FieldNode.getAttribute('odpovedGenerovana')])
           end;
           ShowMessage(Format('Počet záznamů "statusPlatceDPH": %d'#13'%s', [Cnt, InfoStr]));
         end;
       end;
     end;
   end else
     ShowMessage(Format('Chyba při čtení XML: %d %s', [XMLDoc.parseError.errorCode, xmlDoc.parseError.reason]));
 finally
   XMLDoc := nil;
 end;
end.