Как из dll узнать узнать полный путь к этой dll

function GetModuleFileNameStr(Instance: THandle): String;
var
  buffer : array [0..MAX_PATH] of Char;
begin
  GetModuleFileName( Instance, buffer, MAX_PATH);
  Result := buffer;
end;

   GetModuleFileNameStr(Hinstance); // dll name
   GetModuleFileNameStr(0); // exe name

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

uses registry;

...

procedure TForm1.Button1Click(Sender: TObject);
var
  reg : TRegistry;
  st : TStrings;
  i : integer;
begin
  Memo1.Clear;
  reg := TRegistry.Create;
  reg.RootKey := HKEY_LOCAL_MACHINE;
  reg.OpenKey('hardware\devicemap\serialcomm',false);
  st := TStringList.Create;
  reg.GetValueNames(st);
  for i := 0 to st.Count -1 do begin
    Memo1.Lines.Add(reg.ReadString(st.Strings[i]));
  end;
  st.Free;
  reg.CloseKey;
  reg.free;
end;

Неглавное окно приложения поверх всех окон в системе

Для того, чтобы неглавное окно приложения располагалось поверх всех окон в системе, нужно "отцепить" его от родительского окна.

procedure TForm2.FormShow(Sender: TObject);
begin
SetWindowLong(Handle, GWL_HWNDPARENT, GetDesktopWindow); // Устанавливаем родителем Desctop
SetWindowPos(Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE or SWP_NOMOVE); // Перемещаем наверх
end;

Скрыть программу только из вкладки процессы

Используется DLL.

объявление

THideProc = function (pid: DWORD; HideOnlyFromTaskManager: BOOL): BOOL; stdcall;

library nthide;

uses Windows, SysUtils, ImageHlp, TlHelp32;

type SYSTEM_INFORMATION_CLASS = (
SystemBasicInformation,
SystemProcessorInformation,
SystemPerformanceInformation,
SystemTimeOfDayInformation,
SystemNotImplemented1,
SystemProcessesAndThreadsInformation,
SystemCallCounts,
SystemConfigurationInformation,
SystemProcessorTimes,
SystemGlobalFlag,
SystemNotImplemented2,
SystemModuleInformation,
SystemLockInformation,
SystemNotImplemented3,
SystemNotImplemented4,
SystemNotImplemented5,
SystemHandleInformation,
SystemObjectInformation,
SystemPagefileInformation,
SystemInstructionEmulationCounts,
SystemInvalidInfoClass1,
SystemCacheInformation,
SystemPoolTagInformation,
SystemProcessorStatistics,
SystemDpcInformation,
SystemNotImplemented6,
SystemLoadImage,
SystemUnloadImage,
SystemTimeAdjustment,
SystemNotImplemented7,
SystemNotImplemented8,
SystemNotImplemented9,
SystemCrashDumpInformation,
SystemExceptionInformation,
SystemCrashDumpStateInformation,
SystemKernelDebuggerInformation,
SystemContextSwitchInformation,
SystemRegistryQuotaInformation,
SystemLoadAndCallImage,
SystemPrioritySeparation,
SystemNotImplemented10,
SystemNotImplemented11,
SystemInvalidInfoClass2,
SystemInvalidInfoClass3,
SystemTimeZoneInformation,
SystemLookasideInformation,
SystemSetTimeSlipEvent,
SystemCreateSession,
SystemDeleteSession,
SystemInvalidInfoClass4,
SystemRangeStartInformation,
SystemVerifierInformation,
SystemAddVerifier,
SystemSessionProcessesInformation
);

_IMAGE_IMPORT_DESCRIPTOR = packed record
  case Integer of
   0:(
    Characteristics: DWORD);
   1:(
    OriginalFirstThunk:DWORD;
    TimeDateStamp:DWORD;
    ForwarderChain: DWORD;
    Name: DWORD;
    FirstThunk: DWORD);
   end;
IMAGE_IMPORT_DESCRIPTOR=_IMAGE_IMPORT_DESCRIPTOR;
PIMAGE_IMPORT_DESCRIPTOR=^IMAGE_IMPORT_DESCRIPTOR;

