Changing Position of Current Played Track in TMediaPlayer

Problem/Question/Abstract:

Difficulties in moving forward/backward (changing position) the current played track in TMediaPlayer ??

Answer:

To change the current position of current playing track, you just need to take the usefull (advance) of two event: 1) onTimer of TTimer and 2) onChange of TScrollbar. For full code, read below.

Here are the codes:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if (OpenDialog1.Execute) then
  begin
    Timer1.Enabled := false;
    MediaPlayer1.FileName := OpenDialog1.FileName;
    MediaPlayer1.Open;
    ScrollBar1.Max := MediaPlayer1.Length;
    ScrollBar1.Position := 0;
    Timer1.Enabled := true;
  end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
  ScrollBar1.OnChange := nil; // disable the event handler
  ScrollBar1.Position := MediaPlayer1.Position;
  ScrollBar1.OnChange := ScrollBar1Change; // enable it again
end;

procedure TForm1.ScrollBar1Change(Sender: TObject);
begin
  MediaPlayer1.Pause;
  MediaPlayer1.Position := ScrollBar1.Position;
  MediaPlayer1.Play;
end;

First thing you must do here is initiate the MAX range of TScrollBar with the length of the current song track (look at Button1Click above).

Then add onTimer event code like above, and so the onChange event of TScrollBar.
The key is you must set TMediaPlayer's position with your selected scroolbar position for each of onTimer happen. Do this by calling onChange event of TScrollBar in onTimer event of TTimer.

Changing the screen resolution

Problem/Question/Abstract:

How can I change the screen resolution?

Answer:

To change the screen resolution you can use the following function which is a wrapper for the Windows API ChangeDisplaySettings. The function takes the desired width and height as parameters and returns
the return value of ChangeDisplaySettings (see the documentation for more datails).

function SetScreenResolution(Width, Height: integer): Longint;
var
  DeviceMode: TDeviceMode;
begin
  with DeviceMode do
  begin
    dmSize := SizeOf(TDeviceMode);
    dmPelsWidth := Width;
    dmPelsHeight := Height;
    dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
  end;
  Result := ChangeDisplaySettings(DeviceMode, CDS_UPDATEREGISTRY);
end;

You can use ChangeDisplaySettings to change other properties of the display like the color depth and the display frequency.

Sample call

In the following example first we get the current screen resolution before setting it to 800x600, and then we restore it calling SetScreenResolution again.

var
  OldWidth, OldHeight: integer;

procedure TForm1.Button1Click(Sender: TObject);
begin
  OldWidth := GetSystemMetrics(SM_CXSCREEN);
  OldHeight := GetSystemMetrics(SM_CYSCREEN);
  SetScreenResolution(800, 600);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  SetScreenResolution(OldWidth, OldHeight);
end;

Copyright (c) 2001 Ernesto De Spirito
Visit: http://www.latiumsoftware.com/delphi-newsletter.php

How to find a window by its (partial) title and close it (2)

Problem/Question/Abstract:

I am trying to figure out how I can get the handle of the main window of another application so I can terminate that program. I simply need to terminate one application from another application.

Answer:

This Code waits x seconds for a certain window to appear, tries to put it on top and send keystrokes to it. Pay special attention to the FindWindow Command. The Caption is the "EXACT" text in the window title bar. To do a partial match you have to have Windows ENUMERATE all it's open windows, then test the list that comes back.

function TMainForm.WaitForWindowAndType(WindowCaption, TextToSend: string;
  SecondsToWait: Cardinal): boolean;
var
  h: Hwnd;
  i: cardinal;
  vk: word;
