FAQ LazarusConsultez toutes les FAQ

ShellExecute(0,'open','http://www.developpez.com',nil,nil,SW_SHOWNORMAL);

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
Function LectureVersion (chemin : String) : ShortString; 
Var 
  Taille : DWord; 
  Buffer : PChar; 
  VersionPC : PChar; 
  VersionL : DWord; 
Begin 
  Result := ''; 
  {--- on demande la taille des informations sur l'application ---} 
  // S := Application.ExeName; 
  Taille := GetFileVersionInfoSize(PChar(chemin), Taille); 
  if Taille > 0 
  then try 
    {--- Réservation en mémoire d'une zone de la taille voulue ---} 
    Buffer := AllocMem(Taille); 
    {--- Copie dans le buffer des informations ---} 
    GetFileVersionInfo(PChar(chemin),0,Taille,Buffer); 
    {--- Recherche de l'information de version ---} 
    if VerQueryValue(Buffer,PChar('\StringFileInfo\040C04E4\FileVersion'),Pointer(VersionPC),VersionL) 
       then Result := VersionPC; 
  finally 
    FreeMem(Buffer,Taille); 
  end; 
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
Procedure DoEnumPrinters (var Lst : TStrings); 
Var 
  Flags          : DWORD; 
  Level          : DWORD; 
  PrtCount       : DWORD; 
  Needed         : DWORD; 
  Buffer         : PChar; 
  InfoPrt        : PChar; 
  i              : Integer; 
  DefaultPrinter : Array [0..79] of Char; 
  PDev           : TPrinterDevice; 
  TmpDevMode     : PDeviceMode; 
Begin 
  Level := 5; // Compatible with all Win32 versions 
  DefaultPrinter := ''; 
  
  // Retrieve Default printer 
  Flags := PRINTER_ENUM_DEFAULT; 
  // Evaluate buffer size 
  Needed := 0; 
  EnumPrinters(Flags,nil,Level,nil,0,Needed,PrtCount); 
  if Needed > 0 then 
  begin 
    GetMem(Buffer,Needed); 
    try 
      // Get default printer 
      if EnumPrinters(Flags,nil,Level,Buffer,Needed,Needed,PrtCount) then 
        DefaultPrinter := PPRINTER_INFO_5(Buffer)^.pPrinterName; 
    finally 
      FreeMem(Buffer); 
    end; 
  end 
  else 
  begin 
    GetProfileString(PChar('windows'),PChar('device'),PChar(''),DefaultPrinter,SizeOf(DefaultPrinter)); 
    if pos(',',DefaultPrinter) <> 0 then 
       DefaultPrinter := Copy(DefaultPrinter,1,Pos(',',DefaultPrinter)-1); 
  end; 
  
  Flags := PRINTER_ENUM_CONNECTIONS or PRINTER_ENUM_LOCAL; 
  Level := 2; 
  
  // Evaluate buffer size 
  Needed := 0; 
  EnumPrinters(Flags,nil,Level,nil,0,Needed,PrtCount); 
  if Needed <> 0 then 
  begin 
    GetMem(Buffer,Needed); 
    Fillchar(Buffer^,Needed,0); 
    try 
      // Enumerate Printers 
      if EnumPrinters(Flags,nil,Level,Buffer,Needed,Needed,PrtCount) then 
      begin 
        InfoPrt := Buffer; 
        for i := 0 to PrtCount - 1 do 
        begin 
          if Level = 2 then 
          begin 
            PDev := TPrinterDevice.Create; 
            PDev.Name := PPRINTER_INFO_2(InfoPrt)^.pPrinterName; 
            PDev.Driver := PPRINTER_INFO_2(InfoPrt)^.pDriverName; 
            PDev.Port := PPRINTER_INFO_2(InfoPrt)^.pPortName; 
            TmpDevMode := PPRINTER_INFO_2(InfoPrt)^.pDevMode; 
            if TmpDevMode <> nil then begin 
              // the devmode structure obtained this way have two problems 
              // 1. It's not the full devmode, because it doesn't have 
              //    the private info 
              // 2. It's not initialized with the current settings and 
              //    have not extra settings at all. 
              // 
              // PDev.DevMode := PPRINTER_INFO_2(InfoPrt)^.PDevMode^; 
              PDev.Device := TmpDevMode^.dmDeviceName; 
              PDev.DefaultPaper := TmpDevMode^.dmPaperSize; 
            end 
            else begin 
              PDev.Device := ''; 
              PDev.DefaultPaper := 0; 
            end; 
            if AnsiCompareText(PDev.Name,DefaultPrinter) <> 0 then 
              Lst.AddObject(PDev.Name,PDev) 
            else 
            begin 
              Lst.Insert(0,PDev.Name); 
              Lst.Objects[0] := PDev; 
            end; 
            Inc(InfoPrt,SizeOf(_PRINTER_INFO_2)); 
          end; 
        end; 
      end; 
    finally 
      FreeMem(Buffer); 
    end; 
  end; 
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
Unit SelectPrinter; 
  
{$mode objfpc}{$H+} 
  
Interface 
  
Uses 
  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, StdCtrls, ticket, ComCtrls, PrintersDlgs; 
  
Type 
  
  { TFormSelectPrinter } 
  
  TFormSelectPrinter = class(TForm) 
    BTN_Valider : TButton; 
    BTN_Annuler : TButton; 
    Label1 : TLabel; 
    ListBox1 : TListBox; 
    Procedure BTN_AnnulerClick (Sender : TObject); 
    Procedure BTN_ValiderClick (Sender : TObject); 
    Procedure FormShow (Sender : TObject); 
  
  private 
    { private declarations } 
  public 
    { public declarations } 
    Printername : String; 
  end; 
  
Var 
  FormSelectPrinter : TFormSelectPrinter; 
  
Implementation 
  
{ TFormSelectPrinter } 
  
Procedure TFormSelectPrinter.FormShow (Sender : TObject); 
Var 
  n : Byte; 
Begin 
  DoEnumPrinters(ListBox1.Items); 
  if PrinterName <> '' then begin 
    n := 0; 
    while n < ListBox1.Count do begin 
      if ListBox1.Items[n] = printername then break; 
      inc(n); 
    end; 
    if (n < ListBox1.count) and (ListBox1.Items[n] = printername) then 
      ListBox1.ItemIndex := n; 
  end else 
    ListBox1.ItemIndex := -1; 
end; 
  
Procedure TFormSelectPrinter.BTN_ValiderClick (Sender : TObject); 
Begin 
  Printername := ListBox1.Items[listBox1.ItemIndex]; 
  ModalResult := mrOK; 
End; 
  
Procedure TFormSelectPrinter.BTN_AnnulerClick (Sender : TObject); 
Begin 
  ModalResult := mrCancel; 
End; 
  
Initialization 
  {$I selectprinter.lrs} 
  
End.

1
2
3
4
5
Procedure TForm_SetConfig.BTN_SelPrinterTicketClick (Sender : TObject); 
Begin 
  if FormSelectPrinter.ShowModal = mrOk then 
    NameTicket.Text := FormSelectPrinter.PrinterName; //NameTicket est un TEdit 
End;

1
2
Var 
   PrinterHandle : THandle;

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Procedure MyOpenPrinter (nom, titre : String);  
// Nom est le nom de l'imprimante tel que déclarée dans le panneau de configuration 
Var 
  Doc1 : DOC_INFO_1; 
Begin 
  // Initialisation des 3 champs de la structure DOC_INFO_1 : 
  Doc1.DocName := PChar(Titre);   // Le nom du document 
  Doc1.OutputFile := nil;   // Le nom du fichier de sortie (non utilisé ici) 
  Doc1.DataType := 'RAW';   // Le type de données envoyées au document ('RAW' ou 'EMF') 
  
  if OpenPrinter(PChar(nom),PrinterHandle,nil) then begin 
    if StartDocPrinter(PrinterHandle,1,@Doc1) <> 0 then begin 
      if StartPagePrinter(PrinterHandle) <> 0 then begin 
      end else begin 
      // ajouter ici un traitement d'erreur 
      end; 
    end else begin 
    // ajouter ici un traitement d'erreur 
    end; 
  end else begin 
  // ajouter ici un traitement d'erreur 
  end; 
End;

1
2
3
4
5
6
7
8
9
Procedure MyWritePrinter (s : String); 
Var 
  w : Integer; 
Begin 
  WritePrinter(PrinterHandle,@s[1],length(s),pdword(@W)); 
  if w<>length(s) then begin 
    // ajouter ici un traitement d'erreur 
  end; 
End;

1
2
3
4
5
6
Procedure MyClosePrinter; 
Begin 
  EndPagePrinter(PrinterHandle); 
  EndDocPrinter(PrinterHandle); 
  ClosePrinter(PrinterHandle); 
End; // on pourra au sein de cette procedure ajouter des traitements d'erreurs pour chaque fonction appellée

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
Unit Unit1; 
  
Interface 
  
Uses 
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, Dialogs, Winsock, StdCtrls; 
  
Type 
  TForm1 = class(TForm) 
    Button1 : TButton; 
    Edit1 : TEdit; 
    procedure Button1Click(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
  end; 
  
Var 
  Form1 : TForm1; 
  
Implementation 
  
{$R *.dfm} 
  
Function CheckPort (port : Integer; var erport : Integer) : Boolean; 
Var 
  sock : TSocket; 
  inaddr : TInAddr; 
  in_addr : TSockAddrIn; 
  wsdata : TWSAData; 
Begin 
  Result := false; 
  WSAStartup($101,wsdata); 
  try 
    inaddr.S_addr := INADDR_ANY; 
    in_addr.sin_family := AF_INET; 
    in_addr.sin_port := htons(port); 
    in_addr.sin_addr := inaddr; 
    sock := Socket(AF_INET,SOCK_STREAM,0); 
    if bind(sock,in_addr,sizeof(in_addr)) = -1 then 
    begin 
      Result := false; 
      erport := GetLastError; 
      closesocket(sock); 
      exit; 
    end 
    else 
    begin 
      Result := true; 
      closesocket(sock); 
      exit; 
    end; 
  finally 
    WSACleanup; 
  end; 
End; 
  
Procedure TForm1.Button1Click (Sender : TObject); 
Var 
  errno : Integer; 
Begin 
  if not CheckPort(strtoint(Edit1.Text), errno) then 
    showmessage(syserrormessage(errno)) 
  else 
    showmessage('Port is free'); 
End; 
  
End.

1
2
3
4
5
6
7
8
9
10
11
12
13
 
uses 
  LCLIntf; // unité contenant la fonction utile 
... 
var 
  MyURL: string; 
... 
 
procedure TMyButton.Click; 
// *** clic sur un bouton par exemple *** 
begin 
   OpenURL(MyURL); // envoi vers le navigateur par défaut  
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
{$MODE Delphi} 
 
interface 
 
uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  ShlObj, ActiveX, ComObj; 
 
type 
 
  { TForm1 } 
 
  TForm1 = class(TForm) 
    procedure FormCreate(Sender: TObject); 
  private 
    { Private declarations } 
  public 
    { Public declarations } 
    function GetTarget(const LinkFileName: string): string; 
  end; 
 
var 
  Form1: TForm1; 
 
implementation 
 
{$R *.lfm} 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Caption := GetTarget('C:\Users\Roland\Desktop\Lazarus.lnk'); 
end; 
 
function TForm1.GetTarget(const LinkFileName: string): string; 
var 
  sl: IShellLink; 
  pf: IPersistFile; 
  path: array[0..260] of WideChar; 
  info: array[0..MAX_PATH] of Char; 
  data: TWin32FindData; 
begin 
  if UpperCase(ExtractFileExt(LinkFileName)) <> '.LNK' then 
  begin 
    Result := 'error'; 
    exit; 
  end; 
  CoCreateInstance(CLSID_ShellLink, nil, CLSCTX_INPROC_SERVER, IShellLink, sl); 
  if sl.QueryInterface(IPersistFile, pf) = 0 then 
  begin 
    MultiByteToWideChar(CP_ACP, MB_PRECOMPOSED, PChar(LinkFileName), -1, @path, MAX_PATH); 
    pf.Load(path, STGM_READ); 
    sl.GetPath(@info, MAX_PATH, data, SLGP_UNCPRIORITY); 
    Result := info; 
  end else 
    Result := ''; 
end;