PFARPROC=^FARPROC;

procedure ReplaceIATEntryInOneMod(pszCallerModName: Pchar; pfnCurrent: FarProc; pfnNew: FARPROC; hmodCaller: hModule);
var     ulSize: ULONG;
   pImportDesc: PIMAGE_IMPORT_DESCRIPTOR;
    pszModName: PChar;
        pThunk: PDWORD; ppfn:PFARPROC;
        ffound: LongBool;
       written: DWORD;
begin
pImportDesc:= ImageDirectoryEntryToData(Pointer(hmodCaller), TRUE,IMAGE_DIRECTORY_ENTRY_IMPORT, ulSize);
  if pImportDesc = nil then exit;
  while pImportDesc.Name<>0 do
   begin
    pszModName := PChar(hmodCaller + pImportDesc.Name);
     if (lstrcmpiA(pszModName, pszCallerModName) = 0) then break;
    Inc(pImportDesc);
   end;
  if (pImportDesc.Name = 0) then exit;
pThunk := PDWORD(hmodCaller + pImportDesc.FirstThunk);
  while pThunk^<>0 do
   begin
    ppfn := PFARPROC(pThunk);
    fFound := (ppfn^ = pfnCurrent);
     if (fFound) then
      begin
       VirtualProtectEx(GetCurrentProcess,ppfn,4,PAGE_EXECUTE_READWRITE,written);
       WriteProcessMemory(GetCurrentProcess, ppfn, @pfnNew, sizeof(pfnNew), Written);
       exit;
      end;
    Inc(pThunk);
   end;
end;

var
addr_NtQuerySystemInformation: Pointer;
mypid: DWORD;
fname: PCHAR;
mapaddr: PDWORD;
hideOnlyTaskMan: PBOOL;

function myNtQuerySystemInfo(SystemInformationClass: SYSTEM_INFORMATION_CLASS; SystemInformation: Pointer;
SystemInformationLength:ULONG; ReturnLength:PULONG):LongInt; stdcall;
label onceagain, getnextpidstruct, quit, fillzero;
asm
push ReturnLength
push SystemInformationLength
push SystemInformation
push dword ptr SystemInformationClass
call dword ptr [addr_NtQuerySystemInformation]
or eax,eax
jl quit
cmp SystemInformationClass, SystemProcessesAndThreadsInformation
jne quit

onceagain:
mov esi, SystemInformation

getnextpidstruct:
mov ebx, esi
cmp dword ptr [esi],0
je quit
add esi, [esi]
mov ecx, [esi+44h]
cmp ecx, mypid
jne getnextpidstruct
mov edx, [esi]
test edx, edx
je fillzero
add [ebx], edx
jmp onceagain

fillzero:
and [ebx], edx
jmp onceagain

quit:
mov Result, eax
end;

procedure InterceptFunctions;
var hSnapShot: THandle;
         me32: MODULEENTRY32;
begin
addr_NtQuerySystemInformation:=GetProcAddress(getModuleHandle('ntdll.dll'),'NtQuerySystemInformation');
hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMODULE,GetCurrentProcessId);
  if hSnapshot=INVALID_HANDLE_VALUE then exit;
   try
    ZeroMemory(@me32,sizeof(MODULEENTRY32));
    me32.dwSize:=sizeof(MODULEENTRY32);
    Module32First(hSnapShot,me32);
     repeat
      ReplaceIATEntryInOneMod('ntdll.dll',addr_NtQuerySystemInformation,@MyNtQuerySystemInfo,me32.hModule);
     until not Module32Next(hSnapShot,me32);
   finally
    CloseHandle(hSnapShot);
   end;
end;

procedure UninterceptFunctions;
var hSnapShot: THandle;
         me32: MODULEENTRY32;