begin
  i := SecondsToWait;
  repeat
    Application.ProcessMessages;
    sleep(1000);
    h := FindWindow(nil, pchar(WindowCaption));
    dec(i);
  until
    (i < 1) or (h > 0);
  result := not (h < 1);
  if h < 1 then
  begin
    {do nothing}
  end
  else
  begin
    memo1.Lines.Add(format('Found %s, after %d seconds.', [WindowCaption,
                 SecondsToWait - i]));
    sendmessage(h, WM_ACTIVATE, 0, 0);
    sendmessage(h, WM_SETFOCUS, 0, 0);
    i := 1;
    while integer(i) <= length(TextToSend) do
    begin
      if texttosend[i] = '@' then
      begin
        inc(i);
        vk := VkKeyScan(texttosend[i]);
        keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), 0, 0); {this is the ALT key}
        keybd_event(vk, MapVirtualKey(VK, 0), 0, 0); {ALT Letter}
        keybd_event(vk, MapVirtualKey(VK, 0), KEYEVENTF_KEYUP, 0); {Letter UP}
        keybd_event(VK_MENU, MapVirtualKey(VK_MENU, 0), KEYEVENTF_KEYUP, 0); {ALT UP}
      end
      else
      begin
        vk := VkKeyScan(texttosend[i]);
        if vk shr 8 = 1 then
        begin
          keybd_event(VK_SHIFT, 0, 0, 0);
          keybd_event(vk, 0, 0, 0);
          keybd_event(vk, 0, KEYEVENTF_KEYUP, 0);
          keybd_event(VK_SHIFT, 0, KEYEVENTF_KEYUP, 0);
        end
        else
        begin
          keybd_event(vk, 0, 0, 0);
          keybd_event(vk, 0, KEYEVENTF_KEYUP, 0);
        end;
      end;
      sleep(100);
      inc(i);
    end;
  end;
end;

Missing unit 'Proxies.pas'

Problem/Question/Abstract:

If your application or expert uses designtime information, you have to replace
uses DsgnIntf;
with
uses DesignIntf, DesignEditors;
But then you will run into an error message 'Cannot find unit Proxies.pas'

Answer:

The solution is to add DesignIde.dcp to your list of required packages.

You will have to ensure that the run-time package does not require the design-time package(s). This change in Delphi 6 enforces Borland's licence restrictions on designtime editors more strongly, which have been in the license documents since Delphi 3, I believe.

Detect your own IP Address

Problem/Question/Abstract:

Detect your own IP Address

Answer:

uses
  WinSock; // type PHostEnt

function My_IP_Address: longint;
var
  buf: array[0..255] of char;
  RemoteHost: PHostEnt;
begin
  Winsock.GetHostName(@buf, 255);
  RemoteHost := Winsock.GetHostByName(buf);
  if RemoteHost = nil then
    My_IP_Address := winsock.htonl($07000001) { 127.0.0.1 }
  else
    My_IP_Address := longint(pointer(RemoteHost^.h_addr_list^)^);
  Result := Winsock.ntohl(Result);
end;

Extract and display version info from files

Problem/Question/Abstract:

Extract and display version info from files

Answer:

This routine shows how to retrieve version information from the Windows resources and displays it with a ShowMessage box:

procedure TForm1.GetVersionInfo;
const
  n_Info = 10;
  InfoStr: array[1..n_Info] of string =
  ('CompanyName', 'FileDescription', 'FileVersion', 'InternalName',
    'LegalCopyright', 'LegalTradeMarks', 'OriginalFilename',
    'ProductName', 'ProductVersion', 'Comments');
var
  Info: string;
  BuffSize,
    Len, i: Integer;
  Buff: PChar;
  Value: PChar;
begin
  Info := Application.ExeName;
  BuffSize := GetFileVersionInfoSize(PChar(Info), BuffSize);
  if BuffSize > 0 then
  begin
    Buff := AllocMem(BuffSize);
    Memo1.Lines.Add('FileVersionInfoSize=' + IntToStr(BuffSize));
    GetFileVersionInfo(PChar(Info), 0, BuffSize, Buff);
    Info := Info + ':';
    for i := 1 to n_Info do
      if VerQueryValue(Buff, PChar('StringFileInfo\040904E4\' +
        InfoStr[i]), Pointer(Value), Len) then
        Info := Info + #13 + InfoStr[i] + '=' + Value;
    FreeMem(Buff, BuffSize);
    ShowMessage(Info);
  end
  else
    ShowMessage('No FileVersionInfo found');
end;

