Delphi (6.) - Grafika a zvuky

Tady přináším pokračování zdrojáků pro Delphi. V těchto shrnuji práci s obrázky, ikonami, kurzory, zvuky, nastavováním a vzájemnými konverzemi.

Konvertování JPEGu do bitmapy:

uses jpeg;

var

  MyJPEG : TJPEGImage;                    // Zdrojový soubor
  MyBMP : TBitmap;                        // Cílový soubor
begin
  MyJPEG := TJPEGImage.Create;            // Vytvoří MyJPG
  MyJPEG.LoadFromFile('YourJpegHere.jpg');// Otevře MyJPG
  MyBMP := TBitmap.Create;                // Vytvoří MyBMP
  MyBMP.Width := MyJPEG.Width;            // Nastaví šířku
  MyBMP.Height := MyJPEG.Height;          // Nastaví výšku
  MyBMP.Canvas.Draw(0,0,MyJPEG);          // Vykreslí MyJPG do MyBMP
  MyBMP.SaveToFile('YourBmpHere.bmp');    // Uloží MyBMP
  MyBitmap.free;                          // Uvolní MyBMP z paměti
  MyJpeg.free;                            // Uvolní MyJPG z paměti
end;

Konvertování bitmapy do JPEGu:

uses jpeg;

var
  MyBMP : TBitmap;                        // Zdrojový soubor
  MyJPEG : TJPEGImage;                    // Cílový soubor
begin
  MyBMP := TBitmap.Create;                // Vytvoří MyBMP
  MyBMP.LoadFromFile('YourBmpHere.BMP');  // Otevře bitmapu
  MyJPEG := TJPEGImage.Create;            // Vytvoří MyJPG
  MyJPEG.Assign(MyBMP);                   // Připojí MyBMP k MyJPG
  MyJPEG.SaveToFile('YourJpegHere.JPEG'); // Uloží jpeg
  MyBitmap.free;                          // Uvolní MyBMP z paměti
  MyJpeg.free;                            // Uvolní MyJPG z paměti
end;

Načtení kurzoru *.cur nebo *.ani:

Konstanta crCur musí být větší jak 0 nebo menší jak -22, protože čísla -22 až 0 jsou obsazené jinými kurzory.

var Cur:HDC;
  const crCur=1; 
begin

  Cur:=LoadCursorFromFile('kurzor .cur nebo .ani');
  Screen.Cursors[crCur]:=Cur;
  Screen.Cursor:=crCur;
end;

Screenshot plochy:

Existují 2 alternativy:

procedure TForm1.GrabScreen;
var
  DeskTopDC: HDc;
  DeskTopCanvas: TCanvas;
  DeskTopRect: TRect;
begin
  DeskTopDC := GetWindowDC(GetDeskTopWindow); // Získá Handle obrazovky
  DeskTopCanvas := TCanvas.Create;
  DeskTopCanvas.Handle := DeskTopDC;
  DeskTopRect := Rect(0,0,Screen.Width,Screen.Height);
  ScrnForm.Canvas.CopyRect(DeskTopRect,DeskTopCanvas,DeskTopRect);
  ReleaseDC(GetDeskTopWindow,DeskTopDC); // Uvolnění z paměti
end;



procedure TForm1.GrabScreen;
var
  DeskTopDC: HDc;
begin
  DeskTopDC:=CreateDC('Display',nil,nil,nil);
  BitBlt(Canvas.Handle,0,0,Screen.Width,Screen.Height,DeskTopDC,0,0,SRCCOPY);
  ReleaseDC(Application.Handle,DeskTopDC);
end;

získání ikony ze souboru:

Tato funkce získá ze souboru "C:\Win98\System\Shell32.dll" ikonu s indexem 50

uses ShellAPI;

procedure ExtractIcon;
begin
  image1.picture.Icon.Handle:=extracticon(application.Handle,'C:\Win98\System\Shell32.dll',50);
end;

Přehrání souboru *.wav:

uses MMSystem;

begin
  PlaySound('c:\sound.wav', 0, SND_FILENAME + SND_ASYNC); //přehraje c:\sound.wav
end;

Změna systémových barev:

Tento kód změní barvu záhlaví okna na tmavě červenou. Pořadí RGB je u proměnné typu TRGBTriple přehozené

var Color:Integer;
  RGB:TRGBTriple;
begin
  Color:=COLOR_ACTIVECAPTION;
  RGB.rgbtBlue:=128;//Červená
  RGB.rgbtGreen:=0;//Zelená
  RGB.rgbtRed:=0;//Modrá
  SetSysColors(1,Color,RGB);
end;

Jak vytvořit form za běhu aplikace:

var
  MyForm: tForm;
begin
  MyForm := TForm.Create(form1);
  With MyForm do begin
    Top := 100;
    Left := 100;
    Width := 320;
    Height := 200;
    Name := 'My form'
    Caption := 'Novej Form'
    show;
  end;
end;

Jak vytvořit kulatý formulář?

var
  R : HRgn;
begin
form1.width := 200;                       // nastaví šířku formu na 200
form1.height := form1.width;              // nastavení čtvercového formu
R := CreateEllipticRgn(0,0,width,height); // nastaví velikost elipsy
SetWindowRgn(Handle,R,True);              // aplikuje elipsu na form
end;

