Как программно создать ярлык?

Автор: Gavrilo

uses ShlObj, ComObj, ActiveX;

  procedure CreateLink(const PathObj, PathLink, Desc, Param: string);
  var
    IObject: IUnknown;
    SLink: IShellLink;
    PFile: IPersistFile;
  begin
    IObject := CreateComObject(CLSID_ShellLink);
    SLink := IObject as IShellLink;
    PFile := IObject as IPersistFile;

    with SLink do begin
      SetArguments(PChar(Param));
      SetDescription(PChar(Desc));
      SetPath(PChar(PathObj));
    end;
    PFile.Save(PWChar(WideString(PathLink)), FALSE);
  end;

Взято с Исходников.ru

Как программно установить конфигурацию COM-порта в Windows 95?

procedure TForm1.Button1Click(Sender: TObject);
var
  CommPort : string;
  hCommFile : THandle;
  Buffer : PCommConfig;
  size : DWORD;
begin
  CommPort := 'COM1';
{Открываем Com-порт}
  hCommFile := CreateFile(PChar(CommPort),
                          GENERIC_WRITE,
                          0,
                          nil,
                          OPEN_EXISTING,
                          FILE_ATTRIBUTE_NORMAL,
                          0);
  if hCommFile=INVALID_HANDLE_VALUE then
  begin
    ShowMessage('Unable to open '+ CommPort);
    exit;
  end;
{Выделяем временный буфер}
  GetMem(Buffer, sizeof(TCommConfig));

{Получаем размер структуры CommConfig}
  size := 0;
  GetCommConfig(hCommFile, Buffer^, size);

{Освобождаем временный буфер}
  FreeMem(Buffer, sizeof(TCommConfig));

{Выделяем память для структуры CommConfig}
  GetMem(Buffer, size);
  GetCommConfig(hCommFile, Buffer^, size);

{Изменяем скорость передачи}
  Buffer^.dcb.BaudRate := 1200;

{Устанавливаем новую конфигурацию для COM-порта}
  SetCommConfig(hCommFile, Buffer^, size);

{Освобождаем буфер}
  FreeMem(Buffer, size);

{Закрываем COM-порт}
  CloseHandle(hCommFile);
end;

Взято с Исходников.ru

Как программно вазвать окно Завершение работы Windows?

SendMessage (FindWindow ('Progman', 'Program Manager'), WM_CLOSE, 0, 0);

Взято с Исходников.ru

Как программно заставить выпасть меню?

Автор: InSAn

В примере показано как показать меню и выбрать в нем какой-то пункт, эмулируя нажатие "быстрой кдавиши" пункта меню. Если у Вашего пункта меню нет "быстрой клавиши" Вы можете посылать комбинации VK_MENU, VK_LEFT, VK_DOWN, и VK_RETURN, чтобы программно "путешествовать" по меню.

procedure TForm1.Button1Click(Sender: TObject);
begin
//Allow button to finish painting in response to the click
Application.ProcessMessages;
{Alt Key Down}
keybd_Event(VK_MENU, 0, 0, 0);
{F Key Down - Drops the menu down}
keybd_Event(ord('F'), 0, 0, 0);
{F Key Up}
keybd_Event(ord('F'), 0, KEYEVENTF_KEYUP, 0);
{Alt Key Up}
keybd_Event(VK_MENU, 0, KEYEVENTF_KEYUP, 0);
{F Key Down}
keybd_Event(ord('S'), 0, 0, 0);
{F Key Up}
keybd_Event(ord('S'), 0, KEYEVENTF_KEYUP, 0);
end;

Взято с Исходников.ru

Как програмно имитировать нажатие Ctrl-Esc?

SendMessage(Handle,WM_SYSCOMMAND,SC_TASKLIST,0);

Автор ответа: TwoK
Взято с Vingrad.ru

Как програмно нажать SpeedButton?

SpeedButton1.Perform(WM_LBUTTONDOWN, 0, 0);
SpeedButton1.Perform(WM_LBUTTONUP, 0, 0);

Автор ответа: Vit
Взято с Vingrad.ru

Как програмно переключить раскладку клавиатуры?

procedure TForm1.Button1Click(Sender: TObject);//На русский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout( StrCopy(Layout,'00000419'),KLF_ACTIVATE);
end;

procedure TForm1.Button2Click(Sender: TObject);//На английский
var
Layout: array[0.. KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,'00000409'),KLF_ACTIVATE);
end;

Взято с Исходников.ru

Как програмно переключить состояние клавиш Num Lock, Caps Lock, Scroll Lock?

VAR
  KS: TKeyboardState;
begin
GetKeyboardState(KS);
KS[020] := KS[020] XOR 1; //Caps Lock
KS[144] := KS[144] XOR 1; //Num Lock
KS[145] := KS[145] XOR 1; //Scroll Lock
SetKeyboardState(KS);
end;

Взято с Исходников.ru

Во-первых, предложенный способ работает только под 9x (лично проверил)...
Во-вторых, для понятности лучше вместо цифр подставить нормальные константы...
В-третьих, тут еще способ и для NT...

Способ для 9x (на NT не работает):
var
  KeyState : TKeyboardState;
begin
  GetKeyboardState(KeyState);
  KeyState[VK_SCROLL] := KeyState[VK_NUMLOCK] xor 1;
  KeyState[VK_CAPITAL] := KeyState[VK_NUMLOCK] xor 1;
  KeyState[VK_NUMLOCK] := KeyState[VK_NUMLOCK] xor 1;
  SetKeyboardState (KeyState);
end;