How to direct all keyboard events to a specific window

Problem/Question/Abstract:

SetCapture directs all mouse events to a specific window. Is there a similar API for the keyboard? Can this be accomplished without using hooks? I want to track what the user presses on the keyboard and mouse and allow or reject the events.

Answer:

Look up TApplication.OnMessage and study the example given, then look at the example below:


procedure TMainForm.AppMessage(var Msg: TMsg; var Handled: Boolean);
const
  BLOCKEDKEYS = [VK_TAB, VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_SPACE];
begin
  if (Msg.message = WM_KEYDOWN) then
  begin
    if (Msg.wParam in BLOCKEDKEYS) then
    begin
      Handled := True;
    end;
  end;
end;

How to restore the original volume settings after changing the volume of a wave

Problem/Question/Abstract:

I'm trying to control the left/ right channel volume of a wave. I've checked with WaveOutGetDevCaps that volume and left/ right control is supported. When I try to read the volume with WaveOutGetVolume (using "word (Wave_Mapper)" as the device), I get MMSysErr_NotSupported. I need the original volume setting in order to restore it later. WaveOutSetVolume also returns the same error.

Answer:

The code below worked for me. You will see that it is in message handlers for WaveOutOpen etc. messages. The key might be that you need the handle to an open wave device rather than simply the constant for wave_mapper.


procedure TClockForm.mm_wom_open(var Msg: TMessage);
{This code handles the WaveOutOpen message by writing two buffers of data
to the wave device.  Plus other miscellaneous housekeeping.}
begin
  waveOutGetVolume(hWave_out, @saved_volumes);
  waveOutSetVolume(hWave_out, volumes);
  waveOutPrepareHeader(hWave_out, p_wave_hdr, SizeOf(TWaveHdr));
  waveOutWrite(hWave_out, p_wave_hdr, SizeOf(TWaveHdr));
end;

procedure TClockForm.mm_wom_done(var Msg: TMessage);
{Handle the wave out done message}
begin
  waveOutSetVolume(hWave_out, saved_volumes);
  waveOutReset(hWave_out);
  waveOutClose(hWave_out);
end;

Protecting code the ... dizzy way

Problem/Question/Abstract:

Code crackers do not only use debuggers but also reverse dissassemblers, that allow viewing code in a more readable form.

Crackers set breakpoints (typically on windows calls or messages), and "peek" on the source code before actually single-stepping back.

This is a small example of how to insert VARIABLE dummy code between valid statements, which can make reverse-dissassembling and single-stepping a nightmare.

Answer:

Conditional ASM statements that actually insert dummy code are of this kind:

       JMP here
       DB byte,byte,byte,byte  ; garble data
  here:

so actually the garble data never get executed. One can find a LOT of combinations that actually drive reverse dissassemblers nuts. This include file, when used, includes variable length dummy statements

----- This is the Include file AsmDizzy.inc: ------

{$IFDEF DIZZY4}
{$UNDEF DIZZY1}
{$UNDEF DIZZY2}
{$UNDEF DIZZY3}
{$UNDEF DIZZY4}
{$ENDIF}

{$IFDEF DIZZY3}
{$IFNDEF DIZZY4}
asm
   DB $EB,$06,$55,$44,$55,$03,$a8,$09;
end;
{$DEFINE DIZZY4}
{$ENDIF}
{$ENDIF}

{$IFDEF DIZZY2}
{$IFNDEF DIZZY3}
{$IFNDEF DIZZY4}
asm
   DB $EB,$04,$75,$13,$a2,$14;
end;
{$DEFINE DIZZY3}
{$ENDIF}
{$ENDIF}
{$ENDIF}

{$IFNDEF DIZZY1}
{$IFNDEF DIZZY2}
{$IFNDEF DIZZY3}
{$IFNDEF DIZZY4}
asm
     DB $EB,$04,$55,$03,$a7,$44;
end;
{$DEFINE DIZZY2}
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$ENDIF}
;

---- End of incude file ----

Having this include file, try putting this code in the event of a button click. The code executes normally, but a lot of VARIABLE garble code is between the statements, some times 4,5 or 6 bytes wide.

