INTERNET

function GetDefBrowser: string;
var
  Reg: TRegistry;
  tempstr: string;
begin
  Result := '';
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_CLASSES_ROOT;
    if Reg.OpenKey('\http\shell\open\command', FALSE) then
      if Reg.ValueExists('') then
        tempstr := Reg.ReadString('');
    tempstr := copy(tempstr, 0, length(tempstr) -
length(extractfileext(tempstr))) + '.exe';
    if copy(tempstr, 1, 1) = '"' then
      tempstr := copy(tempstr, 2, length(tempstr) - 1);
    result := tempstr;
    Reg.CloseKey;
  finally
    Reg.Free;
  end;
end;

function GetLocalComputerName: string;
var
Count: DWORD;
begin
Count := MAX_COMPUTERNAME_LENGTH + 1;
SetLength(Result, Count);
GetComputerName(PChar(Result), Count);
SetLength(Result, StrLen(PChar(Result)));
end;

function GetIPAddress(const HostName: string): string;
var
R: Integer;
WSAData: TWSAData;
HostEnt: PHostEnt;
Host: string;
begin
Result := EmptyStr;
R := WSAStartup(MakeLong(1, 1), WSAData);
if R = 0 then
try
Host := HostName;
if Host = EmptyStr then Host := GetLocalComputerName;
HostEnt := GetHostByName(PChar(Host));
if Assigned(HostEnt) then with HostEnt^ do
begin
Result := Format('%u.%u.%u.%u', [Byte(h_addr^[0]), Byte(h_addr^[1]),
Byte(h_addr^[2]), Byte(h_addr^[3])]);
end;
finally
WSACleanup;
end;
end;

ou...

function GetLocalIPAddress : String ;

var
SockAddress : TSockAddrIn ;
pHE : PHostEnt ;
szHostName : Array[0..128] of Char ;
WSAData : TWSAData ;
begin
WSAStartup($101,WSAData) ;
GetHostName(szHostName,128) ;
pHE := GetHostByName(szHostName) ;
if pHE = nil then
Result := '0.0.0.0'
else
begin
SockAddress.sin_addr.S_addr := LongInt(pLongint(pHE^.h_addr_list^)^) ;
Result := inet_ntoa(SockAddress.sin_addr) ;
end ;
WSACleanup ;
end ;

function TASPGetRealName.IPAddrToName(IPAddr : String): String;
var
  SockAddrIn: TSockAddrIn;
  HostEnt: PHostEnt;
  WSAData: TWSAData;
begin
  WSAStartup($101, WSAData);
  SockAddrIn.sin_addr.s_addr:= inet_addr(PChar(IPAddr));
  HostEnt:= gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);   if
HostEnt<>nil then
    result:=StrPas(Hostent^.h_name)
  else
    result:='';
end;
 

I place the following code in the OnCreate event of the WebModule:

   SetString(PathStr, Path, GetModuleFileName(HInstance,
Path,SizeOf(Path)));
   PathStr := ExtractFilePath(PathStr);

I also declare the following variables in the private section of my
webmodule:
    PathStr: string;
    Path: array[0..MAX_PATH - 1] of Char;

PathSr will then provide the full path of of your isapi dll

Procedure ConnectServeur(MaConnexion : String);
Begin
  ShellExecute(Application.MainForm.Handle, 'open', 'rundll.exe',
PChar('rnaui.dll,RnaDial '+MaConnexion),
nil, SW_SHOWNORMAL)
end;

{Action GetImage}