Способ для NT (на 9x не работает):
begin
  keybd_event (VK_SCROLL, 0, KEYEVENTF_EXTENDEDKEY, 0);
  keybd_event (VK_SCROLL, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);

  keybd_event (VK_CAPITAL, 0, KEYEVENTF_EXTENDEDKEY, 0);
  keybd_event (VK_CAPITAL, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);

  keybd_event (VK_NUMLOCK, 0, KEYEVENTF_EXTENDEDKEY, 0);
  keybd_event (VK_NUMLOCK, 0, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
end;

т.е. в программе надо будет сделать проверку на версию Windows,
и потом уже вызывать одну из этих функций,
либо же можно их обе вызывать - одна да сработает...

Автор p0s0l

Как програмно прокрутить Memo?

Этот пример прокручивает на одну строку вниз.

memo1.Perform(WM_VScroll, SB_LINEDOWN,0);

Возможны так же следующие опции:
SB_BOTTOM
SB_ENDSCROLL
SB_LINEDOWN
SB_LINEUP
SB_PAGEDOWN
SB_PAGEUP
SB_THUMBPOSITION
SB_THUMBTRACK
SB_TOP

TComboBox, TListBox, TRichEdit и т.п можно прокрутить подобным образом

Взято с Vingrad.ru

Как проиграть файл не использую MediaPlayer ?

PlaySound('c:\....\*.wav',0,SND_FILENAME)

Взято с сайта

Как проиграть ноту?

This is a simple class that plays a formatted musical string. It is reminiscent of the old GWBASIC days whereby one could play a string of notes via the PC speaker. I know that WAV and MIDI files are available in todays technology, but sometimes one does not need all that overhead. The class is useful for certain types of alarms (specially if the user has his sound card volume muted) or simple "Cell Phone" like jingles. The trick of the matter in Delphi is that the standard DELPHI implementation of BEEP takes no arguments and has only one sound. However the WIN API BEEP() takes two arguments.

ie.

BOOL Beep(
DWORD dwFreq, // sound frequency, in hertz
DWORD dwDuration // sound duration, in milliseconds
);

Parameters

dwFreq

Windows NT:
Specifies the frequency, in hertz, of the sound. This parameter must be in the range 37 through 32,767 (0x25 through 0x7FFF).

Windows 95:
The parameter is ignored.

dwDuration

Windows NT:
Specifies the duration, in milliseconds, of the sound.

Windows 95:
The parameter is ignored.

As can be seen it appears that BEEP() is NOT supported on WIN95, but is OK from there upwards. (I have not tested it on WIN95, but assume you will just get a monotone ???? - anyone for comment)

It is easily called by prefixing the unit
ie. Windows.Beep(Freq,Duration)

The format of the "Music String" is a comma delimited (",<" terminated) string in the following formats. (The string is CASE-INSENSITIVE and [] means optional with defaults).

A..G[+ or -][0..5][/BEATS] and

@[/BEATS]

Where A..G is the Note to be played.
+ or - is optional Sharp or Flat designator respectively. (default is normal NULL)
0..5 is optional Octave range (default = 1)
/BEATS is number of 100ms to hold the note (default = 1)

where @ is a musical pause
/BEATS is the number of beats to pause for (default = 1)

where ,< is the END OF STRING terminator.

Properties:
DefaultOctave : Used if no 0..5 designator specified in format. (System Default = 1)
BetweenNotesPause    : Use to set number MS gap between notes (faster or slower default = 100ms)

Simple Example:

procedure TForm1.Button3Click(Sender: TObject);
var
  Organ: TMusicPlayer;
begin
  Organ := TMusicPlayer.Create;
  Organ.Play('A,C,C+,D/3,C,A,C,A,@,F,D/4,<');
  Organ.Play('A,A3/2,G4,G/3,@/2,D-0/4,<');
  Organ.Free;
end;

Any enhancements or additional ideas welcome. Happy jingeling.

unit Music;
interface

uses Windows, SysUtils;

// ===========================================================================
// Mike Heydon May 2002
// Simple Music Player Class Win98/2000 (Win95 not supported)
// Implements Notes A,A#/Bb,C,C#/Db,D,D#,Eb,E,F,F#/Gb,G,G#/Ab
// Caters for Octaves 0..5
// In Between Note Pause setable.
// Defailt Octave setable.
//
// Based on Frequency Matrix
//
//         Octave0   Octave1   Octave2   Octave3   Octave4   Octave5
// A       55.000    110.000   220.000   440.000   880.000   1760.000
// A#/Bb   58.270    116.541   233.082   466.164   932.328   1864.655
// B       61.735    123.471   246.942   493.883   987.767   1975.533
// C       65.406    130.813   261.626   523.251   1046.502  2093.005
// C#/Db   69.296    138.591   277.183   554.365   1108.731  2217.461
// D       73.416    146.832   293.665   587.330   1174.659  2349.318
// D#/Eb   77.782    155.563   311.127   622.254   1244.508  2489.016
// E       82.407    164.814   329.628   659.255   1318.510  2637.020
// F       87.307    174.614   349.228   698.456   1396.913  2793.826
// F#/Gb   92.499    184.997   369.994   739.989   1479.978  2959.955
// G       97.999    195.998   391.995   783.991   1567.982  3135.963
// G#/Ab   103.826   207.652   415.305   830.609   1661.219  3322.438
//
// @ = Pause
// < = End of Music String Marker
//
// ===========================================================================

type
  TOctaveNumber = 0..5;
  TNoteNumber = -1..11;

  TMusicPlayer = class(TObject)
  private
    Octave,
      FDefaultOctave: TOctaveNumber;
    NoteIdx: TNoteNumber;
    FBetweenNotesPause,
      Duration: integer;
  protected
    function ParseNextNote(var MS: string): boolean;
  public
    constructor Create;
    procedure Play(const MusicString: string);
    property DefaultOctave: TOctaveNumber read FDefaultOctave
      write FDefaultOctave;
    property BetweenNotesPause: integer read FBetweenNotesPause
      write FBetweenNotesPause;
  end;

  // ---------------------------------------------------------------------------
implementation

const
  MAXSTRING = 2048; // ASCIIZ String max length

  MHERTZ: array[0..11, 0..5] of integer = // Array of Note MHertz
  ((55, 110, 220, 440, 880, 1760), // A
    (58, 117, 233, 466, 932, 1865), // A+ B-
    (62, 123, 247, 494, 988, 1976), // B
    (65, 131, 262, 523, 1047, 2093), // C
    (69, 139, 277, 554, 1109, 2217), // C+ D-
    (73, 147, 294, 587, 1175, 2349), // D
    (78, 156, 311, 622, 1245, 2489), // D+ E-
    (82, 165, 330, 659, 1319, 2637), // E
    (87, 1745, 349, 698, 1397, 2794), // F
    (92, 185, 370, 740, 1480, 2960), // F+ G-
    (98, 196, 392, 784, 1568, 3136), // G
    (105, 208, 415, 831, 1661, 3322) // G+ A-
    );

  // =======================================
  // Create the object and set defaults
  // =======================================

constructor TMusicPlayer.Create;
begin
  FDefaultOctave := 1;
  FBetweenNotesPause := 100;
end;

// ===========================================================
// Parse the next note and set Octave,NoteIdx and Duration
// ===========================================================

function TMusicPlayer.ParseNextNote(var MS: string): boolean;
var
  NS: string; // Note String
  Beats,
    CommaPos: integer;
  Retvar: boolean;
begin
  Retvar := false; // Assume Error Condition
  Beats := 1;
  Duration := 0;
  NoteIdx := 0;
  Octave := FDefaultOctave;
  CommaPos := pos(',', MS);

  if (CommaPos > 0) then
  begin
    NS := trim(copy(MS, 1, CommaPos - 1)); // Next Note info
    MS := copy(MS, CommaPos + 1, MAXSTRING); // Remove note from music string

    if (length(NS) >= 1) and (NS[1] in ['@'..'G']) then
    begin
      Retvar := true; // Valid Note - set return type true

      // Resolve NoteIdx
      NoteIdx := byte(NS[1]) - 65; // Map 'A'..'G' into 0..11 or -1
      NS := copy(NS, 2, MAXSTRING); // Remove the Main Note ID

      // Handle the @ Pause first
      if NoteIdx = -1 then
      begin
        if (length(NS) >= 1) and (NS[1] = '/') then
          Beats := StrToIntDef(copy(NS, 2, MAXSTRING), 1);
        Sleep(100 * Beats);
        Retvar := false; // Nothing to play
        NS := ''; // Stop further processing
      end;

      // Resolve Sharp or Flast
      if (length(NS) >= 1) and (NS[1] in ['+', '-']) then
      begin
        if NS[1] = '+' then // # Sharp
          inc(NoteIdx)
        else if NS[1] = '-' then // b Flat
          dec(NoteIdx);

        if NoteIdx = -1 then
          NoteIdx := 11; // Roll A Flat to G Sharp
        NS := copy(NS, 2, MAXSTRING); // Remove Flat/Sharp ID
      end;

      // Resolve Octave Number - Default := FDefaultOctave
      if (length(NS) >= 1) and (NS[1] in ['0'..'5']) then
      begin
        Octave := byte(NS[1]) - 48; // map '0'..'5' to 0..5 decimal
        NS := copy(NS, 2, MAXSTRING); // Remove Octave Number
      end;

      // Resolve Number of Beats - Default = 1
      if (length(NS) >= 1) and (NS[1] = '/') then
        Beats := StrToIntDef(copy(NS, 2, MAXSTRING), 1);

      Duration := 100 * Beats;
    end;
  end
  else
    MS := ''; // Signal end of music string

  Result := Retvar;
end;

// ===================================
// Play the passed music string
// ===================================

procedure TMusicPlayer.Play(const MusicString: string);
var
  MS: string; // Music String
begin
  MS := trim(UpperCase(MusicString));

  while (MS <> '') do
  begin
    if ParseNextNote(MS) then
    begin
      Windows.Beep(MHERTZ[NoteIdx, Octave], Duration);
      Sleep(FBetweenNotesPause);
    end;
  end;
end;

end.

Взято с

Delphi Knowledge Base

Как проиграть wav из ресурса не сохраняя его в файл?

{... }
var
  FindHandle, ResHandle: THandle;
  ResPtr: Pointer;
begin
  FindHandle := FindResource(HInstance, 'Name of your resource', 'WAVE');
  if FindHandle <> 0 then
  begin
    ResHandle := LoadResource(HInstance, FindHandle);
    if ResHandle <> 0 then
    begin
      ResPtr := LockResource(ResHandle);
      if ResPtr <> nil then
        SndPlaySound(PChar(ResPtr), snd_ASync or snd_Memory);
      UnlockResource(ResHandle);
    end;
    FreeResource(FindHandle);
  end;
end;

Взято с

Delphi Knowledge Base

Как проиграть wave file в обратную сторону?

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, MMSystem;

const
  WM_FINISHED = WM_USER + $200;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    fData: PChar;
    fWaveHdr: PWAVEHDR;
    fWaveOutHandle: HWAVEOUT;

    procedure ReversePlay(const szFileName: string);
    procedure WaveOutProc(hwo: HWAVEOUT; uMsg: UINT; dwParam1,
      dwParam2: DWORD);
    procedure WmFinished(var Msg: TMessage); message WM_FINISHED;

    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure Interchange(hpchPos1, hpchPos2: PChar; wLength: Word);
var
  wPlace: word;
  bTemp: char;
begin
  for wPlace := 0 to wLength - 1 do
  begin
    bTemp := hpchPos1[wPlace];
    hpchPos1[wPlace] := hpchPos2[wPlace];
    hpchPos2[wPlace] := bTemp
  end
end;

{
  Callback function to be called during waveform-audio playback
  to process messages related to the progress of t he playback.
}

procedure waveOutPrc(hwo: HWAVEOUT; uMsg: UINT; dwInstance,
  dwParam1, dwParam2: DWORD); stdcall;
begin
  TForm1(dwInstance).WaveOutProc(hwo, uMsg, dwParam1, dwParam2)
end;

procedure TForm1.WaveOutProc(hwo: HWAVEOUT; uMsg: UINT; dwParam1,
  dwParam2: DWORD);
begin
  case uMsg of
    WOM_OPEN:;
    WOM_CLOSE:
      fWaveOutHandle := 0;
    WOM_DONE:
      PostMessage(Handle, WM_FINISHED, 0, 0);
  end
end;

procedure TForm1.ReversePlay(const szFileName: string);
var
  mmioHandle: HMMIO;
  mmckInfoParent: MMCKInfo;
  mmckInfoSubChunk: MMCKInfo;
  dwFmtSize, dwDataSize: DWORD;
  pFormat: PWAVEFORMATEX;
  wBlockSize: word;
  hpch1, hpch2: PChar;
begin
  { The mmioOpen function opens a file for unbuffered or buffered I/O }
  mmioHandle := mmioOpen(PChar(szFileName), nil, MMIO_READ or MMIO_ALLOCBUF);
  if mmioHandle = 0 then
    raise Exception.Create('Unable to open file ' + szFileName);

  try
    { mmioStringToFOURCC converts a null-terminated string to a four-character code }
    mmckInfoParent.fccType := mmioStringToFOURCC('WAVE', 0);
    { The mmioDescend function descends into a chunk of a RIFF file }
    if mmioDescend(mmioHandle, @mmckinfoParent, nil, MMIO_FINDRIFF) <>
      MMSYSERR_NOERROR then raise Exception.Create(szFileName + ' is not a valid wave file');

    mmckinfoSubchunk.ckid := mmioStringToFourCC('fmt ', 0);
    if mmioDescend(mmioHandle, @mmckinfoSubchunk, @mmckinfoParent,
      MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
      raise Exception.Create(szFileName + ' is not a valid wave file');

    dwFmtSize := mmckinfoSubchunk.cksize;
    GetMem(pFormat, dwFmtSize);

    try
      { The mmioRead function reads a specified number of bytes from a file }
      if DWORD(mmioRead(mmioHandle, PChar(pFormat), dwFmtSize)) <>
        dwFmtSize then
        raise Exception.Create('Error reading wave data');

      if pFormat^.wFormatTag <> WAVE_FORMAT_PCM then
        raise Exception.Create('Invalid wave file format');

      { he waveOutOpen function opens the given waveform-audio output device for playback }
      if waveOutOpen(@fWaveOutHandle, WAVE_MAPPER, pFormat, 0, 0,
        WAVE_FORMAT_QUERY) <> MMSYSERR_NOERROR then
        raise Exception.Create('Cannot play format');

      mmioAscend(mmioHandle, @mmckinfoSubchunk, 0);
      mmckinfoSubchunk.ckid := mmioStringToFourCC('data', 0);
      if mmioDescend(mmioHandle, @mmckinfoSubchunk, @mmckinfoParent,
        MMIO_FINDCHUNK) <> MMSYSERR_NOERROR then
        raise Exception.Create('No data chunk');

      dwDataSize := mmckinfoSubchunk.cksize;
      if dwDataSize = 0 then
        raise Exception.Create('Chunk has no data');

      if waveOutOpen(@fWaveOutHandle, WAVE_MAPPER, pFormat,
        DWORD(@WaveOutPrc), Integer(Self), CALLBACK_FUNCTION) <> MMSYSERR_NOERROR then
      begin
        fWaveOutHandle := 0;
        raise Exception.Create('Failed to open output device');
      end;

      wBlockSize := pFormat^.nBlockAlign;

      ReallocMem(pFormat, 0);
      ReallocMem(fData, dwDataSize);

      if DWORD(mmioRead(mmioHandle, fData, dwDataSize)) <> dwDataSize then
        raise Exception.Create('Unable to read data chunk');

      hpch1 := fData;
      hpch2 := fData + dwDataSize - 1;

      while hpch1 < hpch2 do
      begin
        Interchange(hpch1, hpch2, wBlockSize);
        Inc(hpch1, wBlockSize);
        Dec(hpch2, wBlockSize)
      end;

      GetMem(fWaveHdr, SizeOf(WAVEHDR));
      fWaveHdr^.lpData  := fData;
      fWaveHdr^.dwBufferLength := dwDataSize;
      fWaveHdr^.dwFlags := 0;
      fWaveHdr^.dwLoops := 0;
      fWaveHdr^.dwUser := 0;

      { The waveOutPrepareHeader function prepares a waveform-audio data block for playback. }
      if waveOutPrepareHeader(fWaveOutHandle, fWaveHdr,
        SizeOf(WAVEHDR)) <> MMSYSERR_NOERROR then
        raise Exception.Create('Unable to prepare header');

      { The waveOutWrite function sends a data block to the given waveform-audio output device.}
      if waveOutWrite(fWaveOutHandle, fWaveHdr, SizeOf(WAVEHDR)) <>
        MMSYSERR_NOERROR then
        raise Exception.Create('Failed to write to device');

    finally
      ReallocMem(pFormat, 0)
    end
  finally
    mmioClose(mmioHandle, 0)
  end
end;

// Play a wave file

procedure TForm1.Button1Click(Sender: TObject);
begin
  Button1.Enabled := False;
  try
    ReversePlay('C:\myWaveFile.wav')
  except
    Button1.Enabled := True;
    raise
  end
end;

// Stop Playback

procedure TForm1.Button2Click(Sender: TObject);
begin
  { The waveOutReset function stops playback on the given waveform-audio output device }
  WaveOutReset(fWaveOutHandle);
end;

procedure TForm1.WmFinished(var Msg: TMessage);
begin
  WaveOutUnprepareHeader(fWaveOutHandle, fWaveHdr, SizeOf(WAVEHDR));
  WaveOutClose(fWaveOutHandle);
  ReallocMem(fData, 0);
  ReallocMem(fWaveHdr, 0);
  Button1.Enabled := True;
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
  WaveOutReset(fWaveOutHandle);
  while fWaveOutHandle <> 0 do
    Application.ProcessMessages
end;

end.

Взято с сайта

Как проиграть Wave-ресурс?

Сначала делаешь файл SOUND.RC, в нем строка вида: MY_WAV RCDATA TEST.WAV
Компилишь чем-нибyдь в *.RES

Далее в тексте:
{$R полное_имя_файла_с_ресурсом}

var WaveHandle: THandle;
  WavePointer: pointer;
  ...
    WaveHandle := FindResource(hInstance, 'MY_WAV', RT_RCDATA);
  if WaveHandle <> 0 then
    begin
      WaveHandle := LoadResource(hInstance, WaveHandle);
      if WaveHandle <> 0 then
        begin;
          WavePointer := LockResource(WaveHandle);

          PlayResourceWave := sndPlaySound(WavePointer, snd_Memory or
            SND_ASYNC);
          UnlockResource(WaveHandle);
          FreeResource(WaveHandle);
        end;
    end;

Serg Vostrikov
(2:5053/15.3)

Взято с сайта

Как проигрывать 2 звука одновременно?

uses
  MMSystem;

procedure SendMCICommand(Cmd: string);
var
  RetVal: Integer;
  ErrMsg: array[0..254] of char;
begin
  RetVal := mciSendString(PChar(Cmd), nil, 0, 0);
  if RetVal <> 0 then
  begin
    {get message for returned value}
    mciGetErrorString(RetVal, ErrMsg, 255);
    MessageDlg(StrPas(ErrMsg), mtError, [mbOK], 0);
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SendMCICommand('open waveaudio shareable');
  SendMCICommand('play "C:\xyz\BackgroundMusic.wav"');
  SendMCICommand('play "C:\xyz\AnotherMusic.wav"');
  SendMCICommand('close waveaudio');
end;

Взято с сайта

Как производить Печать?

Взято из FAQ:
Перевод материала с сайта members.home.com/hfournier/webbrowser.htm

Есть два способа вывода на печать. Первый пример работает в IE 4.x и выше,
в то время как второй пример расчитан на IE 3.x:

var
vaIn, vaOut: OleVariant;

... WebBrowser.ControlInterface.ExecWB(OLECMDID_PRINT, OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut); либо

procedure TForm1.PrintIE;
var
CmdTarget : IOleCommandTarget;
vaIn, vaOut: OleVariant;
begin
if WebBrowser1.Document < > nil then
try
WebBrowser1.Document.QueryInterface(IOleCommandTarget, CmdTarget);
if CmdTarget < > nil then
try
  CmdTarget.Exec( PGuid(nil), OLECMDID_PRINT,
  OLECMDEXECOPT_DONTPROMPTUSER, vaIn, vaOut);
finally
  CmdTarget._Release;
end;
except
  // Ничего
end;
end;

Обратите внимание: Если версия Delphi ниже чем 3.02, то необходимо заменить PGuid(nil)
на PGuid(nil)^
. А лучше всего проапгрейдить до 3.02 (если Вы пользуетесь версиями 3.0 или 3.01).

Как прокрутить TRichEdit в конец?

Существует множество способов, включая и:

---DO NOT USE THIS EXAMPLE - SEE BELOW INSTEAD---
    with MainFrm.RichEdit1 do
    begin
      perform (WM_VSCROLL, SB_BOTTOM, 0);
      perform (WM_VSCROLL, SB_PAGEUP, 0);
    end;
-------------------------------------------------

Вышеприведённый пример работает отлично в 9x и NT4, но не работает в Windows 2000. Поэетому предлагаю воспользоваться следующим примером:

    with MainFrm.RichEdit1 do
    begin
      SelStart := Length(Text);
      Perform(EM_SCROLLCARET, 0, 0);
    end;

Взято с Исходников.ru

Как проверить, имеем ли мы административные привилегии в системе?

type
PTOKEN_GROUPS = TOKEN_GROUPS^;

function RunningAsAdministrator(): Boolean;
var
  SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;
  psidAdmin: PSID;
  ptg: PTOKEN_GROUPS = nil;
  htkThread: Integer; { HANDLE }
  cbTokenGroups: Longint; { DWORD }
  iGroup: Longint; { DWORD }
  bAdmin: Boolean;
begin
  Result := false;
  if not OpenThreadToken(GetCurrentThread(), // get security token
    TOKEN_QUERY, FALSE, htkThread) then
    if GetLastError() = ERROR_NO_TOKEN then
    begin
      if not OpenProcessToken(GetCurrentProcess(),
        TOKEN_QUERY, htkThread) then
        Exit;
    end
    else
      Exit;

  if GetTokenInformation(htkThread, // get #of groups
    TokenGroups, nil, 0, cbTokenGroups) then
    Exit;

  if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then
    Exit;

  ptg := PTOKEN_GROUPS(getmem(cbTokenGroups));
  if not Assigned(ptg) then
    Exit;

  if not GetTokenInformation(htkThread, // get groups
    TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then
    Exit;

  if not AllocateAndInitializeSid(SystemSidAuthority,
    2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
    0, 0, 0, 0, 0, 0, psidAdmin) then
    Exit;

  iGroup := 0;
  while iGroup < ptg^.GroupCount do // check administrator group
  begin
    if EqualSid(ptg^.Groups[iGroup].Sid, psidAdmin) then
    begin
      Result := TRUE;
      break;
    end;
    Inc(iGroup);
  end;
  FreeSid(psidAdmin);
end;

Взято с

Как проверить инсталлирован ли MS Word?

uses
..., Registry;

function IsMicrosoftWordInstalled: Boolean;
var
  Reg: TRegistry;
  S: string;
begin
  Reg := TRegistry.Create;
  with Reg do
  begin
    RootKey := HKEY_CLASSES_ROOT;
    Result := KeyExists('Word.Application');
    Free;
  end;
end;

function MSWordIsInstalled: Boolean;
begin
  Result := AppIsInstalled('Word.Application');
end;

function AppIsInstalled(strOLEObject: string): Boolean;
var
  ClassID: TCLSID;
begin
  Result := (CLSIDFromProgID(PWideChar(WideString(strOLEObject)), ClassID) = S_OK)
end;

Взято с

Delphi Knowledge Base

Как определить установлен ли на компьютере Word, запустить его и загрузить в него текст из программы?

Пример:

var
MsWord: Variant;
...
try
// Если Word уже запущен
MsWord := GetActiveOleObject('Word.Application');
// Взять ссылку на запущенный OLE объект
except
  try
  // Word не запущен, запустить
  MsWord := CreateOleObject('Word.Application');
  // Создать ссылку на зарегистрированный OLE объект
  MsWord.Visible := True;
   except
    ShowMessage('Не могу запустить Microsoft Word');
    Exit;
   end;
  end;
end;
...
MSWord.Documents.Add; // Создать новый документ
MsWord.Selection.Font.Bold := True; // Установить жирный шрифт
MsWord.Selection.Font.Size := 12; // установить 12 кегль
MsWord.Selection.TypeText('Текст');

Источник:

Как проверить, является ли число простым?

Как проверить является ли текущее соединение в TWebbrowser secure (SSL)?

// You need a TWebbrowser, a TLabel

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  if Webbrowser1.Oleobject.Document.Location.Protocol = 'https:' then
    label1.Caption := 'Sichere Verbindung'
  else
    label1.Caption := 'Unsichere Verbindung'
end;

Взято с сайта

Как проверить находится ли файл на локальном диске?

function IsOnLocalDrive(aFileName: string): Boolean;
var
  aDrive: string;
begin
  aDrive := ExtractFileDrive(aFileName);
  if (GetDriveType(PChar(aDrive)) = DRIVE_REMOVABLE) or
     (GetDriveType(PChar(aDrive)) = DRIVE_FIXED) then
    Result := True
  else
    Result := False;
end;

// Example, Beispiel:
procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    if IsOnLocalDrive(OpenDialog1.FileName) then
      ShowMessage(OpenDialog1.FileName + ' is on a local drive.');
end;

Взято с сайта

Как проверить правильность International Bank Account Number?

// IBAN = International Bank Account Number
// Example : CH10002300A1023502601

function ChangeAlpha(input: string): string;
  // A -> 10, B -> 11, C -> 12 ...
var
  a: Char;
begin
  Result := input;
  for a := 'A' to 'Z' do
  begin
    Result := StringReplace(Result, a, IntToStr(Ord(a) - 55), [rfReplaceAll]);
  end;
end;

function CalculateDigits(iban: string): Integer;
var
  v, l: Integer;
  alpha: string;
  number: Longint;
  rest: Integer;
begin
  iban := UpperCase(iban);
  if Pos('IBAN', iban) > 0 then
    Delete(iban, Pos('IBAN', iban), 4);
  iban := iban + Copy(iban, 1, 4);
  Delete(iban, 1, 4);
  iban := ChangeAlpha(iban);
  v := 1;
  l := 9;
  rest := 0;
  alpha := '';
  try
    while v <= Length(iban) do
    begin
      if l > Length(iban) then
        l := Length(iban);
      alpha := alpha + Copy(iban, v, l);
      number := StrToInt(alpha);
      rest := number mod 97;
      v := v + l;
      alpha := IntToStr(rest);
      l := 9 - Length(alpha);
    end;
  except
    rest := 0;
  end;
  Result := rest;
end;

function CheckIBAN(iban: string): Boolean;
begin
  iban := StringReplace(iban, ' ', '', [rfReplaceAll]);
  if CalculateDigits(iban) = 1 then
    Result := True
  else
    Result := False;
end;

Взято с сайта

Как проверить правильность номера кредитной карточки?

{-------------------------------------------------
  Returns:

   0  : Card is invalid or unknown
   1  : Card is a valid AmEx
   2  : Card is a valid Visa
   3  : Card is a valid MasterCard

  Ergebnis:

   0  : Unbekannte Karte
   1  : AmEx Karte
   2  : Visa Karte
   3  : MasterCard Karte
-------------------------------------------------}

function CheckCC(c: string): Integer;
var
  card: string[21];
  Vcard: array[0..21] of Byte absolute card;
  Xcard: Integer;
  Cstr: string[21];
  y, x: Integer;
begin
  Cstr := '';
  FillChar(Vcard, 22, #0);
  card := c;
  for x := 1 to 20 do
    if (Vcard[x] in [48..57]) then
      Cstr := Cstr + chr(Vcard[x]);
  card := '';
  card := Cstr;
  Xcard := 0;
  if not odd(Length(card)) then
    for x := (Length(card) - 1) downto 1 do
    begin
      if odd(x) then
        y := ((Vcard[x] - 48) * 2)
      else
        y := (Vcard[x] - 48);
      if (y >= 10) then
        y := ((y - 10) + 1);
      Xcard := (Xcard + y)
    end
  else
    for x := (Length(card) - 1) downto 1 do
    begin
      if odd(x) then
        y := (Vcard[x] - 48)
      else
        y := ((Vcard[x] - 48) * 2);
      if (y >= 10) then
        y := ((y - 10) + 1);
      Xcard := (Xcard + y)
    end;
  x := (10 - (Xcard mod 10));
  if (x = 10) then
    x := 0;
  if (x = (Vcard[Length(card)] - 48)) then
    Result := Ord(Cstr[1]) - Ord('2')
  else
    Result := 0
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  case CheckCC(Edit1.Text) of
    0: Label1.Caption := 'Card is invalid or unknown';
    1: Label1.Caption := 'Card is a valid AmEx';
    2: Label1.Caption := 'Card is a valid Visa';
    3: Label1.Caption := 'Card is a valid MasterCard';
  end;
end;

Взято с сайта

Как проверить правильность штрих-кода?

Solve 1

:

I want to publish a code for checksum calculation by modulus 10 which is used in the barcodes. I must say that this "mod10" is specifical so readf an article if you're interested.

This algorithm is very popular for UPC barcodes (Universal Product Code), hash code or serial number generation for applications etc...

The basic algorithm:

1.1.add the values of the digits in the odd positions (1, 3, 5...)
2.2.   multiply this result by 3
3.3.   add the values of the digits in the even positions (2, 4, 6...)
4.4.   sum the results of steps 2 and 3
5.5.   the check digit is the smallest number which, when added to the result in step 4, produces a multiple of 10.

Small example. Assume the source data is 08137919805

1.1.   0+1+7+1+8+5=22
2.2.   22*3=66
3.3.   8+3+9+9+0=29
4.4.   66+29=95
5.5.   95+??=100 where ?? is a 5 (our checksum)

My implementation in the Pascal:

function Mod10(const Value: string): Integer;
var
  i, intOdd, intEven: Integer;
begin
  {add all odd seq numbers}
  intOdd := 0;
  i := 1;
  while (i <= Length(Value)) do
  begin
    Inc(intOdd, StrToIntDef(Value[i], 0));
    Inc(i, 2);
  end;

  {add all even seq numbers}
  intEven := 0;
  i := 2;
  while (i <= Length(Value)) do
  begin
    Inc(intEven, StrToIntDef(Value[i], 0));
    Inc(i, 2);
  end;

  Result := 3 * intOdd + intEven;
  {modulus by 10 to get}
  Result := Result mod 10;
  if Result <> 0 then
    Result := 10 - Result
end;

You can expand or optimize this algorithm for own needs.

For example, I modified it and now I use it for any characters (not only digits) in source value.

The original algorithm I used for UPC-barcode validation in the SMReport Designer and the my extended algorithm I use in the serial number generation as part of the protection schema (in the shareware projects).

function BarCodeValid(ACode: string): boolean;
var
  I: integer;
  SumOdd, SumEven: integer;
  ADigit, AChecksumDigit: integer;
begin
  SumOdd := 0;
  SumEven := 0;
  for I := 1 to (Length(ACode) - 1) do
  begin
    ADigit := StrToIntDef(ACode[I], 0);
    if (I mod 2 = 0) then
    begin
      SumEven := SumEven + ADigit;
    end
    else
    begin
      SumOdd := SumOdd + ADigit;
    end; {if}
  end; {for}
  AChecksumDigit := StrToIntDef(ACode[Length(ACode)], 0);
  Result := ((SumOdd * 3 + SumEven + AChecksumDigit) mod 10 = 0);
end; {--BarCodeValid--}

Взято с

Delphi Knowledge Base

Как проверить существование URL?

Данная функция позволяет Вам проверить существование определённого адреса(URL) в интернете. Естественно она может пригодиться веб-мастерам, у которых на сайте много ссылок, и необходимо с определённой периодичнойстью эти ссылки проверять.

URL может быть как с префиксом http:/ так и без него - эта функция добавляет префикс http:// если он отсутствует (необходимо для функции internetOpenUrl которая так же поддерживает FTP:// и gopher://

Эта функция проверяет только два возвращаемых кода '200'(ОК) или '302' (Редирект), но Вы можете заставить проверять функцию и другие коды. Для этого достаточно модифицировать строчку "result := ".

Платформа: Delphi 3.x (или выше)

uses wininet;

function CheckUrl(url: string): boolean;
var
  hSession, hfile, hRequest: hInternet;
  dwindex, dwcodelen: dword;
  dwcode: array[1..20] of char;
  res: pchar;
begin
  if pos('http://', lowercase(url)) = 0 then
    url := 'http://' + url;
  Result := false;
  hSession := InternetOpen('InetURL:/1.0',
    INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if assigned(hsession) then
    begin
      hfile := InternetOpenUrl(
        hsession,
        pchar(url),
        nil,
        0,
        INTERNET_FLAG_RELOAD,
        0);
      dwIndex := 0;
      dwCodeLen := 10;
      HttpQueryInfo(hfile, HTTP_QUERY_STATUS_CODE,
        @dwcode, dwcodeLen, dwIndex);
      res := pchar(@dwcode);
      result := (res = '200') or (res = '302');
      if assigned(hfile) then
        InternetCloseHandle(hfile);
      InternetCloseHandle(hsession);
    end;
end;

Взято с Исходников.ru

Как проверить, существует ли дата?

functionDateExists(Date: string; Separator: char): Boolean;
var
  OldDateSeparator: Char;
begin
  Result := True;
  OldDateSeparator := DateSeparator;
  DateSeparator := Separator;
  try
    try
      StrToDate(Date);
    except
      Result := False;
    end;
  finally
    DateSeparator := OldDateSeparator;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  if DateExists('35.3.2001', '.') then
  begin
    {your code}
  end;
end;

Взято с

Delphi Knowledge Base

Как проверить, включён ли ActiveDesktop?

function IsActiveDeskTopOn: Boolean;
var
  h: hWnd;
begin
  h := FindWindow('Progman', nil);
  h := FindWindowEx(h, 0,
        'SHELLDLL_DefView', nil);
  h := FindWindowEx(h, 0,
       'Internet Explorer_Server', nil);
  Result := h <> 0;
end;

Взято с Исходников.ru

Как проверять корректность доступа к базе данных?

Следующая функция проверяет доступ к базе данных и выдает возможные причины, если доступ не удается осуществить. Функция возвращает значение True в случае успешной операции и False в противном случае.

function TBDEDirect.CheckDatabase: Boolean;
var DS: TDataSource;
begin
  Result := False;
  DS := GetDataSource;
  if DS = nil then
    begin
      MessageDlg('Не установлена связь с элементом-источником данных.'+
        'Проверьте установку свойства DataSource.',
        mtError, [mbOK], 0);
      Exit;
    end;
  if DS.DataSet = nil then
    begin
      MessageDlg('Доступ к базе данных невозможен.', mtError,[mbOK], 0);
      Exit;
    end;
  if TDBDataSet(DS.DataSet).Database = nil then
    begin
      MessageDlg('Доступ к базе данных невозможен.', mtError,[mbOK], 0);
      Exit;
    end;
  if TDBDataSet(DS.DataSet).Database.Handle = nil then
    begin
      MessageDlg('Дескриптор (Handle) БД недоступен.', mtError,[mbOK], 0);
      Exit;
    end;
  if DS.DataSet.Handle = nil then
    begin
      MessageDlg('Дескриптор курсора (Cursor-Handle) недоступен.', mtError, mbOK], 0);
      Exit;
    end;
  Result := True;
end;

Как работать из Delphi напрямую с ADO?

Автор: Nomadic

Итак, хочу поделиться некоторыми достижениями... так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) - то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры, которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:

var
OptionalParam: OleVariant;
  VarData: PVarData;
begin
  OptionalParam := DISP_E_PARAMNOTFOUND;
  VarData := @OptionalParam;
  VarData^.VType := varError;

после этого переменную OptionalParam можно передавать вместо неиспользуемого аргумента.

Далее, самый приятный способ получения Result sets:

Там есть масса вариантов, но как выяснилось оптимальным является следующий вариант, который позволяет получить любой желаемый вид курсора (как клиентский, так и серверный)

var
  MyConn: _Connection;
  MyComm: _Command;
  MyRecSet: _Recordset;
  prm1: _Parameter;
begin
  MyConn := CoConnection.Create;
  MyConn.ConnectionString := 'DSN=pubs;uid=sa;pwd=;'; MyConn.Open( '', '', '', -1 );
  MyCommand := CoCommand.Create;
  MyCommand.ActiveConnection := MyConn;
  MyCommand.CommandText := 'SELECT * FROM blahblah WHERE BlahID=?'
  Prm1 := MyCommand.CreateParameter( 'Id', adInteger.adParamInput, -1, <value> );
  MyCommand.AppendParameter( Prm1 );
  MyRecSet := CoRecordSet.Create;
  MyRecSet.Open( MyCommand, OptionalParam, adOpenDynamic, adLockReadOnly, adCmdText );

... теперь можно фетчить записи. Работает шустро и классно. Меня радует. Особенно радуют серверные курсоры.

Проверялось на Delphi 3.02 + ADO 1.5 + MS SQL 6.5 sp4. Пашет как зверь.

Из вкусностей ADO - их легко можно использовать во всяких многопоточных приложениях, где BDE порой сбоит, если, конечно, ODBC драйвер грамотно сделан...

Ну и еще можно использовать для доступа к данным всяких там "нестандартных" баз типа MS Index Server или MS Active Directory Services.

В Delphi (как минимум в 4 версии) существует "константа" EmptyParam, которую можно подставлять в качестве пустого параметра.

Взято из

Примечание Vit: с появлением в последющих версиях Дельфи ADO компонентов делает работу с ADO гораздо проще и понятнее, хотя в отдельных проектах всё ещё могут понадобится прямые обращения к недокументированным или не имплементированным в Дельфи возможностям ADO.

Как работать с ADO компонентами в DLL?

В оконных приложениях инициализацию COM берет на себя строка в файле проекта:

Application.Initialize;

А вот в DLL и консольных программах обэекта Application нет, и при попытке работать с любыми ActiveX, включая широко используемые ADO компоненты генерится ошибка, которую исправить очень просто: достаточно в секцию Uses в DPR файле добавить модуль oleauto

Автор ответа: Vit
Взято с Vingrad.ru

Как работать с адресной книгой Lotus Notes?

unitUnit2;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Domino_TLB, Menus, ComCtrls;
const
  PASSWD = 'ur70';
type
  TForm2 = class(TForm)
    TV_INFO: TTreeView;
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Create1: TMenuItem;
    Init1: TMenuItem;
    AddressBook1: TMenuItem;
    Scan1: TMenuItem;
    procedure Create1Click(Sender: TObject);
    procedure Init1Click(Sender: TObject);
    procedure Scan1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form2: TForm2;
  Session: TNotesSession;
implementation

{$R *.dfm}

procedure TForm2.Create1Click(Sender: TObject);
begin
  Session := TNotesSession.Create(nil);
end;

procedure TForm2.Init1Click(Sender: TObject);
begin
  Session.Initialize(PASSWD);
end;

procedure TForm2.Scan1Click(Sender: TObject);
var
  NotesDb: NotesDatabase;
  addrBook: NotesDatabase;
  People, People2: NotesView;
  Person, Person2: NotesDocument;
  View: NotesView;
  Item: NotesItem;
  AddrBooks: OleVariant;
  Views: OleVariant;
  Items: OleVariant;
  x, y, z: integer;
  view_name: string;
  tn, tc: TTreeNode;
begin
  NotesDb := Session.GetDatabase('', 'names.nsf', False);
  AddrBooks := Session.AddressBooks;
  for x := 0 to VarArrayHighBound(AddrBooks, 1) -
    VarArrayLowBound(AddrBooks, 1) do
  begin
    addrBook := NotesDatabase(IUnknown(AddrBooks[x]));
    if (addrBook.IsPrivateAddressBook) then
    begin
      addrBook.Open;
    end
    else
      addrBook := nil;
    if (addrBook <> nil) then
    begin
      Views := addrBook.Views;
      for y := 0 to VarArrayHighBound(Views, 1) -
        VarArrayLowBound(Views, 1) do
      begin
        View := NotesView(IUnknown(Views[y]));
        view_name := View.Name;
        tn := tv_info.Items.AddNode(nil, nil, view_name, nil, naAdd);

        if copy(view_name, 1, 1) = '$' then
          view_name := copy(view_name, 2, length(view_name) - 1);
        people := addrBook.GetView(view_name);
        person := people.GetFirstDocument;
        if Person <> nil then
        begin
          Items := Person.Items;
          for z := 0 to VarArrayHighBound(Items, 1) -
            VarArrayLowBound(Items, 1) do
          begin
            Item := NotesItem(IUnknown(Items[z]));
            tc := tv_info.Items.AddChild(tn, Item.Name);

            people := addrBook.GetView(view_name);
            person := people.GetFirstDocument;

            while (Person <> nil) do
            begin
              try
                try
                  tv_info.Items.AddChild(tc, Person.GetFirstItem(Item.Name).Text
                    {Item.Text});
                except
                end;
              finally
                Person := People.GetNextDocument(Person);
              end;
            end;
          end;
        end;
      end;

    end;
  end;
end;

end.

Взято с

Delphi Knowledge Base

Как работать с анимированными курсорами?

Answer:

To use an animated cursor you have several options: load it from a file (using LoadImage or LoadCursorFromFile), load it from a resource (using LoadCursor) or even creating the cursor at runtime (using CreateCursor).

Note:
You should implement custom cursors as resources. Rather than create the cursors at run time, use the LoadCursor, LoadCursorFromFile, or LoadImage function to avoid device dependence, to simplify localization, and to enable applications to share cursor designs.

·Loading a cursor from a file

The easiest way to load a cursor from a file is by using LoadCursorFromFile.
This functions returns a handle to the loaded cursor that you should assign to your application Cursors array.

var
  hCur: HCURSOR;

begin
  // Load the cursor from file
  hCur := LoadCursorFromFile(PChar('path_to_my_cursor'));
  // Assign the loaded cursor to application Cursors array. (This cursor will ave the
  // number 1 assigned to it
  // Remember that predefined cursors start at a negative index, and user defined
  // custom cursors are assigned positive indexes.
  Screen.Cursors[1] := hCur;

  // Use the cursor as you would use a built-in cursor.
  Screen.Cursor := 1;
end;

You can also use LoadImage instead of LoadCursorFromFile like this:

  hCur := LoadImage(0, PChar(PChar('path_to_my_cursor')), IMAGE_CURSOR, 0, 0,
  LR_DEFAULTSIZE or LR_LOADFROMFILE);

·Loading a cursor from a resource

Before loading a cursor from a resource it's necessary to create the resource file with the cursor to be loaded.

To do this create a file myResources.rc where you'll put the following

#define ANICURSOR 21
myCursor ANICURSOR "path_to_my_cursor"

Because Borland's resource compiler does not understand the ANICURSOR resource type, so you have to use the numeric id (21).
Compile your resource file using "brcc32 myResources.rc" and include in the unit where you'll be loading the cursor, using {$R myResources.res}

Now, you just have to load the cursor from the resource instead of loading it from a file, using:

hCur := LoadCursor(HInstance, PChar('myCursor'));

Remember that HInstance contains the instance handle of the application or library as provided by Windows. This variable it's very importante because it's the one used with many Windows API that work with current application resources.

·Creating a cursor at runtime

Another way to use a cursor it's creating one at runtime. Why would you do that?
I don't know, it's your choice. I doubt you ever will create your cursors at runtime, anyway here it's way how to do it.

Define the cursor map

const
  // Yin cursor AND bitmask
  ANDmaskCursor: array[0..127] of byte = (
    $FF, $FC, $3F, $FF, $FF, $C0, $1F, $FF,
    $FF, $00, $3F, $FF, $FE, $00, $FF, $FF,
    $F7, $01, $FF, $FF, $F0, $03, $FF, $FF,
    $F0, $03, $FF, $FF, $E0, $07, $FF, $FF,
    $C0, $07, $FF, $FF, $C0, $0F, $FF, $FF,
    $80, $0F, $FF, $FF, $80, $0F, $FF, $FF,
    $80, $07, $FF, $FF, $00, $07, $FF, $FF,
    $00, $03, $FF, $FF, $00, $00, $FF, $FF,
    $00, $00, $7F, $FF, $00, $00, $1F, $FF,
    $00, $00, $0F, $FF, $80, $00, $0F, $FF,
    $80, $00, $07, $FF, $80, $00, $07, $FF,
    $C0, $00, $07, $FF, $C0, $00, $0F, $FF,
    $E0, $00, $0F, $FF, $F0, $00, $1F, $FF,
    $F0, $00, $1F, $FF, $F8, $00, $3F, $FF,
    $FE, $00, $7F, $FF, $FF, $00, $FF, $FF,
    $FF, $C3, $FF, $FF, $FF, $FF, $FF, $FF
    );

  // Yin cursor XOR bitmask
  XORmaskCursor: array[0..127] of byte = (
    $00, $00, $00, $00, $00, $03, $C0, $00,
    $00, $3F, $00, $00, $00, $FE, $00, $00,
    $0E, $FC, $00, $00, $07, $F8, $00, $00,
    $07, $F8, $00, $00, $0F, $F0, $00, $00,
    $1F, $F0, $00, $00, $1F, $E0, $00, $00,
    $3F, $E0, $00, $00, $3F, $E0, $00, $00,
    $3F, $F0, $00, $00, $7F, $F0, $00, $00,
    $7F, $F8, $00, $00, $7F, $FC, $00, $00,
    $7F, $FF, $00, $00, $7F, $FF, $80, $00,
    $7F, $FF, $E0, $00, $3F, $FF, $E0, $00,
    $3F, $C7, $F0, $00, $3F, $83, $F0, $00,
    $1F, $83, $F0, $00, $1F, $83, $E0, $00,
    $0F, $C7, $E0, $00, $07, $FF, $C0, $00,
    $07, $FF, $C0, $00, $01, $FF, $80, $00,
    $00, $FF, $00, $00, $00, $3C, $00, $00,
    $00, $00, $00, $00, $00, $00, $00, $00
    );

then create the cursor

hCur := CreateCursor(HInstance, 19, 2, 32, 32, @ANDmaskCursor, @XORmaskCursor);

Взято с

Delphi Knowledge Base

Во первых необходимо получит handle курсора, а затем определить его в массиве курсоров компонента TScreen. Индексы предопределенных курсоров системы отрицательны, пользователь может определить курсор, индекс которого положителен.

procedure TForm1.Button1Click(Sender: TObject);
var
  h: THandle;
begin
  h := LoadImage(0, 'C:\TheWall\Magic.ani', IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE or LR_LOADFROMFILE);
  if h = 0 then
    ShowMessage('Cursor not loaded')
  else
    begin
      Screen.Cursors[1] := h;
      Form1.Cursor := 1;
    end;
end;

Как работать с буфером обмена (clipboard)?

Этот пример использует картинку, кнопку и компонент shape на форме. Когда пользователь кликает по кнопке, то изображение формы сохраняется в в переменной FormImage и копируется в буфер обмена (Clipboard). Затем изображение формы копируется обратно в компонент картинки, тем самым создавая интересный эффект, особенно, если кнопку понажимать несколько раз.

procedure TForm1.Button1Click(Sender: TObject);
var
  FormImage: TBitmap;
begin
  FormImage := GetFormImage;
  try
    Clipboard.Assign(FormImage);
    Image1.Picture.Assign(Clipboard);
  finally
    FormImage.Free;
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Shape1.Shape := stEllipse;
  Shape1.Brush.Color := clLime;
  Image1.Stretch := True;
end;

Следующий пример копирует содержимое экрана в буфер обмена:

procedure CopyScreenToClipboard;
var dx,dy : integer;
    hSourcDC,hDestDC,
    hBM, hbmOld : THandle;

begin
  dx := screen.width;
  dy := screen.height;
  hSourcDC := CreateDC('DISPLAY',nil,nil,nil);
  hDestDC  := CreateCompatibleDC(hSourcDC);
  hBM := CreateCompatibleBitmap(hSourcDC, dx, dy);
  hbmold:= SelectObject(hDestDC, hBM);
  BitBlt(hDestDC, 0, 0, dx, dy, hSourcDC, 0, 0, SRCCopy);
  OpenClipBoard(form1.handle);
  EmptyClipBoard;
  SetClipBoardData(CF_Bitmap, hBM);
  CloseClipBoard;
  SelectObject(hDestDC,hbmold);
  DeleteObject(hbm);
  DeleteDC(hDestDC);
  DeleteDC(hSourcDC);
end;

Взято с Исходников.ru

Как работать с DWG файлами (AutoCAD)?

Vit: Примечания в коде были на каком-то не то китайском, не то японском языке - удалены!

unitDWGView;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls;

type
  BITMAPINFO256 = record
    bmiHeader: BITMAPINFOHEADER;
    bmiColors: array[0..255] of RGBQUAD;
  end;

type
  TNoPreviewEvent = procedure(Sender: TOBject) of object;
  TFileErrorEvent = procedure(Sender: TOBject; DWGName: string) of object;

  TDWGView = class(TImage)
  private
    FDWGVersion: string;
    FDWGFile: string;
    FNoPreviewEvent: TNoPreviewEvent;
    FOnFileError: TFileErrorEvent;
    FImage: TImage;
    procedure SetDWGFile(const Value: string);
    procedure SetFImage(const Value: TImage);
  protected
    procedure ReadDWG;
    constructor TDWGView;
  public
  published
    property Image: TImage read FImage write SetFImage;
    property DWGFile: string read FDWGFile write SetDWGFile;
    property DWGVersion: string read FDWGVersion;
    property OnNoPreview: TNoPreviewEvent read FNoPreviewEvent write FNoPreviewEvent;
    property OnFileError: TFileErrorEvent read FOnFileError write FOnFileError;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Voice', [TDWGView]);
end;

procedure TDWGView.ReadDWG;
var
  DWGF: TFileStream;
  MemF: TMemoryStream;
  BMPF: TMemoryStream;
  SentinelF: TMemoryStream;
  bif: BITMAPINFO256;
  bfh: BITMAPFILEHEADER;
  PosSentinel: LongInt;
  LenPreview: Integer;
  RasterPreview: ShortInt;
  PosBMP: Integer;
  LenBMP: Integer;
  IndexPreview: Integer;
  TypePreview: Shortint;
begin
  if Assigned(FOnFileError) then
    FOnFileError(Self, FDWGFile);
  DWGF := TFileStream.Create(FDWGFile, fmOpenRead);
  BMPF := TMemoryStream.Create;
  MemF := TMemoryStream.Create;
  SentinelF := TMemoryStream.Create;
  try
    SetLength(FDWGVersion, 6);
    DWGF.ReadBuffer(FDWGVersion[1], 6);
    DWGF.Position := 13;
    DWGF.Read(PosSentinel, 4);
    DWGF.Position := PosSentinel;
    SentinelF.CopyFrom(DWGF, 16);
    DWGF.Read(LenPreview, 4);
    DWGF.Read(RasterPreview, 1);
    for IndexPreview := RasterPreview - 1 downto 0 do
    begin
      MemF.Position := 0;
      MemF.CopyFrom(DWGF, 9);
      MemF.Position := 0;
      MemF.Read(TypePreview, 1);
      case TypePreview of
        1: ;
        2:
          begin
            MemF.Position := 1;
            MemF.Read(PosBMP, 4);
            MemF.Read(LenBMP, 4);
            DWGF.Position := PosBMP;
            DWGF.ReadBuffer(bif, sizeof(bif));

            with bif do
            begin
              bmiColors[0].rgbBlue := 0;
              bmiColors[0].rgbGreen := 0;
              bmiColors[0].rgbRed := 0;

              bmiColors[225].rgbBlue := 255;
              bmiColors[225].rgbGreen := 255;
              bmiColors[225].rgbRed := 255;
            end;

            bfh.bfType := $4D42;
            bfh.bfSize := LenBMP + sizeof(bfh);
            bfh.bfReserved1 := 0;
            bfh.bfReserved2 := 0;
            bfh.bfOffBits := 14 + $28 + 1024;

            BMPF.Position := 0;
            BMPF.Write(bfh, sizeof(bfh));
            BMPF.WriteBuffer(bif, sizeof(bif));
            BMPF.CopyFrom(DWGF, LenBMP - 1064);
            BMPF.Position := 0;
            Picture.Bitmap.LoadFromStream(BMPF);
          end;
        3: ;
      end;

    end;
  finally
    SentinelF.Free;
    MemF.Free;
    DWGF.Free;
    BMPF.Free;
  end;

end;

procedure TDWGView.SetDWGFile(const Value: string);
begin
  FDWGFile := Value;
  ReadDWG;
end;

procedure TDWGView.SetFImage(const Value: TImage);
begin
  FImage := Value;
end;

constructor TDWGView.TDWGView;
begin
  //TODO: Add your source code here
  FDWGFile := '';
  FDWGVersion := '';
end;

end.

Взято с

Delphi Knowledge Base

Как работать с fade для TImage?

type
  PRGBTripleArray = ^TRGBTripleArray;
  TRGBTripleArray = array[0..32767] of TRGBTriple;

  /////////////////////////////////////////////////
  //                  Fade In                    //
  /////////////////////////////////////////////////

procedure FadeIn(ImageFileName: TFileName);
var
  Bitmap, BaseBitmap: TBitmap;
  Row, BaseRow: PRGBTripleArray;
  x, y, step: integer;
begin
  // Bitmaps vorbereiten / Preparing the Bitmap //
  Bitmap := TBitmap.Create;
  try
    Bitmap.PixelFormat := pf32bit;  // oder pf24bit / or pf24bit //
    Bitmap.LoadFromFile(ImageFileName);
    BaseBitmap := TBitmap.Create;
    try
      BaseBitmap.PixelFormat := pf32bit;
      BaseBitmap.Assign(Bitmap);
      // Fading //
      for step := 0 to 32 do
      begin
        for y := 0 to (Bitmap.Height - 1) do
        begin
          BaseRow := BaseBitmap.Scanline[y];
          // Farben vom Endbild holen / Getting colors from final image //
          Row := Bitmap.Scanline[y];
          // Farben vom aktuellen Bild / Colors from the image as it is now //
          for x := 0 to (Bitmap.Width - 1) do
          begin
            Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;
            Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5; // Fading //
            Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;
          end;
        end;
        Form1.Canvas.Draw(0, 0, Bitmap);   // neues Bild ausgeben / Output new image //
        InvalidateRect(Form1.Handle, nil, False);
        // Fenster neu zeichnen / Redraw window //
        RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);
      end;
    finally
      BaseBitmap.Free;
    end;
  finally
    Bitmap.Free;
  end;
end;

/////////////////////////////////////////////////
//                  Fade Out                   //
/////////////////////////////////////////////////

procedure FadeOut(ImageFileName: TFileName);
var
  Bitmap, BaseBitmap: TBitmap;
  Row, BaseRow: PRGBTripleArray;
  x, y, step: integer;
begin
  // Bitmaps vorbereiten / Preparing the Bitmap //
  Bitmap := TBitmap.Create;
  try
    Bitmap.PixelFormat := pf32bit;  // oder pf24bit / or pf24bit //
    Bitmap.LoadFromFile(ImageFileName);
    BaseBitmap := TBitmap.Create;
    try
      BaseBitmap.PixelFormat := pf32bit;
      BaseBitmap.Assign(Bitmap);
      // Fading //
     for step := 32 downto 0 do
      begin
        for y := 0 to (Bitmap.Height - 1) do
        begin
          BaseRow := BaseBitmap.Scanline[y];
          // Farben vom Endbild holen / Getting colors from final image //
          Row := Bitmap.Scanline[y];
          // Farben vom aktuellen Bild / Colors from the image as it is now //
          for x := 0 to (Bitmap.Width - 1) do
          begin
            Row[x].rgbtRed := (step * BaseRow[x].rgbtRed) shr 5;
            Row[x].rgbtGreen := (step * BaseRow[x].rgbtGreen) shr 5; // Fading //
            Row[x].rgbtBlue := (step * BaseRow[x].rgbtBlue) shr 5;
          end;
        end;
        Form1.Canvas.Draw(0, 0, Bitmap);   // neues Bild ausgeben / Output new image //
        InvalidateRect(Form1.Handle, nil, False);
        // Fenster neu zeichnen / Redraw window //
        RedrawWindow(Form1.Handle, nil, 0, RDW_UPDATENOW);
      end;
    finally
      BaseBitmap.Free;
    end;
  finally
    Bitmap.Free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  FadeIn('C:\TestImage.bmp')
end;

{*****************************}
{by Yucel Karapinar, ykarapinar@hotmail.com }

{ Only for 24 ve 32 bits bitmaps }

procedure FadeOut(const Bmp: TImage; Pause: Integer);
var
  BytesPorScan, counter, w, h: Integer;
  p: pByteArray;
begin
  if not (Bmp.Picture.Bitmap.PixelFormat in [pf24Bit, pf32Bit]) then
    raise Exception.Create('Error, bitmap format is not supporting.');
  try
    BytesPorScan := Abs(Integer(Bmp.Picture.Bitmap.ScanLine[1]) -
      Integer(Bmp.Picture.Bitmap.ScanLine[0]));
  except
    raise Exception.Create('Error!!');
  end;

  for counter := 1 to 256 do
  begin
    for h := 0 to Bmp.Picture.Bitmap.Height - 1 do
    begin
      P := Bmp.Picture.Bitmap.ScanLine[h];
      for w := 0 to BytesPorScan - 1 do
        if P^[w] > 0 then P^[w] := P^[w] - 1;
    end;
    Sleep(Pause);
    Bmp.Refresh;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  FadeOut(Image1, 1);
end;

Взято с сайта

Как работать с FileOpenDialog и FileSaveDialоg?

как именно с ними работать чтобы на с: открыть файл?

Похоже я понял что тебя смущает: OpenFileDialog и SaveFileDialog - ничего сами по себе не открывают и не сохраняют. Они нужны только для выбора имени файла. Ставишь их на форму. Там куча свойств и опций - типа исходны каталог, показыать скрытые файлы или нет и т.п. Впрочем по началу можно их вообще не указывать. Тебе надо знать только 1 метод - execute - открыть диалог:

OpenFileDialog1.execute

ты можешь проверить действительно ли пользователь выбрал файл или нажал Cancel:

if OpenFileDialog1.execute then

если файл выбран то свойство FileName возвращает тебе строку - имя файла

if OpenFileDialog1.execute then showmessage(OpenFileDialog1.FileName);

Сам файл не открывается и ничего с ним не делается, все это надо делать вручную:

if OpenFileDialog1.execute then
begin
assignFile(f,OpenFileDialog1.Filename);
reset(f);
seek(f, $10000);
write(f,b);
CloseFile(f);
end;

Автор ответа: Vit

Взято с Vingrad.ru

Как работать с GIF файлами?

procedure TForm1.Button2Click(Sender: TObject);
begin
  if opendialog1.Execute then
    begin
      ListBox1.Items := opendialog1.Files;
      Edit2.Text := inttostr(ListBox1.Items.Count);
    end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  i, a: integer;
  bm: TBItmap;
begin
  a := 0;
  bm := TBItmap.Create;
  image1.Picture.LoadFromFile(listbox1.Items[0]);
  bm.Height := image1.Height;
  bm.Width := listbox1.Items.Count * image1.Picture.width;
  for i := 0 to listbox1.Items.Count - 1 do
    begin
      image1.Picture.LoadFromFile(listbox1.Items[i]);
      bm.Canvas.Draw(a, 0, image1.Picture.Graphic);
      a := a + image1.Picture.Height;
    end;
//form1.Canvas.Draw(0,0,bm);
  bm.SaveToFile(Edit1.Text + '.bmp');
  bm.free;
end;

Этот код, делает следующее, загружаем в листбох список Gif файлов, затем это все дело обьединяетсяв один BMP файл,картинка к картинке, кто знает DirectX поймет для чего это надо (спрайты);

procedure TForm1.Button4Click(Sender: TObject);
var
  i, a: integer;
  bm: TBItmap;
begin
  a := 0;
  bm := TBItmap.Create;
  bm.Height := RxGIFAnimator1.Height;
  bm.Width := RxGIFAnimator1.Image.Count * RxGIFAnimator1.width;
  for i := 0 to RxGIFAnimator1.Image.Count - 1 do
    begin
      RxGIFAnimator1.FrameIndex := i;
      bm.Canvas.Draw(a, 0, RxGIFAnimator1.Image.Frames[i].Bitmap);
      a := a + RxGIFAnimator1.Height;
    end;
//form1.Canvas.Draw(0,0,bm);
  bm.SaveToFile(Edit1.Text + '.bmp');
  bm.free;
end;

из файловов GIF (анимированных) вытаскивает каждую картинку в отдельности, или записывает в отдельный BMP по очереди
Для этих программок нужен всеми любимый RX Lib !!!

Автор ответа: МММ
Взято с Vingrad.ru

Как поставить (анимационный) GIF на форму?
Использовать компонент rxGIFAnimator из библиотеки RxLib.

Автор ответа: Vit
Взято с Vingrad.ru

Как работать с комплексными числами?

Взято из
Complex numbers
Complex numbers have two representations :
rectanglar : Z = a + i * b, a being the real part, and b being the imaginary part
polar : Z = r * exp(i * phi), r being the absolute value, and phi being the argument(angle)
a reason to demotivate compiler writers to have it as native type.

Here is a unit that approaches the complex as record.
the used record is of dual use, either rectangular or polar,
one just has to keep in mind what in is at the moment.

{ unit for complex numbers based on C_reords
-----------------------------------------
they are efficient on arrays
}
unit ComplexRec;

interface

type
  float = extended;

  ComplexPtr = ^Complex;
  Complex = record // C_record without rectangular/polar discrimination
    a, b: float; // (re,im) or (abs,arg)
  end;

function C_Copy(a: ComplexPtr): ComplexPtr; // result:=a

function C_One: ComplexPtr; // result:=1 BOTH
function C_I: ComplexPtr; // result:=i RECTANGULAR
function C_IP: ComplexPtr; // result:=i POLAR
procedure C_P2R(a: ComplexPtr); // polar to rectangular
procedure C_R2P(a: ComplexPtr); // rectangular to polar
function C_abs(a: ComplexPtr): float; // RECTANGULAR
function C_arg(a: ComplexPtr): float; // RECTANGULAR
function C_re(a: ComplexPtr): float; // POLAR
function C_im(a: ComplexPtr): float; // POLAR
procedure C_Inv(a: ComplexPtr); // a:=-a RECTANGULAR
procedure C_InvP(a: ComplexPtr); // a:=-a POLAR
procedure C_Conj(a: ComplexPtr); // a:=konjug(a) BOTH
function C_ConjN(a: ComplexPtr): ComplexPtr; //result:=konjug(a) BOTH
procedure C_Scale(a: ComplexPtr; u: float); // a:=a*u;
procedure C_ScaleP(a: ComplexPtr; u: float); // a:=a*u;

procedure C_Add(a, b: ComplexPtr); //a:=a+b RECTANGULAR
function C_AddN(a, b: ComplexPtr): ComplexPtr; //result:=a+b RECTANGULAR
procedure C_Sub(a, b: ComplexPtr); //a:=a-b RECTANGULAR
function C_SubN(a, b: ComplexPtr): ComplexPtr; //result:=a-b RECTANGULAR
procedure C_Mul(a, b: ComplexPtr); //a:=a*b RECTANGULAR
function C_MulN(a, b: ComplexPtr): ComplexPtr; //result:=a*b RECTANGULAR
procedure C_MulP(a, b: ComplexPtr); //a:=a*b POLAR
function C_MulNP(a, b: ComplexPtr): ComplexPtr; //result:=a*b POLAR
procedure C_DivP(a, b: ComplexPtr); //a:=a/b POLAR
function C_DivNP(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR
procedure C_Div(a, b: ComplexPtr); //a:=a/b POLAR
function C_DivN(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR
function C_ExpN(a: ComplexPtr): ComplexPtr; // RECTANGLE
function C_LogN(a: ComplexPtr): ComplexPtr; // POLAR
function C_SinN(a: ComplexPtr): ComplexPtr;
function C_CosN(a: ComplexPtr): ComplexPtr;
function C_TanN(a: ComplexPtr): ComplexPtr;
function C_SinhN(a: ComplexPtr): ComplexPtr;
function C_CoshN(a: ComplexPtr): ComplexPtr;
function C_TanhN(a: ComplexPtr): ComplexPtr;
function C_IntPowerN(a: ComplexPtr; n: integer): ComplexPtr; // RECTANGLE
function C_IntPowerNP(a: ComplexPtr; n: integer): ComplexPtr; // POLAR

function C_ParallelN(a, b: ComplexPtr): ComplexPtr; // result:=a//b =(a*b)/(a+b) RECTANGULAR
// electronic parallel circuit

implementation

uses math;

const AlmostZero = 1E-30; // test for zero

function C_Copy(a: ComplexPtr): ComplexPtr; // result:=a
begin
  result := new(ComplexPtr);
  result.a := a.a; result.b := a.b;
end;

function C_One: ComplexPtr; // result:=1
begin
  result := new(ComplexPtr);
  result.a := 1; result.b := 0;
end;

function C_I: ComplexPtr; // result:=i RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := 0; result.b := 1;
end;

function C_IP: ComplexPtr; // result:=i POLAR
begin
  result := new(ComplexPtr);
  result.a := 1; result.b := pi / 2;
end;

procedure C_P2R(a: ComplexPtr);
var t, u, v: float;
begin
  t := a.a;
  sincos(a.b, u, v);
  a.a := t * v; a.b := t * u;
end;

procedure C_R2P(a: ComplexPtr);
var t: float;
begin
  t := a.a; a.a := sqrt(sqr(a.a) + sqr(a.b));
  if (abs(t)0 then a.b := pi / 2
  else
    a.b := -pi / 2;
end
else
  begin
    a.b := arctan(a.b / t);
    if (t < 0) then a.b := a.b + pi;
  end;
end;

function C_abs(a: ComplexPtr): float;
begin
  result := sqrt(sqr(a.a) + sqr(a.b));
end;

function C_arg(a: ComplexPtr): float;
begin
  if (abs(a.a)0 then result := pi / 2
else
  result := -pi / 2;
end
else
  begin
    result := arctan(a.b / a.a);
    if (a.a < 0) then result := result + pi;
  end;
end;

function C_re(a: ComplexPtr): float; // POLAR
begin
  result := a.a * cos(a.b);
end;

function C_im(a: ComplexPtr): float; // POLAR
begin
  result := a.a * sin(a.b);
end;

procedure C_Inv(a: ComplexPtr); // a:=-a RECTANGULAR
begin
  a.a := -a.a; a.b := -a.b;
end;

procedure C_InvP(a: ComplexPtr); // a:=-a POLAR
begin
  a.b := a.b + pi;
end;

procedure C_Conj(a: ComplexPtr); // a:=konjug(a) BOTH
begin
  a.b := -a.b;
end;

function C_ConjN(a: ComplexPtr): ComplexPtr; //result:=konjug(a) BOTH
begin
  result := new(ComplexPtr);
  result.a := a.a;
  result.b := -a.b;
end;

procedure C_Scale(a: ComplexPtr; u: float); // a:=a*u;
begin
  a.a := a.a * u;
  a.b := a.b * u;
end;

procedure C_ScaleP(a: ComplexPtr; u: float); // a:=a*u;
begin
  a.a := a.a * u;
end;

procedure C_Add(a, b: ComplexPtr); //a:=a+b RECTANGULAR
begin
  a.a := a.a + b.a;
  a.b := a.b + b.b;
end;

function C_AddN(a, b: ComplexPtr): ComplexPtr; //result:=a+b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a + b.a;
  result.b := a.b + b.b;
end;

procedure C_Sub(a, b: ComplexPtr); //a:=a-b RECTANGULAR
begin
  a.a := a.a - b.a;
  a.b := a.b - b.b;
end;

function C_SubN(a, b: ComplexPtr): ComplexPtr; //result:=a-b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a - b.a;
  result.b := a.b - b.b;
end;

procedure C_Mul(a, b: ComplexPtr); //a:=a*b RECTANGULAR
var u, v: float;
begin
  u := a.a * b.a - a.b * b.b;
  v := a.a * b.b + a.b * b.a;
  a.a := u;
  a.b := v;
end;

function C_MulN(a, b: ComplexPtr): ComplexPtr; //result:=a*b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a * b.a - a.b * b.b;
  result.b := a.a * b.b + a.b * b.a;
end;

procedure C_MulP(a, b: ComplexPtr); //a:=a*b POLAR
begin
  a.a := a.a * b.a;
  a.b := a.b + b.b;
end;

function C_MulNP(a, b: ComplexPtr): ComplexPtr; //result:=a*b POLAR
begin
  result := new(ComplexPtr);
  result.a := a.a * b.a;
  result.b := a.b + b.b;
end;

procedure C_Div(a, b: ComplexPtr); //a:=a/b RECTANGULAR
var t: float;
begin
  t := a.a / b.a + a.b / b.b;
  a.b := -a.a / b.b + a.b / b.a;
  a.a := t;
end;

function C_DivN(a, b: ComplexPtr): ComplexPtr; //result:=a/b RECTANGULAR
begin
  result := new(ComplexPtr);
  result.a := a.a / b.a + a.b / b.b;
  result.b := -a.a / b.b + a.b / b.a;
end;

procedure C_DivP(a, b: ComplexPtr); //a:=a/b POLAR
begin
  a.a := a.a / b.a;
  a.b := a.b - b.b;
end;

function C_DivNP(a, b: ComplexPtr): ComplexPtr; //result:=a/b POLAR
begin
  result := new(ComplexPtr);
  result.a := a.a / b.a;
  result.b := a.b - b.b;
end;

function C_ExpN(a: ComplexPtr): ComplexPtr; // RECTANGLE
begin
  result := new(ComplexPtr);
  result.a := exp(a.a);
  result.b := a.b;
  C_P2R(result);
end;

function C_LogN(a: ComplexPtr): ComplexPtr; // POLAR
begin
  result := new(ComplexPtr);
  result.a := ln(a.a);
  result.b := a.b;
  C_R2P(result);
end;

function C_SinN(a: ComplexPtr): ComplexPtr;
var z, n, v, t: ComplexPtr;
begin
  t := C_I;
  v := C_MulN(a, t); // i*a
  z := C_expN(a); // exp(i*a)
  t := C_Copy(v);
  C_Inv(t); // -i*a
  t := C_ExpN(v); // exp(-i*a)
  C_Sub(z, t);
  n := C_I;
  C_Scale(n, 2);
  result := C_DivN(z, n);
  dispose(z); dispose(n); dispose(v); dispose(t);
end;

function C_CosN(a: ComplexPtr): ComplexPtr;
var z, n, v, t: ComplexPtr;
begin
  t := C_I;
  v := C_MulN(a, t); // i*a
  z := C_expN(a); // exp(i*a)
  t := C_Copy(v);
  C_Inv(t); // -i*a
  t := C_ExpN(v); // exp(-i*a)
  C_Add(z, t);
  n := C_One;
  C_Scale(n, 2);
  result := C_DivN(z, n);
  dispose(z); dispose(n); dispose(v); dispose(t);
end;

function C_TanN(a: ComplexPtr): ComplexPtr;
begin

end;

function C_SinhN(a: ComplexPtr): ComplexPtr;
var u, v, t: ComplexPtr;
begin
  u := C_ExpN(a);
  t := C_Copy(a);
  C_inv(t);
  v := C_ExpN(t);
  result := C_SubN(u, v);
  C_Scale(result, 1 / 2);
  dispose(u);
  dispose(v);
  dispose(t);
end;

function C_CoshN(a: ComplexPtr): ComplexPtr;
var u, v, t: ComplexPtr;
begin
  u := C_ExpN(a);
  t := C_Copy(a);
  C_inv(t);
  v := C_ExpN(t);
  result := C_AddN(u, v);
  C_Scale(result, 1 / 2);
  dispose(u);
  dispose(v);
  dispose(t);
end;

function C_TanhN(a: ComplexPtr): ComplexPtr;
begin

end;

function C_IntPowerN(a: ComplexPtr; n: integer): ComplexPtr;
var j: integer;
  u, v: float;
begin
  if n = 0 then
    result := C_One
  else
    begin
      result := C_Copy(a);
      if n > 1 then
        begin
          C_R2P(result);
          u := result.a; v := result.b;
          for j := 2 to n do
            begin
              u := u * result.a; v := v + result.b;
            end;
          result.a := u; result.b := v;
          C_P2R(result);
        end;
      if n < 0 then
        begin

        end;
    end;
end;

function C_IntPowerNP(a: ComplexPtr; n: integer): ComplexPtr;
var j: integer;
  u, v: float;
begin
  result := C_Copy(a);
  u := result.a; v := result.b;
  for j := 2 to n do
    begin
      u := u * result.a; v := v + result.b;
    end;
  result.a := u; result.b := v;
end;

function C_ParallelN(a, b: ComplexPtr): ComplexPtr; // result:=a//b = (a*b)/(a+b)
var z, n: ComplexPtr;
begin
  z := C_MulN(a, b);
  n := C_AddN(a, b);
  C_R2P(n);
  C_R2P(z);
  result := C_DivNP(z, n);
  C_P2R(result);
  dispose(n);
  dispose(z);
end;

end.

Copyright (99,2000) Ing.BЁ№ro R.Tschaggelar
Взято с Vingrad.ru

Как работать с объектом Excel вставленном в Word документ?

{... }
var
  AWordApplication: WordApplication;
  AWordDocument: WordDocument;
  AWorkBook: ExcelWorkBook;
  AWorkSheet: ExcelWorkSheet;
  AInlineShape: InlineShape;
  AFileName: OleVariant;
  TrueParam: OleVariant;
begin
  AWordApplication := CoWordApplication.Create;
  try
    FalseParam := False;
    AFileName := 'c:\wordexcel.doc';
    AWordDocument := AWordApplication.Documents.Open(AFileName, EmptyParam,
      EmptyParam,
      EmptyParam, EmptyParam, EmptyParam, EmptyParam, EmptyParam,
      EmptyParam, EmptyParam, EmptyParam, EmptyParam);
    AInlineShape := AWordDocument.InlineShapes.Item(1);
    AInlineShape.Activate;
    AWorkBook := AWordDocument.InlineShapes.Item(1).OLEFormat.Object_ as
      ExcelWorkBook;
    AWorkSheet := AWorkBook.ActiveSheet as ExcelWorkSheet;
    ShowMessage(AWorkSheet.Cells.Item[2, 1].Text);
  finally
    AWordApplication.Quit(FalseParam, EmptyParam, EmptyParam);
    AWordApplication := nil;
    AWordDocument := nil;
  end;
end;

Взято с

Delphi Knowledge Base

Как работать с палитрой в Delphi?

Как работать с палитрой в Delphi? На форме установлен TImage и видна картинка (*.BMP файл), как изменить у него палитру цветов ?

Палитра в TBitmap и TMetaFile доступна через property Palette. Если палитра имеется (что совсем необязательно), то Palette<>0:

procedure TMain.BitBtnClick(Sender: TObject);
var
  Palette : HPalette;
  PaletteSize : Integer;
  LogSize: Integer;
  LogPalette: PLogPalette;
  Red : Byte;
begin
  Palette := Image.Picture.Bitmap.ReleasePalette;
  // здесь можно использовать просто Image.Picture.Bitmap.Palette, но  я не
  // знаю, удаляются ли ненужные палитры автоматически

  if Palette=0 then exit; //Палитра отсутствует
  PaletteSize := 0;
  if GetObject(Palette, SizeOf(PaletteSize), @PaletteSize) = 0 then Exit;
  // Количество элементов в палитре = paletteSize
  if PaletteSize = 0 then Exit; // палитра пустая
  // определение размера палитры
  LogSize := SizeOf(TLogPalette) + (PaletteSize - 1) * SizeOf(TPaletteEntry);
  GetMem(LogPalette, LogSize);
  try
    // заполнение полей логической палитры
    with LogPalette^ do begin
      palVersion := $0300;    palNumEntries := PaletteSize;
      GetPaletteEntries(Palette, 0, PaletteSize, palPalEntry);
      // делаете что нужно с палитрой, например:
      Red := palPalEntry[PaletteSize-1].peRed;
      Edit1.Text := 'Красная составляющего последнего элемента  палитры ='+IntToStr(Red);
      palPalEntry[PaletteSize-1].peRed := 0;
      //.......................................
    end;
    // завершение работы
    Image.Picture.Bitmap.Palette := CreatePalette(LogPalette^);
  finally
    FreeMem(LogPalette, LogSize);
    // я должен позаботиться сам об удалении Released Palette
    DeleteObject(Palette);
  end;
end;

{ Этот модуль заполняет фон формы рисунком bor6.bmp (256 цветов)
  и меняет его палитру при нажатии кнопки }
unit bmpformu;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
  TBmpForm = class(TForm)
    Button1: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    Bitmap: TBitmap;
    procedure ScrambleBitmap;
    procedure WMEraseBkgnd(var m: TWMEraseBkgnd); message WM_ERASEBKGND;
end;

var
  BmpForm: TBmpForm;

implementation
{$R *.DFM}
procedure TBmpForm.FormCreate(Sender: TObject);
begin
  Bitmap := TBitmap.Create;
  Bitmap.LoadFromFile('bor6.bmp');
end;

procedure TBmpForm.FormDestroy(Sender: TObject);
begin
  Bitmap.Free;
end;

// since we're going to be painting the whole form, handling this
// message will suppress the uneccessary repainting of the background
// which can result in flicker.
procedure TBmpform.WMEraseBkgnd(var m : TWMEraseBkgnd);
begin
  m.Result := LRESULT(False);
end;

procedure TBmpForm.FormPaint(Sender: TObject);
var x, y: Integer;
begin
  y := 0;
  while y < Height do begin
    x := 0;
    while x < Width do begin
      Canvas.Draw(x, y, Bitmap);
      x := x + Bitmap.Width;
    end;
    y := y + Bitmap.Height;
  end;
end;

procedure TBmpForm.Button1Click(Sender: TObject);
begin
  ScrambleBitmap; Invalidate;
end;

// scrambling the bitmap is easy when it's has 256 colors:
// we just need to change each of the color in the palette
// to some other value.
procedure TBmpForm.ScrambleBitmap;
var
  pal: PLogPalette;
  hpal: HPALETTE;
  i: Integer;
begin
  pal := nil;
  try
    GetMem(pal, sizeof(TLogPalette) + sizeof(TPaletteEntry) * 255);
    pal.palVersion := $300;
    pal.palNumEntries := 256;
    for i := 0 to 255 do
    begin
      pal.palPalEntry[i].peRed := Random(255);
      pal.palPalEntry[i].peGreen := Random(255);
      pal.palPalEntry[i].peBlue := Random(255);
    end;
    hpal := CreatePalette(pal^);
    if hpal <> 0 then
      Bitmap.Palette := hpal;
  finally
    FreeMem(pal);
  end;
end;

end.

Зайцев О.В.
Владимиров А.М.
Взято с Исходников.ru

Как работать с PDF файлами?

Let's see how to to show an Adobe Acrobat (.PDF) file in a Delphi application. All you need to do is the Acrobat ActiveX control (pdf.ocx and pdf.tlb), which you you can get for free from Adobe.

Here's How:

·Start Delphi and select Component | Import ActiveX Control...
·Look for the 'Acrobat Control for ActiveX (Version x.x)' and simply click on Install.
·Select the Component palette location in which you want to place selected library.
·Maybe the best is to leave the ActiveX option selected.
·Click on Install.
·Select a package where the new component must be installed or create a new package for the new TPdf control. Click on OK.
·Delphi will prompt you whether you want to rebuild the modified/new package or not. Click on Yes.
·After the package is compiled, Delphi will show you a message saying that the new TPdf component was registered and already available as part of the VCL.
·Close the package detail window, allowing Delphi to save the changes to it.
·The component is now available in the ActiveX tab (if you didn't change this setting in step 4)
·Drop the component on a form.
·Select the TPdf component you just dropped on a blank form.
·Using the object inspector, set the src property to the name of an existing PDF file on your system. Now all you have to do is resize the component and read the PDF file from your Delphi application.

Tips:

If you do not have the Acrobat ActiveX control, download it nowhttp://www.adobe.com/prodindex/acrobat/readstep.html! It will be required for tip to work.
Last step (Step 15) can be done in runtime, so you can open and close files programmatically, as well as resize the control.

Closing acrobat reader on formdestroy:

procedure Tfrm_doc_pdf.FormDestroy(Sender: TObject);
var
  xHWND: integer;
begin
  xHWND := findwindow(nil, 'Acrobat Reader');
  sendmessage(xHWND, WM_CLOSE, 0, 0);
end;

Ok, you must have installed the Acrobat Reader program in your machine, if you donґt have it you can download it from Adobeґs site: www.adobe.comhttp://www.adobe.com

After that you have to install the type library for Acrobat (Project -> Import Type Library from Delphiґs menu) select "Acrobat Control for ActiveX (version x)". Where x stands for the current version of the type library. Click the install button to install it into the IDE.

Now, Start a new Application, drop from whatever page of the component palette you have installed a TPDF component in a form, next add an OpenDialog, and finally a Button, in the Onclick event of the Button use:

procedure TForm1.Button1Click(Sender: TObject);
begin
  if OpenDialog1.Execute then
    pdf1.src := OpenDialog1.FileName;
end;

in PdfLib_TLB Unit you can find the interface of the TPdf class in order to know the behaviour of that class so here it is:

TPdf = class(TOleControl)
private
  FIntf: _DPdf;
  function GetControlInterface: _DPdf;
protected
  procedure CreateControl;
  procedure InitControlData; override;
public
  function LoadFile(const fileName: WideString): WordBool;
  procedure setShowToolbar(On_: WordBool);
  procedure gotoFirstPage;
  procedure gotoLastPage;
  procedure gotoNextPage;
  procedure gotoPreviousPage;
  procedure setCurrentPage(n: Integer);
  procedure goForwardStack;
  procedure goBackwardStack;
  procedure setPageMode(const pageMode: WideString);
  procedure setLayoutMode(const layoutMode: WideString);
  procedure setNamedDest(const namedDest: WideString);
  procedure Print;
  procedure printWithDialog;
  procedure setZoom(percent: Single);
  procedure setZoomScroll(percent: Single; left: Single; top:
    Single);
  procedure setView(const viewMode: WideString);
  procedure setViewScroll(const viewMode: WideString; offset:
    Single);
  procedure setViewRect(left: Single; top: Single; width: Single;
    height: Single);
  procedure printPages(from: Integer; to_: Integer);
  procedure printPagesFit(from: Integer; to_: Integer; shrinkToFit:
    WordBool);
  procedure printAll;
  procedure printAllFit(shrinkToFit: WordBool);
  procedure setShowScrollbars(On_: WordBool);
  procedure AboutBox;
  property ControlInterface: _DPdf read GetControlInterface;
  property DefaultInterface: _DPdf read GetControlInterface;
published
  property TabStop;
  property Align;
  property DragCursor;
  property DragMode;
  property ParentShowHint;
  property PopupMenu;
  property ShowHint;
  property TabOrder;
  property Visible;
  property OnDragDrop;
  property OnDragOver;
  property OnEndDrag;
  property OnEnter;
  property OnExit;
  property OnStartDrag;
  property src: WideString index 1 read GetWideStringProp write
    SetWideStringProp stored False;
end;

finally hereґs an advice:

You canґt be sure your users will have Acrobat Reader installed so please fisrt check that situation before you take any actions with the TPdf component. And second if your PDF file have links for an AVI file for example, they donґt work from Delphi.

Взято с

Delphi Knowledge Base

Как работать с полями типа DateTime?

Query1.sql.text:='Select * From TableName Where (Date>:D1) and (Date<:D2)';
Query1.params.parsSql(Query1.sql.text, true);
Query1.params.parambyname('d1').value:=Stringtodatetime('09.10.2002');
Query1.params.parambyname('d2').value:=Stringtodatetime('09.11.2002');
Query1.active:=true;

Возможно применение следующей квери:

SELECT Date
from TableName
where beetwen '01/01/2002' and '31/01/2002'

В этом коде 2 неточности, которые могут стать потенциальными ошибками, именно по этому я рекомендую использовать код с параметрами. Итак:

1) Не все SQL сервера понимают строки как нечто в одинарных кавычках, некоторые требуют двойных кавычек, некоторые сервера могут быть настроены на одинарные ил двойные кавычки. Если дату передавать как параметер, то конечную кверю будет строить сам сервер, и он поставит те кавычки, которые нужны.

2) Где гарантия что формат даты одинаковый на компьютере с программой и компьютере с базой данных? У меня может стоять на клиенте русская винда с русскими настройками и '2/9/2002' будет интерпретироваться как "2 сентября", а на компьютере с базой данных стоит регионарный стандарт для Америки и эта же дата будет означать "9 февраля". (Про разделители полей даты я уже молчу). В этом случае так же параметры работают корректнее - серверу передаётся дата, а он делает кверю в соответствии со своими регионарными стандартами.

Автор ответа: Vit
Взято с Vingrad.ru

Как работать с Powerpoint через OLE?

uses
  comobj;

procedure TForm1.Button2Click(Sender: TObject);
var
  PowerPointApp: OLEVariant;
begin
  try
    PowerPointApp := CreateOleObject('PowerPoint.Application');
  except
    ShowMessage('Error...');
    Exit;
  end;
  // Make Powerpoint visible
  PowerPointApp.Visible := True;

  // Show powerpoint version
  ShowMessage(Format('Powerpoint version: %s',[PowerPointApp.Version]));

  // Open a presentation
  PowerPointApp.Presentations.Open('c:\MyPresentation.ppt', False, False, True);

  // Show number of slides
  ShowMessage(Format('%s slides.',[PowerPointApp.ActivePresentation.Slides.Count]));

  // Run the presentation
  PowerPointApp.ActivePresentation.SlideShowSettings.Run;

  // Go to next slide
  PowerPointApp.ActivePresentation.SlideShowWindow.View.Next;

  // Go to slide 2
  PowerPointApp.ActivePresentation.SlideShowWindow.View.GoToSlide(2);

  // Go to previous slide
  PowerPointApp.ActivePresentation.SlideShowWindow.View.Previous;

  // Go to last slide
  PowerPointApp.ActivePresentation.SlideShowWindow.View.Last;

  // Show current slide name
  ShowMessage(Format('Current slidename: %s',[PowerPointApp.ActivePresentation.SlideShowWindow.View.Slide.Name]));

  // Close Powerpoint
  PowerPointApp.Quit;
  PowerPointApp := UnAssigned;
end;

Взято с сайта

Как работать с реестром средствами API?

Создать подраздел в реестре:

RegCreateKey(Key:HKey; SubKey: PChar; var Result: HKey): Longint;

Key - указывает на "корневой" раздел реестра, в Delphi1 доступен только один - HKEY_CLASSES_ROOT, а в Delphi3 - все.
SubKey - имя раздела - строится по принципу пути к файлу в DOS (пример subkey1\subkey2\ ...). Если такой раздел уже существует, то он открывается.
В любом случае при успешном вызове Result содержит Handle на раздел.
Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное - ошибка.

Открыть подраздел:

RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint;

Раздел Key
Подраздел SubKey
Возвращает Handle на подраздел в переменной Result. Если раздела с таким именем нет, то он не создается.
Возврат - код ошибки или ERROR_SUCCESS, если успешно.

Закрывает раздел:

RegCloseKey(Key: HKey): Longint;

Закрывает раздел, на который ссылается Key.
Возврат - код ошибки или ERROR_SUCCESS, если успешно.

Удалить подраздел:

RegDeleteKey(Key: HKey; SubKey: PChar): Longint;

Удалить подраздел Key\SubKey.
Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

Получить имена всех подразделов раздела Key:

RegEnumKey(Key:HKey; index: Longint; Buffer: PChar; cb: Longint): Longint;

Key - Handle на открытый или созданный раздел
Buffer - указатель на буфер
cb - размер буфера
index - индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование - в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой

Возвращает текстовую строку, связанную с ключом Key\SubKey:

RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint;

Ключ\подключ Key\SubKey.
Value - буфер для строки
cb - размер, на входе - размер буфера, на выходе - длина возвращаемой строки.
Возврат - код ошибки.

Задать новое значение ключу Key\SubKey:

RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint;

Ключ\подключ Key\SubKey.
ValType - тип задаваемой переменной,
Value - буфер для переменной
cb - размер буфера. В Windows 3.1 допустимо только Value=REG_SZ.
Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

Удаляет значение lpValueName находящееся в ключе hKey:

RegDeleteValue(HKEY hKey, LPCTSTR lpValueName);

hKey - ключ. hKey должен был быть открыт с доступом KEY_SET_VALUE процедурой RegOpenKey.
lpValueName - значение, находящееся в ключе hKey.
Возвращает ERROR_SUCCESS если успешно.

Выдает список значений у ключа hKey:

LONG RegEnumValue( HKEY hKey, DWORD dwIndex, LPTSTR lpValueName, LPDWORD lpcbValueName, LPDWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData);

hKey - ключ.
dwIndex - этот параметр должен быть 0 при первом вызове, а далее по анологии с RegEnumKey (т.е. можно использовать в цикле),
lpValueName - буфер для названия значения
lpcbValueName - размер lpValueName
lpReserved должно быть всегда 0
lpType - буфер для названия типа (int)
lpData - буфер для данных
lpcbData-размер для lpData
Примечание:
При каждой новом вызове функции после предыдущего нужно заново переназначить lpcbValueName.

lpcbValueName = sizeof(lpValueName)

Примеры:
{ Создаем список всех подразделов указанного раздела }
procedure TForm1.Button1Click(Sender: TObject);
var
  MyKey: HKey; { Handle для работы с разделом }
  Buffer: array[0 .. 1000] of char; { Буфер }
  Err, { Код ошибки }
  index: longint; { Индекс подраздела }
begin
  Err := RegOpenKey(HKEY_CLASSES_ROOT, 'DelphiUnit', MyKey); { Открыли раздел }
  if Err <> ERROR_SUCCESS then
  begin
    MessageDlg('Нет такого раздела !!', mtError, [mbOk], 0);
    exit;
  end;
  index := 0;
  {Определили имя первого подраздела }
  Err := RegEnumKey(MyKey, index, Buffer, Sizeof(Buffer));
  while err = ERROR_SUCCESS do { Цикл, пока есть подразделы }
  begin
    memo1.lines.add(StrPas(Buffer)); { Добавим имя подраздела в список }
    inc(index); { Увеличим номер подраздела }
    Err := RegEnumKey(MyKey, index, Buffer, Sizeof(Buffer)); { Запрос }
  end;
  RegCloseKey(MyKey); { Закрыли подраздел }
end;

Взято с

Реестр предназначен для хранения системных переменных и позволяет зарегистрировать файлы программы, что обеспечивает их показ в проводнике с соответствующей иконкой, вызов программы при щелчке на этом файле, добавление ряда команд в меню, вызываемое при нажатии правой кнопки мыши над файлом. Кроме того, в реестр можно внести некую свою информацию (переменные, константы, данные о инсталлированной программы ...). Программу можно добавить в список деинсталляции, что позволит удалить ее из менеджера "Установка/Удаление программ" панели управления.
Для работы с реестром применяется ряд функций API :
RegCreateKey (Key: HKey; SubKey: PChar; var Result: HKey): Longint;
Создать подраздел в реестре. Key указывает на "корневой" раздел реестра, в Delphi1 доступен только один - HKEY_CLASSES_ROOT, в в Delphi3 - все. SubKey - имя раздела - строится по принципу пути к файлу в DOS (пример subkey1\subkey2\ ...). Если такой раздел уже существует, то он открывается (в любом случае при успешном вызове Result содержит Handle на раздел). Об успешности вызова судят по возвращаемому значению, если ERROR_SUCCESS, то успешно, если иное - ошибка.

RegOpenKey(Key: HKey; SubKey: PChar; var Result: HKey): Longint;
Открыть подраздел Key\SubKey и возвращает Handle на него в переменной Result. Если раздела с таким именем нет, то он не создается. Возврат - код ошибки или ERROR_SUCCESS, если успешно.

RegCloseKey(Key: HKey): Longint;
Закрывает раздел, на который ссылается Key. Возврат - код ошибки или ERROR_SUCCESS, если успешно.

RegDeleteKey(Key: HKey; SubKey: PChar): Longint;
Удалить подраздел Key\SubKey. Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

RegEnumKey(Key: HKey; index: Longint; Buffer: PChar;cb: Longint): Longint;
Получить имена всех подразделов раздела Key, где Key - Handle на открытый или созданный раздел (см. RegCreateKey и RegOpenKey), Buffer - указатель на буфер, cb - размер буфера, index - индекс, должен быть равен 0 при первом вызове RegEnumKey. Типичное использование - в цикле While, где index увеличивается до тех пор, пока очередной вызов RegEnumKey не завершится ошибкой (см. пример).

RegQueryValue(Key: HKey; SubKey: PChar; Value: PChar; var cb: Longint): Longint;
Возвращает текстовую строку, связанную с ключом Key\SubKey.Value - буфер для строки; cb- размер, на входе - размер буфера, на выходе - длина возвращаемой строки. Возврат - код ошибки.

RegSetValue(Key: HKey; SubKey: PChar; ValType: Longint; Value: PChar; cb: Longint): Longint;
Задать новое значение ключу Key\SubKey, ValType - тип задаваемой переменной, Value - буфер для переменной, cb - размер буфера. В Windows 3.1 допустимо только Value=REG_SZ. Возврат - код ошибки или ERROR_SUCCESS, если нет ошибок.

Примеры :

{  Создаем список всех подразделов указанного раздела }
procedure TForm1.Button1Click(Sender: TObject);
var
MyKey   : HKey;   { Handle для работы с разделом }
Buffer   : array[0..1000] of char; { Буфер }
Err, { Код ошибки }
index   : longint; { Индекс подраздела }
begin
Err:=RegOpenKey(HKEY_CLASSES_ROOT,'DelphiUnit',MyKey); { Открыли раздел }
if Err<> ERROR_SUCCESS then
  begin
    MessageDlg('Нет такого раздела !!',mtError,[mbOk],0);
    exit;
  end;
index:=0;
{Определили имя первого подраздела }
Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer));
while err=ERROR_SUCCESS do { Цикл, пока есть подразделы }
  begin
    memo1.lines.add(StrPas(Buffer)); { Добавим имя подраздела в список }
    inc(index); { Увеличим номер подраздела }
    Err:=RegEnumKey(MyKey,index,Buffer,Sizeof(Buffer)); { Запрос }
  end;
RegCloseKey(MyKey); { Закрыли подраздел }
end;

Источник:

Как работать с реестром Windows?

{ Вот небольшой пример работы с системным реестром; }

uses
  Registry, Windows;

procedure TForm1.Button1Click(Sender: TObject);
var
  Registry: TRegistry;
begin
  { создаём объект TRegistry }
  Registry := TRegistry.Create;
  { устанавливаем корневой ключ; напрмер hkey_local_machine или hkey_current_user }
  Registry.RootKey := hkey_local_machine;
  { открываем и создаём ключ }
  Registry.OpenKey('software\MyRegistryExample',true);
  { записываем значение }
  Registry.WriteString('MyRegistryName','MyRegistry Value');
  { закрываем и освобождаем ключ }
  Registry.CloseKey;
  Registry.Free;
end;

// для удаления ключа используется функция Registry.DeleteKey

Взято с Исходников.ru

Как работать с Shapes

{... }
var
  Pic: Word2000.Shape;
  Left, Top: OleVariant;
  { ... }

{To add a pic and make it appear behind text}
Left := 100;
Top := 100;
Pic := Doc.Shapes.AddPicture('C:\Small.bmp', EmptyParam, EmptyParam, Left, Top,
  EmptyParam, EmptyParam, EmptyParam);
Pic.WrapFormat.Type_ := wdWrapNone;
Pic.ZOrder(msoSendBehindText);
{To get a watermark effect}
Pic.PictureFormat.Brightness := 0.75;
Pic.PictureFormat.Contrast := 0.20;
{To make any white in a picture transparent}
Pic.PictureFormat.TransparencyColor := clWhite;
Pic.PictureFormat.TransparentBackground := msoTrue;
Pic.Fill.Visible := msoFalse;
{ ... }

Взято с

Delphi Knowledge Base

Как работать с ssShift и TShiftState?

ssShift - это константа применяемая в типе TShiftState (являущемся типом Set) а не логическая, надо примерно так:

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState);
begin
if (key=$97) and (ssShift in Shift) then
begin
{do something}
end;
end;

Автор ответа: Vit
Взято с Vingrad.ru

Как работать с Web камерой?

First of all, get the SDK at http://developer.logitech.comhttp://developer.logitech.com

After installation, open delphi and Import ActiveX Control VPortal2 from the list.

Now, create a new form, and put a VideoPortal from the ActiveX panel and a button.

In the uses, add VideoPortal

On the OnShow add:

VideoPortal1.PrepareControl('QCSDK',
'HKEY_LOCAL_MACHINE\Software\JCS Programmation\QCSDK', 0);
VideoPortal1.EnableUIElements(UIELEMENT_STATUSBAR, 0, 0);
VideoPortal1.ConnectCamera2;
VideoPortal1.EnablePreview := 1;

On the ButtonClick add:

var
  BMP: TBitmap;
  JPG: TJpegImage;
  L: string;
begin
  F := 'Photos\test.jpg';
  VideoPortal1.StampBackgroundColor := clYellow;
  VideoPortal1.StampTextColor := clBlack;
  VideoPortal1.StampFontName := 'Arial';
  VideoPortal1.StampPointSize := 10;
  VideoPortal1.StampTransparentBackGround := 0;
  L := Format(' %s - %s ', [DateTimeToStr(Now), Num]);
  VideoPortal1.PictureToFile(0, 24, 'Temp.bmp', L);
  BMP := TBitmap.Create;
  JPG := TJpegImage.Create;
  BMP.LoadFromFile('Temp.bmp');
  JPG.CompressionQuality := 85;
  JPG.Assign(BMP);
  JPG.SaveToFile(F);
  BMP.Free;
  JPG.Free;
end;

It's all, run the application, you will see the image from the camera, click on the button to get a picture.

Here is a copy a VideoPortal.Pas (constants).

unit VideoPortal;

interface
// Copyright (c) 1996-2000 Logitech, Inc.  All Rights Reserved
// User Interface Element, codes used with EnableUIElement method
const
  UIELEMENT_640x480 = 0;
const
  UIELEMENT_320x240 = 1;
const
  UIELEMENT_PCSMART = 2;
const
  UIELEMENT_STATUSBAR = 3;
const
  UIELEMENT_UI = 4;
const
  UIELEMENT_CAMERA = 5;
const
  UIELEMENT_160x120 = 6;

  // Camera status codes, returned by CameraState property
const
  CAMERA_OK = 0;
const
  CAMERA_UNPLUGGED = 1;
const
  CAMERA_INUSE = 2;
const
  CAMERA_ERROR = 3;
const
  CAMERA_SUSPENDED = 4;
const
  CAMERA_DUAL_DETACHED = 5;
const
  CAMERA_UNKNOWNSTATUS = 10;

  // Movie Recording Modes, used with MovieRecordMode property
const
  SEQUENCECAPTURE_FPS_USERSPECIFIED = 1;
const
  SEQUENCECAPTURE_FPS_FASTASPOSSIBLE = 2;
const
  STEPCAPTURE_MANUALTRIGGERED = 3;

  // Movie Creation Flags, used with MovieCreateFlags property
const
  MOVIECREATEFLAGS_CREATENEW = 1;
const
  MOVIECREATEFLAGS_APPEND = 2;

  // Notification Codes
const
  NOTIFICATIONMSG_MOTION = 1;
const
  NOTIFICATIONMSG_MOVIERECORDERROR = 2;
const
  NOTIFICATIONMSG_CAMERADETACHED = 3;
const
  NOTIFICATIONMSG_CAMERAREATTACHED = 4;
const
  NOTIFICATIONMSG_IMAGESIZECHANGE = 5;
const
  NOTIFICATIONMSG_CAMERAPRECHANGE = 6;
const
  NOTIFICATIONMSG_CAMERACHANGEFAILED = 7;
const
  NOTIFICATIONMSG_POSTCAMERACHANGED = 8;
const
  NOTIFICATIONMSG_CAMERBUTTONCLICKED = 9;
const
  NOTIFICATIONMSG_VIDEOHOOK = 10;
const
  NOTIFICATIONMSG_SETTINGDLGCLOSED = 11;
const
  NOTIFICATIONMSG_QUERYPRECAMERAMODIFICATION = 12;
const
  NOTIFICATIONMSG_MOVIESIZE = 13;

  // Error codes used by NOTIFICATIONMSG_MOVIERECORDERROR notification:
const
  WRITEFAILURE_RECORDINGSTOPPED = 0;
const
  WRITEFAILURE_RECORDINGSTOPPED_FILECORRUPTANDDELETED = 1;
const
  WRITEFAILURE_CAMERA_UNPLUGGED = 2;
const
  WRITEFAILURE_CAMERA_SUSPENDED = 3;

  // Camera type codes, returned by GetCameraType method
const
  CAMERA_UNKNOWN = 0;
const
  CAMERA_QUICKCAM_VC = 1;
const
  CAMERA_QUICKCAM_QUICKCLIP = 2;
const
  CAMERA_QUICKCAM_PRO = 3;
const
  CAMERA_QUICKCAM_HOME = 4;
const
  CAMERA_QUICKCAM_PRO_B = 5;
const
  CAMERA_QUICKCAM_TEKCOM = 6;
const
  CAMERA_QUICKCAM_EXPRESS = 7;
const
  CAMERA_QUICKCAM_FROG = 8; // MIGHT CHANGE NAME BUT ENUM STAYS THE SAME
const
  CAMERA_QUICKCAM_EMERALD = 9; // MIGHT CHANGE NAME BUT ENUM STAYS THE SAME

  // Camera-specific property codes used by Set/GetCameraPropertyLong
const
  PROPERTY_ORIENTATION = 0;
const
  PROPERTY_BRIGHTNESSMODE = 1;
const
  PROPERTY_BRIGHTNESS = 2;
const
  PROPERTY_CONTRAST = 3;
const
  PROPERTY_COLORMODE = 4;
const
  PROPERTY_REDGAIN = 5;
const
  PROPERTY_BLUEGAIN = 6;
const
  PROPERTY_SATURATION = 7;
const
  PROPERTY_EXPOSURE = 8;
const
  PROPERTY_RESET = 9;
const
  PROPERTY_COMPRESSION = 10;
const
  PROPERTY_ANTIBLOOM = 11;
const
  PROPERTY_LOWLIGHTFILTER = 12;
const
  PROPERTY_IMAGEFIELD = 13;
const
  PROPERTY_HUE = 14;
const
  PROPERTY_PORT_TYPE = 15;
const
  PROPERTY_PICTSMART_MODE = 16;
const
  PROPERTY_PICTSMART_LIGHT = 17;
const
  PROPERTY_PICTSMART_LENS = 18;
const
  PROPERTY_MOTION_DETECTION_MODE = 19;
const
  PROPERTY_MOTION_SENSITIVITY = 20;
const
  PROPERTY_WHITELEVEL = 21;
const
  PROPERTY_AUTO_WHITELEVEL = 22;
const
  PROPERTY_ANALOGGAIN = 23;
const
  PROPERTY_AUTO_ANALOGGAIN = 24;
const
  PROPERTY_LOWLIGHTBOOST = 25;
const
  PROPERTY_COLORBOOST = 26;
const
  PROPERTY_ANTIFLICKER = 27;
const
  PROPERTY_OPTIMIZATION_SPEED_QUALITY = 28;
const
  PROPERTY_STREAM_HOOK = 29;
const
  PROPERTY_LED = 30;

const
  ADJUSTMENT_MANUAL = 0;
const
  ADJUSTMENT_AUTOMATIC = 1;

const
  ORIENTATIONMODE_NORMAL = 0;
const
  ORIENTATIONMODE_MIRRORED = 1;
const
  ORIENTATIONMODE_FLIPPED = 2;
const
  ORIENTATIONMODE_FLIPPED_AND_MIRRORED = 3;

const
  COMPRESSION_Q0 = 0;
const
  COMPRESSION_Q1 = 1;
const
  COMPRESSION_Q2 = 2;

const
  ANTIFLICKER_OFF = 0;
const
  ANTIFLICKER_50Hz = 1;
const
  ANTIFLICKER_60Hz = 2;

const
  OPTIMIZE_QUALITY = 0;
const
  OPTIMIZE_SPEED = 1;

const
  LED_OFF = 0;
const
  LED_ON = 1;
const
  LED_AUTO = 2;
const
  LED_MAX = 3;

const
  PICTSMART_LIGHTCORRECTION_NONE = 0;
const
  PICTSMART_LIGHTCORRECTION_COOLFLORESCENT = 1;
const
  PICTSMART_LIGHTCORRECTION_WARMFLORESCENT = 2;
const
  PICTSMART_LIGHTCORRECTION_OUTSIDE = 3;
const
  PICTSMART_LIGHTCORRECTION_TUNGSTEN = 4;

const
  PICTSMART_LENSCORRECTION_NORMAL = 0;
const
  PICTSMART_LENSCORRECTION_WIDEANGLE = 1;
const
  PICTSMART_LENSCORRECTION_TELEPHOTO = 2;

const
  CAMERADLG_GENERAL = 0;
const
  CAMERADLG_ADVANCED = 1;

implementation
end.

Example shows how to use the PictureToMemory method in the QuickCam SDK.

type
  TMemoryStream = class(Classes.TMemoryStream);

var
  MS: TMemoryStream;
  lSize: LongInt;
  pBuffer: ^Byte;

begin

  MS := TMemoryStream.Create;
  bitmap1 := TBitmap.Create;

  try
    if VideoPortal1.PictureToMemory(0, 24, 0, lSize, '') = 1 then
    begin
      pBuffer := AllocMem(lSize);
      if VideoPortal1.PictureToMemory(0, 24, integer(pBuffer), lSize, '') = 1 then
      begin
        MS.SetPointer(pBuffer, lSize);
        bitmap1.loadfromstream(MS);
      end;
    end;
  finally
    MS.Free;
    FreeMem(pBuffer);
  end;
end;

Взято с

Delphi Knowledge Base

Как работать с WordBasic?

uses

OleAuto;

var
  MSWord: Variant;

begin
  MsWord := CreateOleObject('Word.Basic');
  MsWord.FileNewDefault;
  MsWord.TogglePortrait;
end;

Взято с

Delphi Knowledge Base