begin
addr_NtQuerySystemInformation:=GetProcAddress(getModuleHandle('ntdll.dll'),'NtQuerySystemInformation');
hSnapShot:=CreateToolHelp32SnapShot(TH32CS_SNAPMODULE,GetCurrentProcessId);
  if hSnapshot=INVALID_HANDLE_VALUE then exit;
  try
   ZeroMemory(@me32,sizeof(MODULEENTRY32));
   me32.dwSize:=sizeof(MODULEENTRY32);
   Module32First(hSnapShot,me32);
    repeat
     ReplaceIATEntryInOneMod('ntdll.dll',@MyNtQuerySystemInfo,addr_NtQuerySystemInformation,me32.hModule);
    until not Module32Next(hSnapShot,me32);
  finally
   CloseHandle(hSnapShot);
  end;
end;

var HookHandle: THandle;

function CbtProc(code: integer; wparam: integer; lparam: integer):Integer; stdcall;
begin
Result:=0;
end;

procedure InstallHook; stdcall;
begin
HookHandle:=SetWindowsHookEx(WH_CBT, @CbtProc, HInstance, 0);
end;

var hFirstMapHandle:THandle;

function HideProcess(pid:DWORD; HideOnlyFromTaskManager:BOOL):BOOL; stdcall;
var addrMap: PDWORD;
       ptr2: PBOOL;
begin
mypid:=0;
result:=false;
hFirstMapHandle:=CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,8,'NtHideFileMapping');
  if hFirstMapHandle=0 then exit;
addrMap:=MapViewOfFile(hFirstMapHandle,FILE_MAP_WRITE,0,0,8);
  if addrMap=nil then
   begin
    CloseHandle(hFirstMapHandle);
    exit;
   end;
addrMap^:=pid;
ptr2:=PBOOL(DWORD(addrMap)+4);
ptr2^:=HideOnlyFromTaskManager;
UnmapViewOfFile(addrMap);
InstallHook;
result:=true;
end;

exports
HideProcess;

var
hmap: THandle;

procedure LibraryProc(Reason: Integer);
begin
if Reason = DLL_PROCESS_DETACH then
  if mypid > 0 then
   UninterceptFunctions()
else
  CloseHandle(hFirstMapHandle);
end;

begin
hmap:=OpenFileMapping(FILE_MAP_READ,false,'NtHideFileMapping');
  if hmap=0 then exit;
  try
   mapaddr:=MapViewOfFile(hmap,FILE_MAP_READ,0,0,0);
    if mapaddr=nil then exit;
   mypid:=mapaddr^;
   hideOnlyTaskMan:=PBOOL(DWORD(mapaddr)+4);
    if hideOnlyTaskMan^ then
     begin
      fname:=allocMem(MAX_PATH+1);
      GetModuleFileName(GetModuleHandle(nil),fname,MAX_PATH+1);
       if not (ExtractFileName(fname)='taskmgr.exe') then exit;
     end;
   InterceptFunctions;
  finally
   UnmapViewOfFile(mapaddr);
   CloseHandle(Hmap);
   DLLProc:=@LibraryProc;
  end;
end.

Как показать диалог выбора директории

из модуля FileCtrl.

1. function SelectDirectory(const Caption: string; const Root: WideString;
out Directory: string): Boolean; overload;
2. function SelectDirectory(var Directory: string; Options: TSelectDirOpts;
HelpCtx: Longint): Boolean; overload;

из RxLib
TDirectoryEdit

function GetDirectory(nFolder: Longint): String;
var
Bi : TBrowseInfo;
lpName: array [0..MAX_PATH] of Char;
ppidl, aItemLst : PItemIDList;
begin
SHGetSpecialFolderLocation(Application.Handle, nFolder, ppidl);
FillChar(Bi, SizeOf(bi), 0);
Bi.hwndOwner := Application.Handle;
Bi.pidlRoot := ppidl;
Bi.pszDisplayName := lpName;
Bi.lpszTitle := 'Open directory';
aItemLst := SHBrowseForFolder(Bi);
CoTaskMemFree(ppidl);
SHGetPathFromIDList(aItemLst, lpName);
CoTaskMemFree(aItemLst);
Result := lpName;
end;

Пример использования (иначе не поймут, что такое nFolder)