procedure TForm1.Button1Click(Sender: TObject);
begin
{$I AsmDizzy.inc}
  ShowMessage('1');
{$I AsmDizzy.inc}
  ShowMessage('2');
{$I AsmDizzy.inc}
  ShowMessage('3');
{$I AsmDizzy.inc}
  ShowMessage('4');
{$I AsmDizzy.inc}
  ShowMessage('1');
end;

This can make singlestepping a nightmare, even with simple statements (ShowMessage) in-between. The .inc file can be enhanced to produce real random code, but this is a task for you to do.

Get the Processor Usage

Problem/Question/Abstract:

How to get the processor usage

Answer:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, CommCtrl, StdCtrls, Menus, WinSpool, ExtCtrls, Buttons, Registry;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Label1: TLabel;
    Label2: TLabel;
    Timer1: TTimer;
    Button2: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
    started: boolean;
    reg: TRegistry;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
var
  Dummy: array[0..1024] of byte;
begin
  // Stats started by Button1 hit
  Reg := TRegistry.Create;
  Reg.RootKey := HKEY_DYN_DATA; // Statistic data is saved under this topic
  { Before starting retrieving statistic data you have to query
    the appropiate key under 'PerfStats\StartStat'. }
  Reg.OpenKey('PerfStats\StartStat', false);
    // Open this key first to start collecting performance data
  Reg.ReadBinaryData('KERNEL\CPUUsage', Dummy, Sizeof(Dummy));
  Reg.CloseKey;
  started := true;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  CPUU: integer;
begin
  { After starting the collection of statistic data, you can retrieve the
    recent value under the 'PerfStats\StatData' key. This is done by a timer
    event in this example }
  if started then
  begin
    Reg.OpenKey('PerfStats\StatData', false); // Open extension kex for txt files
    Reg.ReadBinaryData('KERNEL\CPUUsage', CPUU, SizeOf(Integer));
    Reg.CloseKey;
    Label1.Caption := IntToStr(CPUU) + '%';
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
var
  Dummy: array[0..1024] of byte;
begin
  // Button2 hit stops statistic collection
  { Collecting statistic data is stopped by a query under 'PerfStats/StopStat' }
  Reg.OpenKey('PerfStats\StopStat', false);
    // Open this key first to start collecting performance data
  Reg.ReadBinaryData('KERNEL\CPUUsage', Dummy, SizeOf(Dummy));
  Reg.Free;
  Started := false;
end;

end.

Outlook Automation - Scaning Outlook's Folders

Problem/Question/Abstract:

How I can information from Outlook in my application

Answer:

Sample how to work with Outlook from Delphi application

unit UScanOutlook;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Grids, Outline;
const
  olByValue = 1;
  olByReference = 4;
  olEmbeddedItem = 5;
  olOLE = 6;

  olMailItem = 0;
  olAppointmentItem = 1;
  olContactItem = 2;
  olTaskItem = 3;
  olJournalItem = 4;
  olNoteItem = 5;
  olPostItem = 6;

  olFolderDeletedItems = 3;
  olFolderOutbox = 4;
  olFolderSentMail = 5;
  olFolderInbox = 6;
  olFolderCalendar = 9;
  olFolderContacts = 10;
  olFolderJournal = 11;
  olFolderNotes = 12;
  olFolderTasks = 13;

type
  TForm1 = class(TForm)
    oline_outlook: TOutline;
    Button8: TButton;
    procedure Button8Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    OlApp, NameSpace, root: OleVariant;
  end;

var
  Form1: TForm1;

implementation
uses ComObj;
{$R *.DFM}