Jak změnit wallpaper:

Proceduru voláme příkazem např. ChangeWallpaper('C:\windows\wall.bmp');

procedure TForm1.ChangeWallpaper(Path: string);
begin
  SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, PChar(Path), 0)
end;

Konvertování barvy do HEX:

function ColorToHex(Color: integer): string;
var

  r,g,b: byte;
begin
  r:=GetRValue(Color);
  g:=GetGValue(Color);
  b:=GetBValue(Color);
  Result:=IntToHex(r,2)+IntToHex(g,2)+IntToHex(b,2);
end;

Jak zjistit a změnit hlasitost:

uses
  mmsystem;  line

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
  public
    myvolume: array[0..10] of longint;
  end;


procedure TForm1.FormCreate(Sender: TObject);
var
  Count, i: integer;
begin

  Count := auxGetNumDevs;

  for i := 0 to Count do begin //The i is the device: I.E. 0=Wav Volume
    //Gets the values that the user has set
    auxgetvolume(i,addr(myvolume[i])); 

    //Sets the volume very very low
    auxsetvolume(i,longint(9000)*65536+longint(9000));  

  end; //The reason for the 9000*65536 + 9000 is if you wanted to do left and right channels
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
var
  Count, i: integer;
begin
  Count := auxGetNumDevs;

  for i := 0 to Count do begin
    //Sets the volume back to the users old settings
    auxsetvolume(i,myvolume[i]); 
  end;
end;

end.

Nastavení hlasitosti wavů:

uses MMSystem;

1) ScrollBar1.MinValue nastavte na 0 a MaxValue na 65

2) do ScrollBar1Change napište

begin
  waveOutSetVolume(a,ScrollBar1.Position * 1000);
end;

Jak přehrát XM, S3M, MOD?

uses midasdll, sysutils;

procedure MIDASerror;
begin
  WriteLn('MIDAS error: ', MIDASgetErrorMessage(MIDASgetLastError));
  MIDASclose;
  halt;
end;

var
  module : MIDASmodule;
  playHandle : MIDASmodulePlayHandle;

begin
  MIDASstartup;
  if not MIDASinit then MIDASerror;
  if not MIDASstartBackgroundPlay(0) then MIDASerror;
  module := MIDASloadModule('templsun.xm');
  if module = NIL then MIDASerror;
  playHandle := MIDASplayModule(module, true);
  if playHandle = 0 then MIDASerror;
  WriteLn('Playing - press enter');
  ReadLn;
  if not MIDASstopModule(playHandle) then MIDASerror;
  if not MIDASfreeModule(module) then MIDASerror;
  if not MIDASstopBackgroundPlay then MIDASerror;
  if not MIDASclose then MIDASerror;
end.

Jak přehrát mp3 ?

uses MPEGPlayer;

var MPlayer:TMPEGPlayer;

procedure HrajPisen;
begin
  mplayer:=tmpegplayer.create(self);
  mplayer.init;  // Inicializuje prehravac
  mplayer.StreamName:="pisen.mp3";
  mplayer.Open;
  mplayer.Play;
end;

procedure ZastavPisen;
begin
  mplayer.stop;
  mplayer.close;
  mplayer.DeInit;
  mplayer.free;
end;

Zapnutí a vypnutí spořiče obrazovky:

begin
function ActivateScreenSaver(Activate: boolean): boolean;
var
  IntActive: byte;  //False (0) is off, True (1) is on.
begin
  if Activate then
    IntActive := 1
  else
    IntActive := 0;
  Result := SystemParametersInfo(SPI_SETSCREENSAVEACTIVE, IntActive, nil, 0);
end;

Vyšlo 15.10.2001, v blogu: 0 1 2 3 4 5 6 7 8

Děkuji, že jste se rozhodl(a) přečíst tento článek. Budu rád i za komentář. Pokud Vás tento článek zaujal a rádi byste jej doporučili ostatním, podpořte mně prosím tím, že věnujete minutku svého času a uděláte mi reklamu na linkuj.cz, vybrali.sme.sk či jagg.cz. Přeji příjemné čtení

Poslední články

• 3D Studio MAX (8.) - Tvorba hořící zápalky
• 'DOOM' 3D Engine techniques
• OpenGL (3.) - Procházení scénou
• 3D Studio MAX (7.) - 3D text
• 3D Studio MAX (6.) - Vznášející se dým
• Jak se dostat do BIOSů
• Adobe Photoshop (3.) - Textura vodní hladiny
• Delphi (6.) - Grafika a zvuky
• 3D Studio MAX (5.) - Přízemní mlha ve 3D Studiu MAX
• Delphi (5.) - Zajímavé zdrojáky 2.
• Photoshop Tutoriály (2.) - Temná hvězdná obloha
• OpenGL (2.) - Čtverec s texturou
• OpenGL (1.) - Čtverec s interpolací barvy
• 3D Studio MAX (4.) - Jak vytvořit laser
• Delphi (4.) - Zajímavé zdrojáky

Diskuse k blogu

Zatím nikdo nevložil komentář. Chcete být první? Přidání příspěvku