FAQ LazarusConsultez toutes les FAQ

MAINICON ICON "nom_fichier.ico"

windres -i nom_fichier.rc -o nom_fichier.res

{$R nom_fichier.res}

1
2
3
4
5
6
7
8
9
10
11
12
13
msgid "" 
msgstr "" 
"MIME-Version: 1.0\n" 
"Content-Type: text/plain; charset=UTF-8\n" 
"Content-Transfer-Encoding: 8bit\n" 
 
#: lzvconst:lzvversionstr 
msgid "%d.%d.%d%d" 
msgstr "" 
 
#: lzvconst:lzvdlgmbabort 
msgid "Abort" 
msgstr ""

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Unit untres; 
  
{$mode objfpc}{$H+} 
  
Interface 
  
Uses 
  Classes, SysUtils; 
  
Resourcestring 
  {All} 
  LZTLabVersion            = 'Version :'; 
  LZTVersionStr            = '%d.%d.%d%d'; 
  LZTNoneStr               = 'None'; 
  LZTBuildWith             = 'Builded with Lazarus'; 
  LZTNoImplemented         = 'Not implemented'; 
  LZTStatusInsert          = 'Insert into table'; 
  LZTStatusUpdate          = 'Update table'; 
  LZTStatusTruncate        = 'Truncate table';  
  // etc.... 
  
Implementation 
  
End.

gettext, Translations

1
2
3
4
5
6
{ Cette procédure affecte les resourcestring aux champs concernés } 
Procedure TFrmlztdbconvert.TranslateVisual; 
Begin 
  BT1.Caption := LZTStatusInsert; // LZTStatusInsert est une ressourcestring dans untres 
  BT2.Caption := LZTStatusUpdate; // LZTStatusUpdate est une ressourcestring dans untres 
End;

1
2
3
4
5
6
7
8
9
10
11
12
13
Procedure TFrmlztdbconvert.FormCreate(Sender : TObject); 
Var 
  lg, language : String; 