procedure TWebModule1.WebModule1WebActionItem7Action(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

Var
   MS:TMemoryStream;

begin
      If QPhoto.Active then
     QPhoto.Close;
     QPhoto.SQL.Text:='Select * from pictures where id_nom='+Request.QueryFields.Values['rec'];
     QPhoto.Open;
     Ms:=TMemoryStream.Create;
     TBlobField(QPhoto.FieldByName('Image')).SaveToStream(Ms);
     MS.Position:=0;
     Response.ContentType:='image/jpeg';
     Response.ContentStream:=Ms;
     Response.SendResponse;
     Handled:=True;
end;

Insérer l'appel suivant dans l'action principale:

     If Not TBlobField(Pictures.FieldByName('Image') as TBlobField).IsNull then
          S:=S+'<IMG SRC="/scripts/adr.dll/GetImage?rec='+QFindid_nom.AsString+'" NOSAVE></center>'

uses
   ddeman

procedure TFormMain.SpeedButtonGetURLClick(Sender: TObject);
var
   DdeClientConv:TDdeClientConv;
   Temp  :string;
   URL   :string;
   Title :string;
 begin
   DdeClientConv:=TDdeClientConv.Create(self);
   with DdeClientConv do
   begin
    if SetLink( 'Netscape', 'WWW_GetWindowInfo' )then
      Temp:=RequestData('0xFFFFFFFF,sURL,sTitle');
      while Pos('"',Temp) > 0 do
        Delete(Temp,Pos('"',Temp),1);                   //Remove the quotes
        URL:=Copy(Temp,1,Pos(',',Temp)-1);              //Get URL
        Title:=Copy(Temp,Pos(',',Temp)+1,Length(Temp)); //Get title
        dmTables.tblwww.FieldByName('wwwadres').value:=URL;
    end;
   DdeClientConv.Free;
end;

function IEHere:BOOL;stdcall;
  var HWND:Thandle;
       HWND2:Thandle;
  begin
       result:=false;
       HWND:=FindWindow('CabinetWClass',Nil);
       HWND2:=FindWindowEx(HWND,0,'Shell DocObject View',Nil);
       if (HWND2 <> 0)then
       begin
          result:=true;
       end;
  end;

Imprimer en HTML depuis une appli
 
 

procedure TForm1.WebBrowser_V1NavigateComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
HTMLDoc: IHTMLDocument2;
HTMLWnd: IHTMLWindow2;
HTMLWindow3: IHTMLWindow3;
begin
HTMLDoc := (Sender as TWebBrowser).Document as IHTMLDocument2;
if HTMLDoc = nil then
raise Exception.Create('Couldn''t convert the WebBrowser to an IHTMLDocument2');
HTMLWnd := HTMLDoc.parentWindow;
HTMLWindow3 := HTMLWnd as IHTMLWindow3;
// Finally, we get to the print method
HTMLWindow3.print;
end;

Renvoyer un fichier de + de 48 K par HTTP

var p: pchar;
FContent: string;
FContentLength: integer;
i: integer;
len: cardinal;
ms: TMemoryStream;
begin
FContentLength := req.ContentLength;
SetString(FContent, pchar(req.Content), Length(req.Content));
SetLength(FContent, FContentLength);
len := Length(req.Content);
p := pchar(FContent) + len;
// get the entire request
while len < FContentLength do
begin
i := req.ReadClient(p^, FContentLength - len);
Inc(len, i); Inc(p, i);
end;
end;
 
 
 

EDI

OnDrawColumnCell

procedure TF_SaisieDevis.DBGrid1DrawColumnCell(Sender: TObject;
  const Rect: TRect; DataCol: Integer; Column: TColumn;
  State: TGridDrawState);
begin
If Datacol = 3 Then
  begin
    if (QdetailUnite.Value ='ML') Then
    DbGrid1.Canvas.Brush.Color := Clred
         else
    DbGrid1.Canvas.Brush.Color := ClBlue;
  end;
    DbGrid1.DefaultDrawColumnCell(Rect,DataCol,Column,State);
end;

Simuler une touche par programmation

keybd_event(
    BYTE bVk, // virtual-key code
    BYTE bScan, // hardware scan code
    DWORD dwFlags, // flags specifying various function options
    DWORD dwExtraInfo  // additional data associated with keystroke
   );

procedure ImpressionEcran;
Var
  HDcScreen,HDcCompatible:HDC;
  HBMScreen:THandle;
  Bmp:TBitmap;
  Resultat:Boolean;
begin
  Try
    Bmp:=TBitmap.Create;
    Bmp.Width:=Screen.Width;
    Bmp.Height:=Screen.Height;
    hdcScreen:=CreateDC('DISPLAY',Nil,Nil,Nil);
    hdcCompatible:=CreateCompatibleDC(hdcScreen);
    HBMScreen:=CreateCompatibleBitmap(hdcScreen,GetDeviceCaps(hdcScreen,HO
RZRES),GetDeviceCaps(hdcScreen,VERTRES));
    SelectObject(hdcCompatible, hbmScreen);
    Resultat:=BitBlt(Bmp.Canvas.Handle,0,0,Bmp.Width,Bmp.Height,hdcScreen,
0,0,SRCCOPY);
  Finally
    Bmp.Free;
  End;
End;

Caption de plusieurs lignes

procedure TForm1.Button1Click(Sender: TObject);
var
    i:integer;
begin
    i:=GetWindowLong(Button1.Handle,GWL_STYLE);
    SetWindowLong(Button1.Handle,GWL_STYLE,i or BS_MULTILINE or
BS_CENTER
    or BS_VCENTER);
    Button1.Caption:=' Un'#13'Deux';
end;

Intercepter un copier/coller

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Clipbrd,
  StdCtrls, ExtCtrls, ComCtrls, Buttons;

type
  TFormMain = class(TForm)
   // ...
  private
    { Déclarations privées }
    procedure WMDrawClipboard(var msg: TWMDRAWCLIPBOARD); message
WM_DRAWCLIPBOARD;
    procedure WMChangeCBChain(var msg: TWMCHANGECBCHAIN); message
WM_CHANGECBCHAIN;
    // ...
  public
    { Déclarations publiques }
    // ...
  end;

var
  FormMain: TFormMain;
  G_HwndClipboardViewer : HWND;

procedure TFormMain.FormCreate(Sender: TObject);
begin
  // The SetClipboardViewer function adds the specified window to the chain
of
  // clipboard viewers.
  // Clipboard viewer windows receive a WM_DRAWCLIPBOARD message whenever
the
  // content of the clipboard changes.
  G_HwndClipboardViewer := SetClipboardViewer(FormMain.Handle);
  // If the function succeeds, the return value identifies the next window
in
  // the clipboard viewer chain.
  // If an error occurs or there are no other windows in the clipboard
viewer
  // chain, the return value is NULL.
  if G_HwndClipboardViewer = NULL then
  begin
    MessageDlg('Erreur: Impossible de recevoir les messages du Clipboard',
mtError,[mbOk], 0);
  end;

  // ...
end;

procedure TFormMain.FormDestroy(Sender: TObject);
begin
  // A clipboard viewer window must eventually remove itself from the
clipboard
  // viewer chain by calling the ChangeClipboardChain function
  // for example, in response to the WM_DESTROY message.
  // The ChangeClipboardChain function removes a specified window from the
chain
  // of clipboard viewers.
  if G_HwndClipboardViewer <> NULL then
    ChangeClipboardChain(FormMain.Handle,G_HwndClipboardViewer);

  // ...
end;

procedure TFormMain.WMDrawClipboard(var msg: TWMDRAWCLIPBOARD);
begin
  // The WM_DRAWCLIPBOARD message is sent to the first window in the
clipboard
  // viewer chain when the content of the clipboard changes.
  // This enables a clipboard viewer window to display the new content of
the clipboard.
  {
  Remarks
    Only clipboard viewer windows receive this message.
    These are windows that have been added to the clipboard viewer chain by
    using the SetClipboardViewer function.
    Each window that receives the WM_DRAWCLIPBOARD message must call
    the SendMessage function to pass the message on to the next window in
the
    clipboard viewer chain.
    The handle of the next window in the chain is returned by
SetClipboardViewer,
    and may change in response to a WM_CHANGECBCHAIN message.
  }
  SendMessage(G_HwndClipboardViewer, WM_DRAWCLIPBOARD, 0, 0);
  msg.Result := 0;

  { cf; aide delphi:
  S'agissant de l'objet Clipboard, Clear supprime le contenu du
Presse-papiers ; ceci se produit automatiquement à
  chaque fois que des données sont ajoutées dans le Presse-papiers
(opérations couper et copier).
  }
  Clipboard.Clear;

// Ou traiter selon le format dans le presse papier
  // Is it Text in the Clipboard ?
  if Clipboard.HasFormat(CF_TEXT) then
  begin
    // ...
    Clipboard.Clear;
  end;
  // Is it Graphic Bitmap in the Clipboard ?
  if Clipboard.HasFormat(CF_BITMAP)
  then
    begin
      // ...
      Clipboard.Clear
    end
  else
  // Is it Graphic Picture in the Clipboard ?
  if Clipboard.HasFormat(CF_PICTURE) then
  begin
    // ...
    Clipboard.Clear
  end;
end;

procedure TFormMain.WMChangeCBChain(var msg: TWMCHANGECBCHAIN);
begin
  // The WM_CHANGECBCHAIN message is sent to the first window in the
clipboard
  // viewer chain when a window is being removed from the chain
  {
  Parameters
    hwndRemove
      Value of wParam.
      Identifies the window being removed from the clipboard viewer chain.
    hwndNext
      Value of lParam.
      Identifies the next window in the chain following the window being
removed.
      This parameter is NULL if the window being removed is the last window
in the chain.

  Return Value
    If an application processes this message, it should return zero.

  Remarks
    Each clipboard viewer window saves the handle of the next window in the
    clipboard viewer chain. Initially, this handle is the return value of
the
    SetClipboardViewer function.
    When a clipboard viewer window receives the WM_CHANGECBCHAIN message,
    it should call the SendMessage function to pass the message to the next
    window in the chain, unless the next window is the window being removed.
    In this case, the clipboard viewer should save the handle specified by
    hwndNext as the next window in the chain.
  }
  if Msg.Next <> NULL then
  begin
    G_HwndClipboardViewer := Msg.Next;
    Msg.Result := SendMessage(Msg.Next, WM_CHANGECBCHAIN, Msg.Remove,
Msg.Next);
  end;
end;

Vider la corbeille

procedure EmptyRecycleBin;
{ proc to empty the recycle bin. }
const
  SHERB_NOCONFIRMATION = $00000001;
  SHERB_NOPROGRESSUI   = $00000002;
  SHERB_NOSOUND        = $00000004;
type
  TSHEmptyRecycleBin = function (Wnd: HWND;
                                 LPCTSTR: PChar;
                                 DWORD: Word): integer; stdcall;
var
  SHEmptyRecycleBin: TSHEmptyRecycleBin;
  LibHandle: THandle;
begin
   LibHandle := LoadLibrary(PChar('Shell32.dll'));
   if LibHandle <> 0 then
     @SHEmptyRecycleBin := GetProcAddress(LibHandle, 'SHEmptyRecycleBinA')
   else
     begin
       MessageDlg('Failed to load Shell32.dll.', mtError, [mbOK], 0);
       Exit;
     end;

  if @SHEmptyRecycleBin <> nil then
    SHEmptyRecycleBin(Application.Handle,
                      '',
                      SHERB_NOCONFIRMATION or
                      SHERB_NOPROGRESSUI or
                      SHERB_NOSOUND);

  FreeLibrary(LibHandle);
  @SHEmptyRecycleBin := nil;
end;

Changer la résolution
 
 

function ChangeDisplay(WResolution, HResolution, Depth: DWORD) : Boolean;
var
  i: Integer;
  DevMode: TDevMode;
begin
  Result := False;
  i:=0;
  while EnumDisplaySettings(nil,i,DevMode) do begin
    with DevMode do begin
      if (dmPelsWidth = WResolution) and
         (dmPelsHeight = HResolution) and
         (dmBitsPerPel = Depth) then
        if ChangeDisplaySettings(DevMode,CDS_UPDATEREGISTRY) =
          DISP_CHANGE_SUCCESSFUL then begin
          Result := True;
          Break;
        end;
      Inc(i);
    end;
  end;
end;

Eteindre ou rallumer l'écran
Eteindre
 

Sendmessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,2);