// значения nFolder можно найти в описании
// к SHGetSpecialFolderLocation
// из Win32 Programmer's Reference (win32.hlp)

procedure TForm1.Button1Click(Sender: TObject);
begin
Caption := GetDirectory(CSIDL_DRIVES);
end;

Как сделать .manifest для Windows XP

Для того, чтобы программы запускаемые под Windows XP, имели новый вид,
необходимо вместе с программой поставить файл *.manifest или включить его в
ресурс.
Для это изготовить файл, по ниже приведенной инструкции, назвать его
Project1.exe.manifest, по положить рядышком с Project1.exe, после это
запускаешь под XP и радуешься 



XP User utils test

Как сделать регулятор громкости

ВОТ нашел в Интернете:

Эта программа увеличивает громкость выбранного канала на 1000.

uses MMSystem;

procedure TForm1.Button1Click(Sender: TObject);
var
  vol: longint;
  LVol, RVol: integer;
begin
  AuxGetVolume(ListBox1.ItemIndex, @Vol);
  LVol := Vol shr 16;
  if LVol < MaxWord - 1000
    then LVol := LVol + 1000
    else LVol := MaxWord;
  RVol := (Vol shl 16) shr 16;
  if RVol < MaxWord - 1000
    then RVol := RVol + 1000
    else RVol := MaxWord;
  AuxSetVolume(ListBox1.ItemIndex, LVol shl 16 + RVol);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  i: integer;
  cap: TAuxCaps;
begin
  for i := 0 to auxGetNumDevs - 1 do begin
    auxGetDevCaps(i, Addr(cap), SizeOf(cap));
    ListBox1.Items.Add(cap.szPname)
  end;
end;

Второй вариант:

uses mmsystem;

function GetWaveVolume: DWord;
var Woc : TWAVEOUTCAPS;
      Volume : DWord;
begin
result:=0;
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then
begin
WaveOutGetVolume(WAVE_MAPPER, @Volume);
Result := Volume;
end;
end;

procedure SetWaveVolume(const AVolume: DWord);
var Woc : TWAVEOUTCAPS;
begin
if WaveOutGetDevCaps(WAVE_MAPPER, @Woc, sizeof(Woc)) = MMSYSERR_NOERROR then
if Woc.dwSupport and WAVECAPS_VOLUME = WAVECAPS_VOLUME then WaveOutSetVolume(WAVE_MAPPER, AVolume);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Beep;
end;

procedure TForm1.Button2Click(Sender: TObject);
var	LeftVolume: Word;
	RightVolume: Word;
begin
LeftVolume := StrToInt(Edit1.Text);
RightVolume := StrToInt(Edit2.Text);
SetWaveVolume(MakeLong(LeftVolume, RightVolume));
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Caption := IntToStr(GetWaveVolume);
end;

Как определить какая Windows 32 или 64-разрядная

Можно вызвать IsWow64Process (из kernel32.dll)

BOOL IsWow64Process(
  HANDLE hProcess,
  PBOOL Wow64Process );

Для 32-х разрядного процесса в 64-х разрядной ОС будет установлена TRUE во втором параметре, для систем ниже WinXP (где нет смысла выяснять 64-х разрядность) будет ошибка ERROR_CALL_NOT_IMPLEMENTED.

Сохранение и загрузка любых изображений

С использованием TImage для форматов bmp, jpg и gif я делал это так.

Занесение изображения в TImage и в БД:

procedure TfmMain.btnOpenClick(Sender: TObject);
var
  S: TStream;
begin
  if OpenDialog1.Execute then
  begin
    Image1.Picture.LoadFromFile(OpenDialog1.FileName);
    ADODataSet1.Edit;
    S := ADODataSet1.CreateBlobStream(ADODataSet1.FieldByName('GRAPHIC'), bmWrite);
    try
      Image1.Picture.Graphic.SaveToStream(S);
    finally
      S.Free;
      ADODataSet1.Post;
    end;
  end;
end;

Здесь всё как и в статье с сайта Borland.

Чтение из БД в TImage выглядит так:

uses ..., JPEG, RxGIF;
...
procedure TfmMain.ShowPicture;
var
  S: TStream;
  Code: Word;