procedure TForm1.Button8Click(Sender: TObject);
  procedure scan(ol: TOutline; root: OleVariant; s: string);
  var
    i, j, k: integer;
    bcount, rcount: integer;
    branch, MAPIFolder: olevariant;
    line: string;
  begin
    line := '';
    rcount := root.count;
    for i := 1 to rcount do
    begin
      line := s + root.item[i].name;
      ol.Lines.Add(line);
      branch := root.item[i].folders;
      bcount := branch.count;
      MAPIFolder := Namespace.GetFolderFromId(root.item[i].EntryID,
        root.item[i].StoreID);
      if MAPIFolder.Items.count > 0 then
        for j := 1 to MAPIFolder.Items.count do
          ol.Lines.Add(s + ' ' + MAPIFolder.Items[j].subject);
      if bcount > 0 then
      begin
        scan(ol, branch, s + ' ');
      end;
    end;
  end;
begin
  oline_outlook.Lines.Clear;
  OlApp := CreateOleObject('Outlook.Application');
  Namespace := OlApp.GetNameSpace('MAPI');
  root := Namespace.folders;
  scan(oline_outlook, root, '');
end;

end.

Opening and Closing a CD Tray better

Problem/Question/Abstract:

Opening and Closing a CD Tray?

Answer:

uses
  MMSystem;

// Open CD Tray

{Simple Way:}

mciSendstring('SET CDAUDIO DOOR OPEN WAIT', nil, 0, Self.Handle);

{More complex way:}

function OpenCD(Drive: Char): Boolean;
var
  Res: MciError;
  OpenParm: TMCI_Open_Parms;
  Flags: DWORD;
  S: string;
  DeviceID: Word;
begin
  Result := False;
  S := Drive + ':';
  Flags := MCI_OPEN_TYPE or MCI_OPEN_ELEMENT;
  with OpenParm do
  begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar(S);
  end;
  Res := mciSendCommand(0, MCI_OPEN, Flags, Longint(@OpenParm));
  if Res <> 0 then
    Exit;
  DeviceID := OpenParm.wDeviceID;
  try
    Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_OPEN, 0);
    if Res = 0 then
      Exit;
    Result := True;
  finally
    mciSendCommand(DeviceID, MCI_CLOSE, Flags, Longint(@OpenParm));
  end;
end;

//Close CD Tray

{Simple Way:}

mciSendstring('SET CDAUDIO DOOR CLOSED WAIT', nil, 0, Self.Handle);

{More complex way:}

function CloseCD(Drive: Char): Boolean;
var
  Res: MciError;
  OpenParm: TMCI_Open_Parms;
  Flags: DWORD;
  S: string;
  DeviceID: Word;
begin
  Result := False;
  S := Drive + ':';
  Flags := MCI_OPEN_TYPE or MCI_OPEN_ELEMENT;
  with OpenParm do
  begin
    dwCallback := 0;
    lpstrDeviceType := 'CDAudio';
    lpstrElementName := PChar(S);
  end;
  Res := mciSendCommand(0, MCI_OPEN, Flags, Longint(@OpenParm));
  if Res <> then
    Exit;
  DeviceID := OpenParm.wDeviceID;
  try
    Res := mciSendCommand(DeviceID, MCI_SET, MCI_SET_DOOR_CLOSED, 0);
    if Res = 0 then
      Exit;
    Result := True;
  finally
    mciSendCommand(DeviceID, MCI_CLOSE, Flags, Longint(@OpenParm));
  end;
end;

Deleting Registry Key from .Reg file

Problem/Question/Abstract:

Deleting Registry Key from .Reg file

Answer:

If you want to import a key but delete another key at the same time, use the syntax in your Reg file:

[-HKEY_CURRENT_USER\Software\Local Applications]

Note the minus sign after the bracket.

Create a TAction and its OnExecute event at runtime

Problem/Question/Abstract:

How to create a TAction and its OnExecute event at runtime

Answer:

{ ... }
type
  TForm1 = class(TForm)
    ActionList1: TActionList;
    procedure FormCreate(Sender: TObject);
  private
    Action1, Action2: TAction;
    procedure Test(Sender: TObject);
  end;

procedure TForm1.Test(Sender: TObject);
begin
  Caption := IntToStr(Actionlist1.ActionCount);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Action1 := TAction.Create(Actionlist1);
  Action1.Actionlist := Actionlist1;
  Action1.OnExecute := Test;
  Form1.OnClick := Action1.OnExecute;
end;