Çeşitli Delphi Kodları

'Programlama' forumunda sha. tarafından 10 Ağu 2009 tarihinde açılan konu

Konu etiketleri:
  1. sha.

    sha. ..daha çirkin, daha huysuz

    Programdan windows wallpaper'i degistirme islemi

    procedure TForm1.ChangeWallPaper(const FileName: string);
    begin
    SystemParametersInfoA(SPI_SETDESKWALLPAPER, 0,
    PChar(FileName), SPIF_UPDATEINIFILE);
    end;


    *****************
    Eliptik form olusturulmasi

    procedure TForm1.FormCreate(Sender: TObject);
    var
    region: HRgn;
    begin
    { koselerden 25 pixel keser }
    region:=CreateRoundRectRgn(1, 1, 484, 312, 25, 25);
    SetWindowRgn(handle, region, true);
    end;


    ******************
    Programdan bir internet adresini yeni ve istenilen ozelliklerde bir pencerede acmak

    uses
    comobj;
    procedure TFmMain.GotoUrl(SUrl: string; Width, Height: Integer; ToolBar: Boolean);
    const
    csOLEObjName = 'InternetExplorer.Application';
    var
    IE : Variant;
    WinHanlde : HWnd;
    begin
    if( VarIsEmpty( IE ) )then
    begin
    IE := CreateOleObject( csOLEObjName );
    IE.Visible := true;
    IE.Toolbar := Toolbar;
    if Width > 0 then IE.Width := Width;
    if Height > 0 then IE.Height := Height;
    IE.Navigate( sURL );
    end else
    begin
    WinHanlde := FindWIndow( 'IEFrame', nil );
    if( 0 <> WinHanlde )then
    begin
    IE.Navigate( sURL );
    SetForegroundWindow( WinHanlde );
    end else
    begin
    ShowMessage('Internet Explorer acilamadi');
    end;
    end;
    end;

    // kullanimi:

    {adresi yukseklik ve genislik belirtmeden acar }
    GotoUrl('http://www.delphiturk.com', 0, 0, True);
    {adresi yukseklik ve genislik belirterek toolbar
    olmayan bir pencerede acar }
    GotoUrl('http://www.delphiturk.com', 400, 400, False);


    ************************
    Programdan dosya kopyalama islemi


    procedure FileCopy(const SourceFileName, TargetFileName: string );
    var
    S, T: TFileStream;
    begin
    S := TFileStream.Create(sourcefilename, fmOpenRead );
    try
    T := TFileStream.Create(targetfilename, fmOpenWrite or fmCreate);
    try
    T.CopyFrom(S, S.Size ) ;
    finally
    T.Free;
    end;
    finally
    S.Free;
    end;
    end;


    ******************************
    Herhangi bir Wincontrol' veya tüm ekran nasil bitmap olarak alinir ?


    function GetDcAsBitmap(DC: HDC; Bitmap: TBitmap; W, H: Cardinal): Boolean;
    var
    hdcCompatible: HDC;
    hbmScreen: HBitmap;
    begin
    Result := False;
    if DC = 0 then Exit;
    hdcCompatible := CreateCompatibleDC(DC);
    hbmScreen := CreateCompatibleBitmap(DC, W, H);
    if (hbmScreen = 0) then Exit;
    if (SelectObject(hdcCompatible, hbmScreen)=0) then Exit;
    if not(BitBlt(hdcCompatible, 0,0, W, H, DC, 0,0, SRCCOPY)) then
    Exit;
    Bitmap.Handle := HbmScreen;
    Bitmap.Dormant;
    Result := True;
    end;

    function GetScreenAsBitmap(Bitmap: TBitmap): Boolean;
    var ScreenDC: HDC;
    begin
    ScreenDC := CreateDC('DISPLAY', nil, nil, nil);
    Result := GetDCAsBitmap(ScreenDC, Bitmap,
    GetDeviceCaps(ScreenDC, HORZRES),
    GetDeviceCaps(ScreenDC, VERTRES)
    );
    end;

    function GetWindowAsBitmap(const WindowName: string;
    Bitmap: TBitmap): Boolean;
    var Wnd: HWnd;
    Rect: TRect;
    begin
    Wnd := FindWindow(nil, PChar(WindowName));
    GetWindowRect(Wnd, Rect);
    Result := GetDCAsBitmap(GetWindowDC(Wnd), Bitmap,
    Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
    end;

    function GetWindowAsBitmap(Wnd: HWnd; Bitmap: TBitmap): Boolean;
    var
    Rect: TRect;
    begin
    GetWindowRect(Wnd, Rect);
    Result := GetDCAsBitmap(GetWindowDC(Wnd), Bitmap,
    Rect.Right - Rect.Left, Rect.Bottom - Rect.Top);
    end;

    // Kullanimi:
    {Button1 yüzeyini resim olarak al}
    GetWindowAsBitmap(Button1.Handle, Image1.Picture.Bitmap);
    {Tüm ekrani resim olarak al}
    GetScreenAsBitmap(Image1.Picture.Bitmap);

    *****************************
     

Bu Sayfayı Paylaş