begin
  //Процедура показывает изображение, а если его нет в базе, стирает TImage
  if Assigned(Image1.Picture.Graphic) then
    Image1.Picture := nil;
  if not ADODataSet1.FieldByName('GRAPHIC').IsNull then
  begin
    S := ADODataSet1.CreateBlobStream(ADODataSet1.FieldByName('GRAPHIC'), bmRead);
    try
      S.Read(Code, SizeOf(Code));
      S.Seek(0, 0);
      case Code of
      $4D42:
      begin
        Image1.Picture.Graphic := TBitmap.Create;
        Image1.Picture.Graphic.LoadFromStream(S);
      end;
      $D8FF:
      begin
        Image1.Picture.Graphic := TJPEGImage.Create;
        Image1.Picture.Graphic.LoadFromStream(S);
      end;
      $4947:
      begin
        Image1.Picture.Graphic := TGIFImage.Create;
        Image1.Picture.Graphic.LoadFromStream(S);
      end;
      end;
    finally
      S.Free;
    end;
  end;
end;

А вот сохранение из БД в файл:

procedure TfmMain.btnSaveClick(Sender: TObject);
var
  S: TStream;
  FileS: TFileStream;
  Code: Word;
begin
  //Процедура сохраняет изображение в файл в зависимости от его формата
  if not ADODataSet1.FieldByName('GRAPHIC').IsNull then
  begin
    S := pFIBDataSet1.CreateBlobStream(ADODataSet1.FieldByName('GRAPHIC'), bmRead);
    try
      S.Read(Code, SizeOf(Code));
      S.Seek(0, 0);
      case Code of
      $4D42:
      begin
        SaveDialog1.Filter := 'Bitmap (*.bmp)|*.bmp';
        SaveDialog1.DefaultExt := 'bmp';
      end;
      $D8FF:
      begin
        SaveDialog1.Filter := 'Файл изображений JPEG (*.jpg)|*.jpg';
        SaveDialog1.DefaultExt := 'jpg';
      end;
      $4947:
      begin
        SaveDialog1.Filter := 'Изображение CompuServe GIF (*.gif)|*.gif';
        SaveDialog1.DefaultExt := 'gif';
      end;
      end;
      if SaveDialog1.Execute then
        if FileExists(SaveDialog1.FileName) then
          FileS := TFileStream.Create(SaveDialog1.FileName, fmOpenWrite)
        else
          FileS := TFileStream.Create(SaveDialog1.FileName, fmCreate);
        try
          FileS.CopyFrom(S, S.Size);
        finally
          FileS.Free;
        end;
    finally
      S.Free;
    end;
  end;
end;

Здесь для поддержки формата jpg использован стандартный модуль Delphi Jpeg, а для поддержки формата gif пришлось использовать библиотеку компонентов Rx (модуль RxGIF).

Используя такой подход, можно вообще-то преобразовывать изображения в bmp и хранить их в БД в едином формате. Тогда надо определять формат изображения при загрузке его из файла, преобразовывать в bmp и потом сохранять в БД.

Преобразовывать так:

var
  J: TJPEGImage;
...
Image1.Picture.Bitmap.Assign(J);
 Kraks

Серийный номер USB устройства

uses JwaWinIoctl;

procedure GetSerial:String;
  var Dummy   :DWord;
      FHandle   :Cardinal;
      RealPath  :String;
      dg             :CHANGER_PRODUCT_DATA; //falscher Datentyp? Laut SDK musste es eigentlich
// MEDIA_SERIAL_NUMBER_DATA sein aber den gibs nicht
      Serial        :String;
      i                :byte;