Rallumer:
 

Sendmessage(Application.Handle,WM_SYSCOMMAND,SC_MONITORPOWER,-1);

 

ADO

Connection=CreateObject('ADODB.Connection');
Connection.Provider='QLOLEDB.1'
 Connection.Properties ('Data Source'.Value ='061-BDC-01'//Server name
Connection.Properties ('Initial Catalog'.Value ='RG61'//Database name
Connection.Properties ('Integrated Security'.Value ='SPI'//Security
Connection.Open();

RecordSet=CreateObject('ADODB.RecordSet');

RecordSet.Open('select * from SBJ_T_SUBJECT' Connection);
.....
RecordSet.Close();

DATABASE

procedure TFmConfigureDSNs.SystemDSNs;
var
  Reg : TRegistry;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_LOCAL_MACHINE;

  Reg.OpenKey('Software\ODBC\ODBC.INI\KeyName',True);
  with Reg do
  begin
    WriteString('Database',NomDeLaBase);
    WriteString('Description','Descrption que vous voulez');
    WriteString('Driver','WOD50T.DLL'); // Nom du driver de votre SGBD
    WriteString('Server',''(local)''); // Nom du serveur
    ***Ajoutez tout ce qui est nécessaire (uid, pwd etc...).***
    CloseKey;
  end;
end;

DIVERS

unit WinApi;

interface

uses windows, sysUtils, Classes;

function obtainUserName : string;
function obtainComputerName : string;

implementation

var
 size    : dword;
 buffer  : PChar;

function obtainUserName : string;
begin
   size := 256;
   buffer := strAlloc(size);
   size   := size - 1;
   GetUserName(buffer, size);
   result := StrPas(buffer);
   strDispose(Buffer);
end;

function obtainComputerName : string;
begin
   size := 256;
   buffer := strAlloc(size);
   size   := size - 1;
   GetComputerName(buffer , size);
   result := StrPas(buffer);
   strDispose(Buffer);
end;

end.

Savoir si un utilisateur est connecté en tant qu'administrateur

function IsAdmin: Boolean;
var
hAccessToken: THandle;
ptgGroups: PTokenGroups;
dwInfoBufferSize: DWORD;
psidAdministrators: PSID;
x: Integer;
bSuccess: BOOL;
begin
Result := False;
bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,
hAccessToken);
if not bSuccess then
begin
if GetLastError = ERROR_NO_TOKEN then
bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
hAccessToken);
end;
if bSuccess then
begin
GetMem(ptgGroups, 1024);
bSuccess := GetTokenInformation(hAccessToken, TokenGroups,
ptgGroups, 1024, dwInfoBufferSize);
CloseHandle(hAccessToken);
if bSuccess then
begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0, psidAdministrators);
{$R-}
for x := 0 to ptgGroups.GroupCount - 1 do
if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then
begin
Result := True;
Break;
end;
{$R+}
FreeSid(psidAdministrators);
end;
FreeMem(ptgGroups);
end;
end;
 
 

