Скины

[Fliplab]

Ребят посоветуйте какойнибудь бесплатный компонент для Delphi для поддержки скинов, а то стоит триальный AlphaControls7 и не очень удобно к проге подвязывать свою либу по блоку вывода о триале.

Вот, если кому надо исходник [killtrial.dll]:

{
Kill trial of AlphaControls7
version 1.0
email:fliplab@ya.ru
author:Fliplab Software
icq:1948260
}

library KillTrial;

uses
Windows;

type
OldCode = packed record
One: DWord;
Two: Word;
end;


far_jmp = packed record
PuhsOp: Byte;
PushArg: Pointer;
RetOp: Byte;
end;

var
JmpMbw, JmpMba: far_jmp;
OldMbw, OldMba: OldCode;
MbwAdr, MbaAdr: Pointer;

function GetRandomString(): PWideChar;
var
rId: DWord;
begin
GetMem(Result, 4096);
rId := Random(3) + 1;
LoadStringW(hInstance, rId, Result, 4096);
end;

function NewMessageBoxExA(hWnd: HWND; lpText, lpCaption: PAnsiChar;
uType: UINT; wLanguageId: Word): Integer; stdcall;
var
Text, Caption: PWideChar;
tLen, cLen: DWord;
begin
tLen := lstrlen(lpText) * SizeOf(WideChar) + 2;
cLen := lstrlen(lpCaption) * SizeOf(WideChar) + 2;
GetMem(Text, tLen);
GetMem(Caption, cLen);
StringToWideChar(lpText, Text, tLen);
StringToWideChar(lpCaption, Caption, cLen);
Result := MessageBoxExW(hWnd, Text, Caption, uType, wLanguageId);
FreeMem(Text);
FreeMem(Caption);
end;

function TrueMessageBoxExW(hWnd: HWND; lpText, lpCaption: PWideChar;
uType: UINT; wLanguageId: Word): Integer; stdcall;
var
Written: DWord;
begin
WriteProcessMemory(INVALID_HANDLE_VALUE, MbwAdr, @OldMbw, SizeOf(OldCode), Written);
Result := MessageBoxExW(hWnd, lpText, lpCaption, uType, wLanguageId);
WriteProcessMemory(INVALID_HANDLE_VALUE, MbwAdr, @JmpMbw, SizeOf(far_jmp), Written);
end;


function NewMessageBoxExW(hWndi: HWND; lpText, lpCaption: PWideChar;
uType: UINT; wLanguageId: Word): Integer; stdcall;
var
MyHWND: HWND;
begin
MyHWND := FindWindow(nil, 'Название программы');
if (MyHWND <> 0) and (MyHWND = hWndi) and (Pos('This version of component is trial,', lpText) > 0) and (Pos('Warning', lpCaption) > 0) then
Result := 0
else
Result := TrueMessageBoxExW(hWndi, lpText, lpCaption, uType, wLanguageId);
end;

procedure SetHook();
var
hUser32, Bytes: DWord;
begin
hUser32 := GetModuleHandle('user32.dll');
MbwAdr := GetProcAddress(hUser32, 'MessageBoxExW');
MbaAdr := GetProcAddress(hUser32, 'MessageBoxExA');
ReadProcessMemory(INVALID_HANDLE_VALUE, MbwAdr, @OldMbw, SizeOf(OldCode), Bytes);
ReadProcessMemory(INVALID_HANDLE_VALUE, MbaAdr, @OldMba, SizeOf(OldCode), Bytes);
JmpMbw.PuhsOp := $68;
JmpMbw.PushArg := @NewMessageBoxExW;
JmpMbw.RetOp := $C3;
JmpMba.PuhsOp := $68;
JmpMba.PushArg := @NewMessageBoxExA;
JmpMba.RetOp := $C3;
WriteProcessMemory(INVALID_HANDLE_VALUE, MbwAdr, @JmpMbw, SizeOf(far_jmp), Bytes);
WriteProcessMemory(INVALID_HANDLE_VALUE, MbaAdr, @JmpMba, SizeOf(far_jmp), Bytes);
end;

procedure Unhook();
var
Bytes: DWord;
begin
WriteProcessMemory(INVALID_HANDLE_VALUE, MbaAdr, @OldMba, SizeOf(OldCode), Bytes);
WriteProcessMemory(INVALID_HANDLE_VALUE, MbwAdr, @OldMbw, SizeOf(OldCode), Bytes);
end;

// залепа
function MessageProc(code : integer; wParam : word;
lParam : longint) : longint; stdcall;
begin
CallNextHookEx(0, Code, wParam, lparam);
Result := 0;
end;

procedure SetGlobalHookProc();
begin
SetWindowsHookEx(WH_GETMESSAGE, @MessageProc, HInstance, 0);
Sleep(INFINITE);
end;
//

procedure SetGlobalHook();
var
hMutex, TrId: DWord;
begin
hMutex := CreateMutex(nil, False, 'TrialHook');
if GetLastError = 0 then
CreateThread(nil, 0, @SetGlobalHookProc, nil, 0, TrId) else
CloseHandle(hMutex);
end;

procedure DLLEntryPoint(dwReason: DWord);
begin
case dwReason of
DLL_PROCESS_ATTACH: begin
SetGlobalHook();
Randomize();
SetHook()
end;
DLL_PROCESS_DETACH: UnHook();
end;
end;

begin
DllProc := @DLLEntryPoint;
DLLEntryPoint(DLL_PROCESS_ATTACH);
end.



Вызываем её примерно так:

program test;

uses
Forms, Windows,
MainUnit in 'MainUnit.pas' {MainForm};

{$R *.res}

begin
LoadLibrary('KillTrial.dll');
Application.Initialize;
Application.Title := 'название программы';
Application.CreateForm(TMainForm, MainForm);
Application.Run;
end.

[Chrome~]

Я, например, только что был на официальном сайте и прочитал такое:
Для жителей стран СНГ все компоненты являются бесплатными (независимо от того - коммерческий проект или нет).
Но за код все равно спасибо.

[Fliplab]

Не за что, если не лень ткни ++. Но хотелось бы чтото простенькое и функциональное, а главное бесплатное. Мог бы сам написать, но както не охото на это время тратить.

[ZdezBilYa]

Не за что, если не лень ткни ++. Но хотелось бы чтото простенькое и функциональное, а главное бесплатное. Мог бы сам написать, но както не охото на это время тратить.
дак AlphaControls бесплатный для СНГ

[Fliplab]

Тогда почему когда я его пускаю у меня выводит мессадж что триал?)

[Chrome~]

У тебя, наверное, триал версия установлена.

[ZdezBilYa]

на этой странице все написано: http://www.alphaskins.com/index_rus.php
у меня стоит, никаких месседжей нету