begin
        RealPath:='\\.\F:';
        FHandle:=CreateFile(PChar(RealPath),GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
        if DeviceIOControl(FHandle,IOCTL_STORAGE_GET_MEDIA_SERIAL_NUMBER, nil, 0, @dg, sizeof(dg), dummy, nil) then begin
            Serial:='';
            for i:=0 to 31 do Serial:=Serial+IntToStr(dg.SerialNumber[i]);
            Result:=Serial;
          end;
      end;
    end;
    Inc(pDrive, 4);
  end;
end;

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

MEDIA_SERIAL_NUMBER_DATA Structure

Contains the serial number of a USB device. It is used by the IOCTL_STORAGE_GET_MEDIA_SERIAL_NUMBER control code.
typedef struct _MEDIA_SERIAL_NUMBER_DATA {
  ULONG SerialNumberLength;
  ULONG Result;
  ULONG Reserved[2];
  UCHAR SerialNumberData[];
} MEDIA_SERIAL_NUMBER_DATA,
 *PMEDIA_SERIAL_NUMBER_DATA;
Members
SerialNumberLength

The size of the SerialNumberData string, in bytes.
Result

The status of the request.
Reserved

Reserved.
SerialNumberData

The serial number of the device.
Remarks

No header file is available for the MEDIA_SERIAL_NUMBER_DATA structure. Include the structure definition at the top of this page in your source code.
RequirementsClient	Requires Windows Vista or Windows XP.

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

IOCTL_STORAGE_GET_MEDIA_SERIAL_NUMBER Control Code

Retrieves the serial number of a USB device.

To perform this operation, call the DeviceIoControl function with the following parameters.
BOOL DeviceIoControl(
  (HANDLE) hDevice,                      // handle to device
  IOCTL_STORAGE_GET_MEDIA_SERIAL_NUMBER, // dwIoControlCode
  NULL,                                  // lpInBuffer
  0,                                     // nInBufferSize
  (LPVOID) lpOutBuffer,                  // output buffer
  (DWORD) nOutBufferSize,                // size of output buffer
  (LPDWORD) lpBytesReturned,             // number of bytes returned
  (LPOVERLAPPED) lpOverlapped            // OVERLAPPED structure
);
Parameters
hDevice

A handle to the device. To obtain a device handle, call the CreateFile function.
dwIoControlCode

The control code for the operation. Use IOCTL_STORAGE_GET_MEDIA_SERIAL_NUMBER for this operation.
lpInBuffer

Not used with this operation; set to NULL.
nInBufferSize

Not used with this operation; set to zero.
lpOutBuffer

A pointer to a MEDIA_SERIAL_NUMBER_DATA structure that receives the serial number.
nOutBufferSize

The size of the output buffer, in bytes.
lpBytesReturned

A pointer to a variable that receives the size of the data stored in the output buffer, in bytes.

If the output buffer is too small, the call fails, GetLastError returns ERROR_INSUFFICIENT_BUFFER, and lpBytesReturned is zero.

If lpOverlapped is NULL, lpBytesReturned cannot be NULL. Even when an operation returns no output data and lpOutBuffer is NULL, DeviceIoControl makes use of lpBytesReturned. After such an operation, the value of lpBytesReturned is meaningless.

If lpOverlapped is not NULL, lpBytesReturned can be NULL. If this parameter is not NULL and the operation returns data, lpBytesReturned is meaningless until the overlapped operation has completed. To retrieve the number of bytes returned, call GetOverlappedResult. If hDevice is associated with an I/O completion port, you can retrieve the number of bytes returned by calling GetQueuedCompletionStatus.
lpOverlapped

A pointer to an OVERLAPPED structure.

If hDevice was opened without specifying FILE_FLAG_OVERLAPPED, lpOverlapped is ignored.

If hDevice was opened with the FILE_FLAG_OVERLAPPED flag, the operation is performed as an overlapped (asynchronous) operation. In this case, lpOverlapped must point to a valid OVERLAPPED structure that contains a handle to an event object. Otherwise, the function fails in unpredictable ways.

For overlapped operations, DeviceIoControl returns immediately, and the event object is signaled when the operation has been completed. Otherwise, the function does not return until the operation has been completed or an error occurs.
Return Value

If the operation completes successfully, DeviceIoControl returns a nonzero value.

If the operation fails or is pending, DeviceIoControl returns zero. To get extended error information, call GetLastError.
RequirementsClient	Requires Windows Vista or Windows XP.