procedure TForm1.Button1Click(Sender: TObject);
begin
if isAdmin then
begin
ShowMessage('Logged in as Administrator');
end;

end;

FUNCTION ChercheTexte(Const Chaine,Texte:ShortString):Integer; Assembler;
Var
    Table : Array[Byte] of Byte;
Asm
    push  edi        {Il faut conserver EDI, ESI, EBX, ESP et EBP}
    push  esi
    push  ebx
    cld

    {Récupère longueur(eax) et adresse(esi) de Chaine}
    mov   esi,Chaine
    xor   eax,eax    {Pour conversion byte -> 32b}
    lodsb            {Récup longueur Chaine et pointe premier car}
    or    al,al      {Si longueur=0 : Exit}
    jz    @Inconnue

    {Récupère longueur(ecx) et adresse(edi) de Texte}
    mov   edi,Texte
    xor   ecx,ecx    {Pour conversion byte -> 32b}
    mov   cl,[edi]   {Récup longueur Texte}
    jcxz  @Inconnue  {Si longueur=0 : Exit}
    inc   edi        {Saute l'octet longueur et pointe premier car}

    {Si Long(Chaine)=1, c'est 1 caractère -> recherche simplifiée}
    cmp   eax,1
    jne   @Boyer_Moore

{--- Recherche simplifiée ---}
    lodsb            {Récupère l'unique caractère de Chaine}
    repne scasb      {et le cherche dans Texte}
    jnz   @Inconnue  {pas trouvé, exit}

    mov   esi,edi
    sub   esi,2
    jmp   @Corresp

{--- Recherche Boyer-Moore ---}
@Boyer_Moore:

    push  edi        {on aura besoin de @ du premier car de Texte}
    mov   edx,ecx    {et de longueur de Texte plus loin}

    {Remplis le tableau avec la longueur de Chaine}
    lea   edi,Table  {ebx Pointe la table des sauts}
    mov   ah,al      {AH = AL = Longueur de Chaine}
    mov   ecx,128    {taille de table des sauts / 2 (écrit des words)}
    rep   stosw      {remplis avec longueur de Chaine, ecx=0 en fin de bcle}

    {Place dans la table(Car) la distance entre Car et fin de Chaine -1}
    xor   ah,ah
    mov   ecx,eax    {ecx = Longueur Chaine-1}
    dec   ecx
    push  ecx        {on a besoin de longueur(Chaine)-1 plus loin}

    lea   ebx,Table  {ebx = @Table des sauts, esi pointe encore début de Chaine}
@Remplis:
    lodsb            {Récupère un car de Chaine}
    mov   [ebx+eax],cl {Met la distance à sauter}
    loop  @Remplis
    lodsb            {ecx=0 : idem pour dernier caractère}
    mov   [ebx+eax],cl

    {Initialise pointeurs pour recherche}
    std              {comparaisons à partir de la fin}

    dec   edx        {edx = Length(Texte)-1}
    pop   eax        {Récupère longueur(Chaine)-1 = longueur du premier saut}
    pop   esi        {esi pointe Texte, ebx pointe encore Table de sauts}

@SautSuivant:
    sub   edx,eax    {Texte épuisé ?}
    jc    @Inconnue  {oui, pas de correspondance}

    add   esi,eax    {Avance pointeur du nbre de car à sauter}
    mov   al,[esi]   {Récup car pointé}
    mov   al,[ebx+eax] {et récup nbre de car à sauter dans table sauts}
    or    al,al      {Si 0, peut-être correspondance : compare chaines}
    jne   @SautSuivant

    {Occurence possible, compare les chaines}
    mov   eax,esi    {Sauve Pointeur dans Texte}
    dec   esi       {saute le caractère comparé (indirectement via table)}

    mov   edi,Chaine {Pointe chaine à rechercher}
    mov   cl,[edi]   {et ecx = longueur à comparer}
    dec   ecx        {dernier car déjà testé}
    add   edi,ecx    {edi pointe avant dernier car de Chaine}
    repe  cmpsb      {compare à rebrousse-poil}
    je    @Corresp   {Egales : correspondance trouvée !}

    mov   esi,eax    {Sinon récupère pointeur dans Texte}
    mov   eax,1      {Sautera 1 seul caractère}
    jmp   @SautSuivant

@Corresp:
    mov   eax,esi    {Récup position dans Texte}
    sub   eax,Texte  {Ôte adresse de début de Texte+2}
    inc   eax
    cld
    jmp   @Fin

@Inconnue:
    xor   eax,eax    {Pas d'occurence, retourne 0}

@Fin:
    pop   ebx
    pop   esi
    pop   edi
End;

Tuer mon appli du "kill task menu"
Déclarez cette fonction dans votre progr.:
 

function RegisterServiceProcess (ProcessID,RType:DWord):DWord; stdcall;external 'KERNEL32.DLL';

Sous les événements FormCreate and FormDestroy entrez ce code:
 

procedure TForm1.FormCreate(Sender: TObject); begin   RegisterServiceProcess(GetCurrentProcessID,1); end; procedure TForm1.FormDestroy(Sender: TObject); begin   RegisterServiceProcess(GetCurrentProcessID,0); end;