Begin 
  // Récupère le code langue de la machine mais ont peut s'en passer pour gérer autrement (passage direct issu d'une liste par exemple) 
  GetLanguageIDs(lg,language);  
  
  // Appelle le fichier de traduction via l'unité contenant les resourcestring 
  Translations.TranslateUnitResourceStrings('untres', '.\languages\'+'monfichier.%s.po', lg, language); 
  
  // Affiche les captions et autres ... de type TTranslateString 
  TranslateVisual; 
End;

1
2
3
4
5
6
7
8
9
10
11
12
13
msgid "" 
msgstr "" 
"MIME-Version: 1.0\n" 
"Content-Type: text/plain; charset=UTF-8\n" 
"Content-Transfer-Encoding: 8bit\n" 
 
#: lzvconst:lzvversionstr 
msgid "%d.%d.%d%d" 
msgstr "" 
 
#: lzvconst:lzvdlgmbabort 
msgid "Abort" 
msgstr "Abandonner"

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Unit Unit1;  
  
{$mode objfpc}{$H+} 
  
Interface 
  
Uses 
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs;  
  
Type 
  TForm1 = class(TForm) 
  private 
    { private declarations } 
  public 
    { public declarations } 
  end;  
  
Var 
  Form1 : TForm1;  
  
Implementation 
  
{ TForm1 } 
Uses 
  gettext; 
  
Procedure TForm1.FormShow (Sender : TObject); 
Begin 
  Label1.Caption := rsLabel1Caption; // Je fixe la valeur de mon texte à la valeur de ma resourcestring 
End; 
  
Initialization 
  {$I main.lrs} 
  TranslateResourcestrings('french.mo'); // Je sélectionne la langue française 
  
End.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Unit language; 
  
{$mode objfpc}{$H+} 
  
Interface 
  
Uses 
  Classes, SysUtils;  
  
resourcestring 
  rsLabel1Caption = 'English text'; 
  
Implementation 
  
End.

rstconv.exe -i language.rst -o english.po

1
2
3
4
5
6
7
8
9
10
11
12
13
14
msgid "" 
msgstr "" 
"Project-Id-Version: \n" 
"POT-Creation-Date: \n" 
"PO-Revision-Date: 2006-09-18 16:54+0100\n" 
"Last-Translator: \n" 
"Language-Team: \n" 
"MIME-Version: 1.0\n" 
"Content-Type: text/plain; charset=utf-8\n" 
"Content-Transfer-Encoding: 8bit\n" 
  
#: rs:rstest 
msgid "English Text" 
msgstr "Texte Français"

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
Unit Unit1;  
  
{$mode objfpc}{$H+} 
  
Interface 
  
Uses 
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, Buttons; 
  
Type 
  
  { TForm1 } 
  
  TForm1 = class(TForm) 
    Button1 : TButton; 
    Edit1 : TEdit; 
    Label1 : TLabel; 
    Procedure Button1Click (Sender : TObject); 
  private 
    { private declarations } 
  public 
    { public declarations } 
  end;  
  
Var 
  Form1 : TForm1;  
  
Implementation 
  
Uses 
  translations, rs; 
  
{ TForm1 } 
  
Procedure TForm1.Button1Click (Sender : TObject); 
Begin 
  TranslateUnitResourceStrings('rs', Edit1.Text + '.po', 'english', 'english'); 
  Label1.Text := rsTest; 
End; 
  
Initialization 
  {$I unit1.lrs} 
  InitTranslation; 
  
End.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Unit rs; 
  
{$mode objfpc}{$H+} 
  
Interface 
  
Uses 
  Classes, SysUtils;  
  
resourcestring 
  rsTest = 'English Text'; 
  
Implementation 
  
End.

1
2
3
if not (csDesigning in ComponentState) 
   then  
     ...

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
Procedure TForm1.CopierFichier (Source, Destination : String); 
Var 
  Src, Dst : TStream; 
  i, Count : Int64; 
  buffer : Array [0..1023] of Byte; 
Begin 
    // Ouvrir le fichier source 
    Src := TFileStream.Create(Source,fmOpenRead); 
    // Ouvrir le fichier destination 
    Dst := TFileStream.Create(Destination,fmcreate or fmOpenWrite); 
    // Source au début de fichier 
    Src.Position := 0; 
    // Taille du fichier 
    Count := Src.Size; 
    // Début de la copie 
    while Count > 0 do 
      begin 
        // On suit la progression de 0 à 100 % 
        ProgressBar1.Position := trunc(100.0 * (Src.position / Src.size)); 
        // Traitement des messages pour ne pas bloquer tout le système 
        Application.ProcessMessages; 
        // Si count + grand que buffer on lit la taille du buffer 
        if (Count > sizeof(buffer)) then i := sizeof(Buffer) 
           else i:=Count; 
        // On lit i bits 
        i := Src.Read(buffer,i); 
        // On écrit i bits 
        i := Dst.Write(buffer,i); 
       // Si i = 0 plus rien à copier ou erreur 
        if i = 0 then break; 
        dec(count,i); 
      end; 
    // Libération des streams 
    Src.Free; 
    Dst.Free; 
End;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Unit browserlink; 
  
{$mode objfpc}{$H+} 
  
Interface 
  
Uses 
  Classes, SysUtils, FileUtil, Forms, Dialogs 
{$ifdef linux} 
  ,Unix 
{$endif} 
{$ifdef win32} 
  ,Windows, ShellApi 
{$endif} 
  ; 
  
Type 
  TBrowserLink = class(TComponent) 
  private 
    BrowserDefault : string; 
    BrowserName : Array [0..10] of string; 
    BrowserCount : Integer; 
  public 
    Constructor Create (AOwner :TComponent); override; 
    Destructor Destroy; override; 
    Procedure ShowLink (_url : String); 
    Function SearchExecutable (const ShortFilename : String; var Filename : String) : Boolean; 
    Procedure InitFirst; 
  end; 
  
Implementation 
  
Constructor TBrowserLink.Create (AOwner : TComponent); 
Begin 
  inherited Create(AOwner); 
  BrowserDefault := ''; 
  BrowserName[0] := 'firefox'; 
  BrowserName[1] := 'galeon'; 
  BrowserName[2] := 'konqueror'; 
  BrowserName[3] := 'mozilla'; 
  BrowserName[4] := 'netscape'; 
  BrowserName[5] := 'opera'; 
  BrowserCount := 6; 
End; 
  
Destructor TBrowserLink.Destroy; 
Begin 
  inherited Destroy; 
End; 
  
Function TBrowserLink.SearchExecutable (const ShortFilename : String; var Filename : String) : Boolean; 
Begin 
  Filename := SearchFileInPath(ShortFilename,'',SysUtils.GetEnvironmentVariable('PATH'),PathSeparator,[]); 
  Result := Filename<>''; 
End; 
  
Procedure TBrowserLink.InitFirst; 
Var 
  i1 : Integer; 
  BrowserFileName : String; 
Begin 
  for i1 := 1 to BrowserCount do begin 
    if SearchExecutable(lowercase(BrowserName[i1-1]),BrowserFilename) then begin 
      BrowserDefault := BrowserFileName; 
      Exit; 
    end 
    else begin 
    end; 
  end; 
End; 
  
Procedure TBrowserLink.ShowLink (_url : String); 
Begin 
{$ifdef linux} 
  if BrowserDefault = '' then begin 
    InitFirst; 
  end; 
  Shell(BrowserDefault + ' ' + _url); 
{$endif} 
{$ifdef win32} 
  ShellExecute(0,'open',PChar(_url),'','',SW_SHOW); 
{$endif} 
End; 
  
End.

1
2
3
4
5
6
7
Procedure TForm1.BitBtn1Click (Sender : TObject); 
Var 
  Link1 : TBrowserLink; 
Begin 
  Link1 := TBrowserLink.Create(Self); 
  Link1.ShowLink('http://www.developpez.com'); 
End;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Procedure OpenURL (const URL : String); 
Var 
  TheProcess : TProcess; 
Begin 
  TheProcess := TProcess.Create(nil); 
  try 
    TheProcess.Options := [poNoConsole,poNewProcessGroup]; 
    TheProcess.ShowWindow := swoNone; 
    TheProcess.CommandLine := ExeNavigateur + URL; 
    try 
      TheProcess.Execute; 
      //TheProcess.WaitOnExit; // 
      {$IFDEF LINUX} 
      if TheProcess.ExitStatus <> 0 then begin 
        MessageDlg('Erreur','Erreur lors de l''exécution du programme ' + ExeNavigateur + chariot +'Code de l''erreur : '+IntToStr(TheProcess.ExitStatus),mtError,[mbOk],0); 
      end; 
      {$ENDIF} 
    finally 
      TheProcess.Free; 
    end; 
  except 
    ShowMessage('Erreur !'); 
  end; 
End;

1
2
3
4
Procedure TForm1.MaProcedure1 (Sender : TObject); 
Begin 
  ... 
End;

OnClick := @MaProcedure1;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Type 
  TTaskThread = class(TThread) 
  protected 
    Procedure Execute; override; 
  public 
    Constructor Create; 
  end; 
  
Constructor TTaskThread.Create; 
Begin 
  inherited Create(true); // "thread" suspendu à la création 
  FreeOnTerminate := true; 
End; 
  
Procedure TTaskThread.Execute; 
Const 
  LAPS = 180000; // 180000 ms = 3 mn 
Begin 
  while not Terminated do 
  begin 
    Sleep(LAPS); 
    Task; // procédure contenant le code à exécuter toutes les 3 mn 
  end; 
End;

TaskThread := TTaskThread.Create;

TaskThread.Resume;

TaskThread.Suspend;

TaskThread.Terminate;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Procedure TForm1.capturer; 
Var 
  Bitmap : TBitmap; 
  ScreenDC : HDC; 
Begin 
  try 
    Bitmap := TBitmap.Create; 
    ScreenDC := GetDC(handle); // récupère le handle de la feuille 
    Bitmap.LoadFromDevice(ScreenDC); 
    ReleaseDC(handle,ScreenDC); 
    if SaveDialog1.Execute then BitMap.SaveToFile(SaveDialog1.FileName); 
  finally 
    Bitmap.free 
  end; 
End;

1
2
3
4
5
-- add.lua 
  
function add(x, y) 
  return x + y 
end

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
 
program Add; 
{$MODE OBJFPC}{$H+} 
{$DEFINE USE_LUA53} 
 
uses 
{$IFDEF USE_LUA53} 
  Lua53; (* https://github.com/malcome/Lua4Lazarus *) 
{$ELSE} 
  Lua52; (* http://lua-users.org/files/wiki_insecure/FreePascal/lua52.pas *) 
{$ENDIF} 
 
var 
  L: plua_state; 
 
function LuaAdd(x, y: integer): integer; 
begin 
  lua_getglobal(L, 'add');        (* Nom de la fonction Lua. *) 
  lua_pushinteger(L, x);          (* Premier argument. *) 
  lua_pushinteger(L, y);          (* Second argument. *) 
  lua_call(L, 2, 1);              (* Appel de la fonction : deux arguments, un résultat. *) 
  result := lua_tointeger(L, -1); (* Lecture du résultat. *) 
  lua_pop(L, 1);                  (* Le résultat est retiré de la pile. *) 
end; 
 
var 
  script: string;                 (* Nom du script Lua. *) 
  result: integer; 
   
begin 
  script := 'add.lua'; 
  L := luaL_newstate(); 
  luaL_openlibs(L); 
  if luaL_dofile(L, pChar(script)) <> 0 then  
  begin 
    WriteLn(lua_tostring(L, -1)); (* Message d'erreur. *) 
    exit; 
  end; 
  result := LuaAdd(12, 3); 
  lua_close(L); 
  WriteLn(result); 
end.

1
2
3
4
5
6
7
-- Fonction qui vérifie si une chaîne donnée peut être une adresse de messagerie 
-- électronique. 
  
function IsEMail(str) 
  local pattern = "^%a[%w%._]*@[%w%._]+%.%a%a%a?%a?$" 
  return string.match(str, pattern) ~= nil 
end

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
program EMail; 
{$MODE OBJFPC}{$H+} 
{$DEFINE USE_LUA53} 
 
uses 
{$IFDEF USE_LUA53} 
  Lua53; (* https://github.com/malcome/Lua4Lazarus *) 
{$ELSE} 
  Lua52; (* http://lua-users.org/files/wiki_insecure/FreePascal/lua52.pas *) 
{$ENDIF} 
 
var 
  L: plua_state; 
 
function luaIsEMail(s: string): boolean; 
begin 
  lua_getglobal(L, 'IsEMail'); 
  lua_pushstring(L, s); 
  lua_call(L, 1, 1); 
  result := lua_toboolean(L, -1); 
  lua_pop(L, 1); 
end; 
   
begin 
  L := luaL_newstate(); 
  luaL_openlibs(L); 
   
  if luaL_dofile(L, 'email.lua') = 0 then 
  begin 
    WriteLn(luaIsEMail('berthe.aux_grands_pieds@messagerie.fr')); 
    WriteLn(luaIsEMail('berthe.57@messagerie.fr')); 
    WriteLn(luaIsEMail('57.aux_grands_pieds@messagerie.fr')); 
    lua_close(L); 
  end else 
    WriteLn(lua_tostring(L, -1)); 
end.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
unit MyCursors; 
  
{$mode objfpc}{$H+} 
  
interface 
  
uses 
    Forms, Graphics, LResources; 
  
const 
     // vos constantes cursors 
     CUR_PIPETTE = 1; 
     CUR_PINCEAU = 2; 
  
implementation 
  
initialization 
    {$I mycursors.lrs} 
  
   Screen.Cursors[CUR_PIPETTE]:= LoadCursorFromLazarusResource('pipette'); 
   Screen.Cursors[CUR_PINCEAU]:= LoadCursorFromLazarusResource('pinceau'); 
  
end.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
function UTF82HTML(const St : string) : string; 
var 
  Li : integer; 
  LSt: string; 
begin 
  Result := ''; 
  for Li := 1 to UTF8Length(St) do 
  begin 
    LSt := UTF8Copy(St, Li, 1); 
    if Length(LSt) = 1 then 
    begin 
      Result := Result + LSt; 
    end 
    else 
    begin 
      case UTF8Pos(LSt, '™©®ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõöøùúûüýþÿ¡¢£¤¥¦§¨ª«¬¯°±²³´µ·¸¹º»¼½¾¿×÷€') of 
      1 : Result  := Result  +  '™'; 
      2 : Result  := Result  +  '©'; 
      3 : Result  := Result  +  '®'; 
      4 : Result  := Result  +  'À'; 
      5 : Result  := Result  +  'Á'; 
      6 : Result  := Result  +  'Â'; 
      7 : Result  := Result  +  'Ã'; 
      8 : Result  := Result  +  'Ä'; 
      9 : Result  := Result  +  'Å'; 
      10 : Result  := Result  +  'Æ'; 
      11 : Result  := Result  +  'Ç'; 
      12 : Result  := Result  +  'È'; 
      13 : Result  := Result  +  'É'; 
      14 : Result  := Result  +  'Ê'; 
      15 : Result  := Result  +  'Ë'; 
      16 : Result  := Result  +  'Ì'; 
      17 : Result  := Result  +  'Í'; 
      18 : Result  := Result  +  'Î'; 
      19 : Result  := Result  +  'Ï'; 
      20 : Result  := Result  +  'Ð'; 
      21 : Result  := Result  +  'Ñ'; 
      22 : Result  := Result  +  'Ò'; 
      23 : Result  := Result  +  'Ó'; 
      24 : Result  := Result  +  'Ô'; 
      25 : Result  := Result  +  'Õ'; 
      26 : Result  := Result  +  'Ö'; 
      27 : Result  := Result  +  'Ø'; 
      28 : Result  := Result  +  'Ù'; 
      29 : Result  := Result  +  'Ú'; 
      30 : Result  := Result  +  'Û'; 
      31 : Result  := Result  +  'Ü'; 
      32 : Result  := Result  +  'Ý'; 
      33 : Result  := Result  +  'Þ'; 
      34 : Result  := Result  +  'ß'; 
      35 : Result  := Result  +  'à'; 
      36 : Result  := Result  +  'á'; 
      37 : Result  := Result  +  'â'; 
      38 : Result  := Result  +  'ã'; 
      39 : Result  := Result  +  'ä'; 
      40 : Result  := Result  +  'å'; 
      41 : Result  := Result  +  'æ'; 
      42 : Result  := Result  +  'ç'; 
      43 : Result  := Result  +  'è'; 
      44 : Result  := Result  +  'é'; 
      45 : Result  := Result  +  'ê'; 
      46 : Result  := Result  +  'ë'; 
      47 : Result  := Result  +  'ì'; 
      48 : Result  := Result  +  'í'; 
      49 : Result  := Result  +  'î'; 
      50 : Result  := Result  +  'ï'; 
      51 : Result  := Result  +  'ð'; 
      52 : Result  := Result  +  'ñ'; 
      53 : Result  := Result  +  'ò'; 
      54 : Result  := Result  +  'ó'; 
      55 : Result  := Result  +  'ô'; 
      56 : Result  := Result  +  'õ'; 
      57 : Result  := Result  +  'ö'; 
      58 : Result  := Result  +  'ø'; 
      59 : Result  := Result  +  'ù'; 
      60 : Result  := Result  +  'ú'; 
      61 : Result  := Result  +  'û'; 
      62 : Result  := Result  +  'ü'; 
      63 : Result  := Result  +  'ý'; 
      64 : Result  := Result  +  'þ'; 
      65 : Result  := Result  +  'ÿ'; 
      66 : Result  := Result  +  '¡'; 
      67 : Result  := Result  +  '¢'; 
      68 : Result  := Result  +  '£'; 
      69 : Result  := Result  +  '¤'; 
      70 : Result  := Result  +  '¥'; 
      71 : Result  := Result  +  '¦'; 
      72 : Result  := Result  +  '§'; 
      73 : Result  := Result  +  '¨'; 
      74 : Result  := Result  +  'ª'; 
      75 : Result  := Result  +  '«'; 
      76 : Result  := Result  +  '*'; 
      77 : Result  := Result  +  '¯'; 
      78 : Result  := Result  +  '°'; 
      79 : Result  := Result  +  '±'; 
      80 : Result  := Result  +  '²'; 
      81 : Result  := Result  +  '³'; 
      82 : Result  := Result  +  '´'; 
      83 : Result  := Result  +  'µ'; 
      84 : Result  := Result  +  '·'; 
      85 : Result  := Result  +  '¸'; 
      86 : Result  := Result  +  '¹'; 
      87 : Result  := Result  +  'º'; 
      88 : Result  := Result  +  '»'; 
      89 : Result  := Result  +  '¼'; 
      90 : Result  := Result  +  '½'; 
      91 : Result  := Result  +  '¾'; 
      92 : Result  := Result  +  '¿'; 
      93 : Result  := Result  +  '×'; 
      94 : Result  := Result  +  '÷'; 
      95 : Result  := Result  +  '€'; 
        else 
          Result  := Result  + '?'; 
      end; 
    end; 
  end; 
end;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Function ExtAsciiToUTF8 (AValue : String) : String; 
Var 
  Li, LByte : Integer; 
Begin 
  Result := ''; 
  for Li := 1 to Length(AValue) do 
    begin 
      LByte := Ord(AValue[Li]); 
      if LByte < 128 
         then 
           Result := Result + AValue[Li] 
         else 
           if LByte > 128 
              then 
                Result := Result + Chr($C0 or ((LByte and $C0) shr 6)) + Chr((LByte and $3F) or $80) 
              else 
                Result := Result + Chr($E2) + Chr($82) + Chr($AC); 
    end; 
End;