VPF::Арсенал форумистов - Форум программистов

p0s0l

Дата 15.4.2004, 00:04 (ссылка)

(нет голосов)

Загрузка ...

Г-н Посол

Профиль
Группа: Экс. модератор
Сообщений: 3668
Регистрация: 13.7.2003
Где: 58°38' с.ш. 4 9°41' в.д.

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

Не раз уже встречал случаи, когда кто-нибудь хотел выложить какие-то свои наработки в Delphi: модули, исходники, компоненты, может еще что-то. Предлагалось создавать отдельный раздел, но пока не понятно, будет ли от этого толк. Пока что создаю эту тему. В дальнейшем же будет видно насчёт отдельного раздела исходников по тому, какая тут будет активность, и как к этому отнесётся Admin.

Единственное правило - в этой теме не флеймить, тут оставлять только краткое описание модулей и ссылки к ним.

Можно скинуть мне на мыло (кнопка E-Mail под моим постом) файл, и я его прикреплю к вашему сообщению при первой же возможности...

--------------------

С уважением, г-н Посол.

Girder

Дата 4.3.2006, 00:25 (ссылка)

(нет голосов)

Загрузка ...

Лентяй 2

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

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

Учимся работать с "многопоточными файлами" в NT.

За не большой теорией... обращаемся к топику smile

: http://forum.vingrad.ru/index.php?showtopic=85363

1. Создание(изменение) и чтение "Опциональных потоков"

Код

procedure TForm1.Button1Click(Sender: TObject);
begin
 //сохраняем то что в Memo в "многопоточный файл"
 Memo1.Lines.SaveToFile('k:\memo.txt');
 Memo2.Lines.SaveToFile('k:\memo.txt:memo2'); //опциональный поток
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
 //читаем в обратном порядке из "многопоточного файла"
 Memo1.Lines.LoadFromFile('k:\memo.txt:memo2'); //опциональный поток
 Memo2.Lines.LoadFromFile('k:\memo.txt');
end;

Как видно из первого примера... что бы прочитать "Опциональный поток" нам необходимо знать его "имя"... smile

. Если вам не известно енто "имя", а очень хочется... тогда код 2 пункта предназначен для вас smile

.

2. Определяем инфу о файле/директории - читаем инфу о потоках:
*** Не забудьте включить SE_BACKUP_NAME привелегию ***

Код

function InfoFileStreams(const FileName:String; Delete:Boolean; out RStreams:String):Boolean;
{Входные данные:
- FileName: Имя файла/дирректории.
- Delete: Если Truе то... по мимо инфы еще и удаляем "Опциональные потоки" файла.
Выходные данные:
- True: Что-то смоглы определить :)
- RStreams - Определенная инфа}
const Error_Buffer_Overflow=$80000005;
type
 _IO_STATUS_BLOCK=packed record
   Status:DWord;
   Information:DWord;
 end;
 FILE_STREAM_INFORMATION=packed record 
   NextEntry:DWord;
   NameLength:DWord;
   Size:Int64;
   AllocationSize:Int64;
   Name:WideChar;
 end;
 _FILE_INFORMATION_CLASS=(FileDirectoryInformation=1,FileFullDirectoryInformation,
                          FileBothDirectoryInformation,FileBasicInformation,
                          FileStandardInformation,FileInternalInformation,
                          FileEaInformation,FileAccessInformation,FileNameInformation,
                          FileRenameInformation,FileLinkInformation,FileNamesInformation,
                          FileDispositionInformation,FilePositionInformation,FileFullEaInformation,
                          FileModeInformation,FileAlignmentInformation,FileAllInformation,
                          FileAllocationInformation,FileEndOfFileInformation,FileAlternateNameInformation,
                          FileStreamInformation,FilePipeInformation,FilePipeLocalInformation,
                          FilePipeRemoteInformation,FileMailslotQueryInformation,FileMailslotSetInformation,
                          FileCompressionInformation,FileObjectIdInformation,FileCompletionInformation,
                          FileMoveClusterInformation,FileQuotaInformation,FileReparsePointInformation,
                          FileNetworkOpenInformation,FileAttributeTagInformation,FileTrackingInformation,
                          FileMaximumInformation);
var NtQueryInformationFile: function (FileHandle:DWord; out IoStatusBlock: _IO_STATUS_BLOCK; FileInformation:Pointer; Length:DWord; FileInformationClass:_FILE_INFORMATION_CLASS):DWord; stdcall;
    fHandle:DWord;
    StreamIS:DWord;
    StreamInfo,tSI:^FILE_STREAM_INFORMATION;
    IoSB:_IO_STATUS_BLOCK;
    t:DWord;
    sN,sT:String;
    NextEntry,sM:Boolean;
begin
 Result:=false;
 NtQueryInformationFile:=GetProcAddress(GetModuleHandle('ntdll.dll'),'NtQueryInformationFile');
 if Assigned(NtQueryInformationFile)=false then exit;
 fHandle:=CreateFile(PChar(FileName),GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE,nil,
                     OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
 if fHandle<>INVALID_HANDLE_VALUE then
  begin
   StreamIS:=0;
   GetMem(StreamInfo,StreamIS);
   repeat
    FreeMem(StreamInfo,StreamIS);
    StreamIS:=StreamIS+16384;
    GetMem(StreamInfo,StreamIS);
    t:=NtQueryInformationFile(fHandle,IoSB,StreamInfo,StreamIS,FileStreamInformation);
   until (t<>Error_Buffer_Overflow);
   if (t=0)and(IoSB.Information<>0) then
    begin
     tSI:=StreamInfo;
     sN:='';
     NextEntry:=True;
     Result:=true;
     sM:=false;
     while NextEntry do
      begin
       if tSI^.NextEntry=0 then NextEntry:=false;
       sT:=Copy(PWideChar(@tSI^.Name),0,tSI^.NameLength div SizeOf(WideChar));
       if (sM=false)and(AnsiCompareText(sT,'::$DATA')=0) then
        begin
         sM:=true;
         sN:=sN+'Основной поток: '+sT+'; Размер: '+IntToStr(tSI^.Size)+' байт'+chr($D)+chr($A);
        end else
        begin
         sN:=sN+'Опциональный поток: '+sT+'; Размер: '+IntToStr(tSI^.Size)+' байт'+chr($D)+chr($A);
         if Delete then
          if DeleteFile(FileName+sT) then sN:=sN+'Удален!'+chr($D)+chr($A);
        end;
       tSI:=Pointer(DWord(tSI)+tSI^.NextEntry);
      end;
     RStreams:=sN;
    end;
   FreeMem(StreamInfo,StreamIS);
   CloseHandle(fHandle);
  end;
end;

Ну и до кучи... пример использывания InfoFileStreams:

Код


const
  SE_BACKUP_NAME = 'SeBackupPrivilege';

function NTSetPrivilege(sPrivilege:string;fEnabled:LongBool):boolean;
var hToken:THandle;
    TokenPriv,PrevTokenPriv:TOKEN_PRIVILEGES;
    PrivSet:PRIVILEGE_SET;
    f:LongBool;
    i:Cardinal;
begin
 Result:=false;
 if Win32Platform<>VER_PLATFORM_WIN32_NT then exit;
 PrivSet.PrivilegeCount:=1;
 PrivSet.Control:=0;
 PrivSet.Privilege[0].Attributes:=0;
 if LookupPrivilegeValue(nil,PChar(sPrivilege),PrivSet.Privilege[0].Luid) then
  if OpenProcessToken(GetCurrentProcess(),TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY,hToken) then
   begin
    try
     if PrivilegeCheck(hToken,PrivSet,f)and(f<>fEnabled) then
      if LookupPrivilegeValue(nil,PChar(sPrivilege),TokenPriv.Privileges[0].Luid) then
       begin
        TokenPriv.PrivilegeCount:=1;
        if fEnabled then TokenPriv.Privileges[0].Attributes:=SE_PRIVILEGE_ENABLED else
         TokenPriv.Privileges[0].Attributes:=0;
        i:=0;
        PrevTokenPriv:=TokenPriv;
        AdjustTokenPrivileges(hToken,false,TokenPriv,SizeOf(PrevTokenPriv),PrevTokenPriv,i);
        Result:=GetLastError=ERROR_SUCCESS;
       end;
    except
    end;
    CloseHandle(hToken);
   end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var s:string;
begin
 NTSetPrivilege(SE_BACKUP_NAME,true);
 if InfoFileStreams('k:\memo.txt',false,s) then Memo1.Lines.Text:=s;
 //Удаляем опциональные потоки
 //if InfoFileStreams('k:\memo.txt',true,s) then Memo1.Lines.Text:=s;
end;

Удачи.

--------------------

Как слышим, так и пишим.
Истина где-то там...

former

Дата 27.3.2006, 20:05 (ссылка)

(нет голосов)

Загрузка ...

MEMS Expert

Профиль
Группа: Завсегдатай
Сообщений: 1166
Регистрация: 1.3.2006
Где: Россия

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

Народ, ранее в этом разделе публиковалась ссылка на SoftUtl.zip. Сейчас она не работает. Если у кого есть и не жалко, дайте ссылку или киньте на мыло.

--------------------

Достаточно снизить уровень мышления, чтобы иные почувствовали почву под ногами.

Guedda

Дата 28.3.2006, 19:30 (ссылка)

(нет голосов)

Загрузка ...

Подрывник

Профиль
Группа: Завсегдатай
Сообщений: 3137
Регистрация: 27.12.2005
Где: Ростов-на-Дону

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

Вот мой модуль для работы с Ini файлами... Должен всем пригодиться...
MyIni.pas:

Код


//Модуль для работы с данными в конфигурационном файле.
//Функции упрощают использование конфиг. файлов.
//Данный материал можно изменять по Вашему усмотрению...
//При нахождении ошибкок пишите на [email protected]
unit MyIni.pas

interface

uses
  IniFiles;

procedure WriteIniData(Section, Ident, Value : string);
procedure WriteIniDataInt(Section, Ident : string; Value : Integer);
procedure WriteIniDataBool(Section, Ident : string; Value : boolean);
function ReadIniData(Section, Ident : string; Default : string = '') : string;
function ReadIniDataInt(Section, Ident : string; Default : Integer = 0) : Integer;
function ReadIniDataBool(Section, Ident : string; Default : boolean = false) : boolean;

implementation

var
  IniFile : TIniFile;
  Path : string;

procedure WriteIniData(Section, Ident, Value : string);
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  IniFile.WriteString(Section, Ident, Value);
  IniFile.Free;
end;

procedure WriteIniDataInt(Section, Ident : string; Value : Integer);
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  IniFile.WriteInteger(Section, Ident, Value);
  IniFile.Free;
end;

procedure WriteIniDataBool(Section, Ident : string; Value : boolean);
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  IniFile.WriteBool(Section, Ident, Value);
  IniFile.Free;
end;

function ReadIniData(Section, Ident : string; Default : string = '') : string;
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  Result := IniFile.ReadString(Section, Ident, Default);
  IniFile.Free;
end;

function ReadIniDataInt(Section, Ident : string; Default : Integer = 0) : Integer;
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  Result := IniFile.ReadInteger(Section, Ident, Default);
  IniFile.Free;
end;

function ReadIniDataBool(Section, Ident : string; Default : boolean = false) : boolean;
begin
  IniFile := TIniFile.Create(Path + '\config.ini');
  Result := IniFile.ReadBool(Section, Ident, Default);
  IniFile.Free;
end;

initialization
  GetDir(0, Path);

end.

--------------------

Ll 2

Rrader

Дата 29.3.2006, 03:15 (ссылка)

(нет голосов)

Загрузка ...

Inspired =)

Профиль
Группа: Экс. модератор
Сообщений: 1535
Регистрация: 7.5.2005

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

А вот мой, ещё проще:

Код


Unit USDKINIFiles;

{ From Windows Messages SDK }

Interface

Uses Windows, SysUtils;

Type
  TINIFile = Class(TObject)
  Private
    FFileName: String;
  Public
    Constructor Create(Const FileName : String);
    Destructor Destroy; Override;
    Function ReadString(Const Section, Key, Default: String): String;
    Function ReadInteger(Const Section, Key: String;
      Default: Longint): Longint;
    Function ReadBool(Const Section, Key: String; Default: Boolean): Boolean;
    Function WriteString(Const Section, Key, Value: String): Boolean;
    Function WriteInteger(Const Section, Key: String;
      Value: Longint): Boolean;
    Function WriteBool(Const Section, Key: String; Value: Boolean): Boolean;
    Procedure UpdateFile;
    Property FileName: String Read FFileName;
  End;

Implementation

{ TINIFile }

Constructor TIniFile.Create(Const FileName: String);
Begin
  FFileName := FileName;
End;

Destructor TIniFile.Destroy;
Begin
  UpdateFile;
  Inherited Destroy;
End;

Function TIniFile.ReadBool(Const Section, Key: String;
  Default: Boolean): Boolean;
Begin
  Result := ReadInteger(Section, Key, Ord(Default)) <> 0;
End;

Function TIniFile.ReadInteger(Const Section, Key: String;
  Default: Integer): Longint;
Var
  IntStr: String;
Begin
  IntStr := ReadString(Section, Key, '');
  If (Length(IntStr) > 2) And (IntStr[1] = '0') And
     ((IntStr[2] = 'X') Or (IntStr[2] = 'x')) Then
    IntStr := '$' + Copy(IntStr, 3, MaxInt);
  Result := StrToIntDef(IntStr, Default);
End;

Function TIniFile.ReadString(Const Section, Key, Default: String): String;
Var
  Buffer: Array[0..2047] Of Char;
Begin
  SetString(Result, Buffer, GetPrivateProfileString(PChar(Section),
    PChar(Key), PChar(Default), Buffer, SizeOf(Buffer), PChar(FFileName)));
End;

Procedure TIniFile.UpdateFile;
Begin
  WritePrivateProfileString(NIL, NIL, NIL, PChar(FFileName));
End;

Function TIniFile.WriteBool(Const Section, Key: String;
  Value: Boolean): Boolean;
Const
  Values: Array[Boolean] Of String = ('0', '1');
Begin
  Result := WriteString(Section, Key, Values[Value]);
End;

Function TIniFile.WriteInteger(Const Section, Key: String;
  Value: Integer): Boolean;
Begin
  Result := WriteString(Section, Key, IntToStr(Value));
End;

Function TIniFile.WriteString(Const Section, Key, Value: String): Boolean;
Begin
  Result := WritePrivateProfileString(PChar(Section), PChar(Key),
    PChar(Value), PChar(FFileName));
End;

End.

Guedda, Try-Finally не видно... smile

Это сообщение отредактировал(а) Rrader - 24.6.2006, 12:01

--------------------

Let's do this quickly!
Rest in peace, Vit!

Guedda

Дата 29.3.2006, 12:17 (ссылка)

(нет голосов)

Загрузка ...

Подрывник

Профиль
Группа: Завсегдатай
Сообщений: 3137
Регистрация: 27.12.2005
Где: Ростов-на-Дону

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

Да по-моему это обрезанный класс TIniFile...

--------------------

Ll 2

Sh@dow

Дата 6.4.2006, 13:36 (ссылка)

(нет голосов)

Загрузка ...

Новичок

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

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

Хотел бы поделиться некоторыми наработками под MS SQL. Так как в разделе баз данных подобного раздела нет выкладываю сюда. Может кому и пригодяться. На авторство не претендую smile

Код


-- Возвращает строку в DOS кодировке 
-- dbo.WIN_DOS_STRING(expression)
--    expression - строка в WIN кодировке
CREATE FUNCTION dbo.WIN_DOS_STRING
(
  @ws VARCHAR(8000)    -- строка
)
RETURNS VARCHAR(8000)
AS  
BEGIN
    DECLARE    @ss        int,                -- счетчик
                @ds        varchar(8000),    -- DOS строка
                @ls        int,                -- длина обр. строки
                @os        int                -- код 1-го обраб-го символа
    SET @ds=''
    SET @ls=LEN(@ws)
    SET @ss=0
    WHILE @ss<@ls
    BEGIN
        SET @os=ASCII(SUBSTRING(@ws,1,1))
        SET @ds=@ds+CASE
            WHEN @os>=192 AND @os<=239 THEN  CHAR(@os-64)-- 128.180
            WHEN @os>=240 AND @os<=256 THEN  CHAR(@os-16)-- 224.239
            WHEN @os=168 THEN  CHAR(240) --Ё
            WHEN @os=184 THEN  CHAR(241) --ё
            ELSE CHAR(@os)
        END                        
        SET @ss=@ss+1
        SET @ws=SUBSTRING(@ws,2,LEN(@ws)-1)
    END
    RETURN @ds
END

Код


/*
перекодировка символа Widows в code128
*/
CREATE FUNCTION dbo.Win2code128
(@winchar as varchar(1))
RETURNS int
 AS  
BEGIN 

DECLARE @code as int
DECLARE @T TABLE( a int, b VARCHAR(1) )

insert into @T
select 0 a,' ' b
union all
select 1 a,'!' b
union all
select 2 a,'"' b
union all
select 3 a,'#' b
union all
select 4 a,'$' b
union all
select 5 a,'%' b
union all
select 6 a,'&' b
union all
select 7 a,'''' b
union all
select 8 a,'(' b
union all
select 9 a,')' b
union all
select 10 a,'*' b
union all
select 11 a,'+' b
union all
select 12 a,',' b
union all
select 13 a,'-' b
union all
select 14 a,'.' b
union all
select 15 a,'/' b
union all
select 16 a,'0' b
union all
select 17 a,'1' b
union all
select 18 a,'2' b
union all
select 19 a,'3' b
union all
select 20 a,'4' b
union all
select 21 a,'5' b
union all
select 22 a,'6' b
union all
select 23 a,'7' b
union all
select 24 a,'8' b
union all
select 25 a,'9' b
union all
select 26 a,':' b
union all
select 27 a,';' b
union all
select 28 a,'<' b
union all
select 29 a,'=' b
union all
select 30 a,'>' b
union all
select 31 a,'?' b
union all
select 32 a,'@' b
union all
select 33 a,'A' b
union all
select 34 a,'B' b
union all
select 35 a,'C' b
union all
select 36 a,'D' b
union all
select 37 a,'E' b
union all
select 38 a,'F' b
union all
select 39 a,'G' b
union all
select 40 a,'H' b
union all
select 41 a,'I' b
union all
select 42 a,'J' b
union all
select 43 a,'K' b
union all
select 44 a,'L' b
union all
select 45 a,'M' b
union all
select 46 a,'N' b
union all
select 47 a,'O' b
union all
select 48 a,'P' b
union all
select 49 a,'Q' b
union all
select 50 a,'R' b
union all
select 51 a,'S' b
union all
select 52 a,'T' b
union all
select 53 a,'U' b
union all
select 54 a,'V' b
union all
select 55 a,'W' b
union all
select 56 a,'X' b
union all
select 57 a,'Y' b
union all
select 58 a,'Z' b
union all
select 59 a,'[' b
union all
select 60 a,'\' b
union all
select 61 a,']' b
union all
select 62 a,'^' b
union all
select 63 a,'_' b
union all
select 64 a,'`' b
union all
select 65 a,'a' b
union all
select 66 a,'b' b
union all
select 67 a,'c' b
union all
select 68 a,'d' b
union all
select 69 a,'e' b
union all
select 70 a,'f' b
union all
select 71 a,'g' b
union all
select 72 a,'h' b
union all
select 73 a,'i' b
union all
select 74 a,'j' b
union all
select 75 a,'k' b
union all
select 76 a,'l' b
union all
select 77 a,'m' b
union all
select 78 a,'n' b
union all
select 79 a,'o' b
union all
select 80 a,'p' b
union all
select 81 a,'q' b
union all
select 82 a,'r' b
union all
select 83 a,'s' b
union all
select 84 a,'t' b
union all
select 85 a,'u' b
union all
select 86 a,'v' b
union all
select 87 a,'w' b
union all
select 88 a,'x' b
union all
select 89 a,'y' b
union all
select 90 a,'z' b
union all
select 91 a,'{' b
union all
select 92 a,'|' b
union all
select 93 a,'}' b
union all
select 94 a,'~' b
union all
select 95 a,char(161) b
union all
select 96 a,char(162) b
union all
select 97 a,char(163) b
union all
select 98 a,char(164) b
union all
select 99 a,char(165) b
union all
select 100 a,char(166) b
union all
select 101 a,char(167) b
union all
select 102 a,char(168) b
union all
select 103 a,char(169) b
union all
select 104 a,char(170) b
union all
select 105 a,char(171) b
union all
select 106 a,char(172) b

select @code=a
from @T
where ascii(b)=ascii(@winchar)

set @code=isnull(@code,0)

return (@code)

END

Код


/*возвращает строку для формирования штрихкода со стартовыми, стоповыми символами и контрольной суммой по кодировке code128 подсистемы B на входе строка, состоящая из цифр (если какой-то другой символ, то он обрабатывается как 0) */

CREATE FUNCTION dbo.getcode128
(@string as varchar(50) )
RETURNS varchar(50)
 AS  
BEGIN 

DECLARE @position int, @stringnew varchar(50), @sum int, @codestart int, @codestop int
SET @position = 1
SET @stringnew = ''
set @codestart=104
set @codestop=106
set @sum=@codestart

WHILE @position <= DATALENGTH(@string)
   BEGIN
   SELECT @stringnew=@stringnew+SUBSTRING(@string, @position, 1), 
          @sum=@sum+@position*
          (case when SUBSTRING(@string, @position, 1)='1' then 17 else
          case when SUBSTRING(@string, @position, 1)='2' then 18 else
          case when SUBSTRING(@string, @position, 1)='3' then 19 else
          case when SUBSTRING(@string, @position, 1)='4' then 20 else
          case when SUBSTRING(@string, @position, 1)='5' then 21 else
          case when SUBSTRING(@string, @position, 1)='6' then 22 else
          case when SUBSTRING(@string, @position, 1)='7' then 23 else
          case when SUBSTRING(@string, @position, 1)='8' then 24 else
          case when SUBSTRING(@string, @position, 1)='9' then 25 else
          16
          end
          end
          end
          end
          end
          end
          end
          end
          end)
   SET @position = @position + 1
   END

set @stringnew=dbo.code128toWin(@codestart)+@stringnew+dbo.code128toWin(@sum-@sum/103*103)+dbo.code128toWin(@codestop)

return (@stringnew)

END

Код


/* Функция переводит число в строковое выражение числа с запятой, которое понимает Ёксель
*P* 15.11.02  */

CREATE FUNCTION Float2Str
(@val as float )
RETURNS varchar(24)
 AS  
BEGIN 

declare @s as varchar(24)
set @s=str(@val,21,2)
return stuff(@s,len(@s)-2,1,',')

END

Код


-- Возвращает строку в WIN кодировке, на базе WIN_DOS_String()
-- dbo.DOS_WIN_STRING(expression)
--    expression - строка в DOS кодировке
CREATE FUNCTION dbo.DOS_WIN_STRING
(
  @ds VARCHAR(8000)    -- строка в DOS кодировке
)
RETURNS VARCHAR(8000)
AS  
BEGIN
    DECLARE    @ss        int,        -- счетчик
            @ws        varchar(8000),    -- WIN строка
            @ls        int,        -- длина обр. строки
            @os        int        -- код 1-го обраб-го символа
    SET @ws=''
    SET @ls=LEN(@ds)
    SET @ss=0
    WHILE @ss<@ls
    BEGIN
        SET @os=ASCII(SUBSTRING(@ds,1,1))
        SET @ws=@ws+CASE
            WHEN @os>=128 AND @os<=180 THEN  CHAR(@os+64)-- 192.239
            WHEN @os>=224 AND @os<=239 THEN  CHAR(@os+16)-- 240.256
            WHEN @os=240 THEN  CHAR(168) --Ё
            WHEN @os=241 THEN  CHAR(184) --ё
            ELSE CHAR(@os)

    END                        
        SET @ss=@ss+1
        SET @ds=SUBSTRING(@ds,2,LEN(@ds)-1)
    END
    RETURN @ws
END

Код


CREATE FUNCTION [dbo].[CalcDate] 
 (
  @date datetime, --исходная дата
  @Month int,  -- кол-во месяцев добавить (отриц. - вычесть)
  @Begin bit  -- 0 - получить кон. дату месяца, 1-получить нач. дату месяца
 )  
RETURNS datetime AS  
BEGIN 
  declare @d datetime
  set @d = DateAdd(m, @Month, @date)
  if (@Begin=0)
  begin
    set @d = DateAdd( m , 1, @d)
    set @d = DateAdd(day,  -(day(@d) ) , @d  )
  end
  else
    set @d = DateAdd(day, -(day(@d)-1) , @d )
  Return( @d )
 
END

Код


-- Возвращает строку дополненную с начала заданным символом до нужной длины
-- dbo.LONGSTRING(expression , symbol , length )
--    expression - дополняемая строка
--    symbol - символ для дополнения
--    length - длина возвращаемой строки. Если длина меньше длины expression
--                    expression урезается до заданной длины
-- Примеры: dbo.LONGSTRING('4','0',3) 
--            Результат: 004
--    dbo.LONGSTRING('123456789','0',4) 
--            Результат: 6789        
CREATE FUNCTION dbo.BLONGSTRING
(
  @bs NVARCHAR(4000),
  @sim NVARCHAR(4000),
  @long INT
)
RETURNS NVARCHAR(4000)
AS  
BEGIN
    DECLARE @lnst nvarchar(4000)
    SET @bs=LTRIM(RTRIM(@bs))
    SET @lnst=REVERSE(SUBSTRING(REVERSE(REPLICATE(@sim, @long)+@bs),1,@long))
    RETURN @lnst
END

Дата 29.4.2006, 19:34 (ссылка)

(голосов:1)

Загрузка ...

Брутальный буратина

Профиль
Группа: Участник Клуба
Сообщений: 3497
Регистрация: 31.3.2002
Где: Лес

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

совмещённые, между собой:
ToolBar2000 v2.1.7 и TBX v2.2

http://g32.org и http://www.jrsoftware.org

Скачать

TP@MB@Y

Дата 12.5.2006, 22:06 (ссылка)

(нет голосов)

Загрузка ...

Опытный

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

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

Как-то мне пришлось для удобства написать эту функцию. Но она настолько полезна, что я ее пользую во многих своих проектах. Сорри если такое уже было.

Код


//Функция возвращающая N-ое слово в строке
//Если N=0, то функция возвращает подстоку начиная с первого разделителя
function GetWord(str:string;n:word;sep:char):string;
var i,space,l,j:integer;
    buf:string;
begin
 l:=length(str);
 if n=0 then begin  //особый параметр
              j:=pos(GetWord(str,2,sep),str);
              GetWord:=copy(str,j,l-j+1);
              exit
             end;
 space:=0;
 i:=0;
 while (space<>(n-1))and(i<=l) do
  begin
   i:=i+1;
   if str[i]=sep then space:=space+1
  end;
 i:=i+1;
 buf:='';
 while (i<=l)and(str[i]<>sep) do
  begin
   buf:=buf+str[i];
   i:=i+1
  end;
 GetWord:=buf;
end;

Если кто не понял, то функция возвращает n-ое слово из строки str, считая за разделитель символ sep

Надеюсь комунибуть пригодится! smile

Sansei

Дата 14.5.2006, 18:13 (ссылка)

(нет голосов)

Загрузка ...

Новичок

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

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

Начинающие системные программисты всегда ощущают дискомфорт и профессиональную неполноценность при отсутствии крайне необходимого им системного драйвера для чтения записи портов и MSR-регистров. Как же быть, когда знаний порой не достаточно, а времени на изучение тонкостей написания драйверов не хватает, а порой и не возникает? В этом случае есть два выхода. Найти в Интернете бесплатный либо позаимствовать уже готовый полноценный драйвер. Первый, как правило, обеспечивает только чтение и запись портов ввода-вывода, чего естественно недостаточно. Второй зачастую стоит больших денег, что естественно нас не устраивает. Поэтому мы попробуем найти простенькую бесплатную программу, драйвер которой сделает нас полноценными системными программистами.

Я не стал обременять себя поиском необходимой программы, а сразу обратился на один попсовый среди оверклокеров рунета форум. Программа, по сути, ничем не примечательна и актуальностью не выделяется, чего не скажешь о её авторе. По сути, очередной банальный идентификатор CPU, самопально написанный на презренном многими программистами Delphi 7.0. Скачав последнюю бета версию 1.0, я приступил к её изучению.

Для начала, я загрузил программу в известный PE-редактор PE Explorer 1.96 с целью анализа прилинкованных к EXE-файлу ресурсов, среди которых мог обнаружится сам драйвер. Как я и ожидал, драйвер быстро обнаружился в секции RC Data под именем OSCI_DRVNT. Сохраняем драйвер в виде sys-файла на диск выбором команды контекстного меню Save Resource As…. В последующем он понадобился для компиляции в файл ресурсов и, как результат, подключения готового Res-файла к тестовому Delphi-приложению директивой {$R driver.res}.

Следующий этап заключается в поиске необходимых нам так называемых IOCTL-кодов, через которые происходит обращение приложения к драйверу. По сути, это команды, в ответ на которые драйвер выполняет ту или иную функцию, например читает порт или перезаписывает MSR-регистр процессора. В итоге, драйвер возвращает результат выполненной функции приложению. Для поиска IOCTL-кодов я прибегнул к встроенному дизассемблеру программы PE Explorer. Данный дизассемблер хорошо подходит для программ, скомпилированных на Delphi и предоставляет код ассемблера в удобном для изучения виде.

Дизассемблировав EXE-файл, нажатием Ctrl+F вводим запрос IOCTL. Естественно, первая попытка найти соответствие символьной константы необходимому IOCTL-коду неудачна, поэтому двигаем поиск дальше нажатием клавиши F3. И вот она удача! Полный перечень IOCTL-кодов обнаружился!

user posted image

Итак, видим, что для того, чтобы считать данные MSR-регистра необходимо обратиться к драйверу с IOCTL-кодом IOCTL_READ_MSR, числовое значение в hex-формате которого равно 9C402604h. Драйвер понимает и множество других IOCTL-кодов, смысл которых нам раскрывают интуитивно понятные имена символьных констант. Прекрасно понимая, что автор программы – полный «лом» в написании драйверов, всё-таки не могу не упрекнуть его за такое упущение!

Финальный шаг состоит в определении названия функции, с помощью которой приложение отправляет драйверу IOCTL-код. Их две: DeviceIoControl и WriteFile. Учитывая, что первая функция применяется гораздо чаще и является, по сути, классической в данной случае, с её поиска мы и начнем.

Поднимаемся в самое начало дизассемблированного кода, и начинаем поиск по критерию IOCTL_READ_MSR. Первый найденный результат доказывает, что для обращения к драйверу применяется классическая функция DeviceIoControl – сместившись на 20 строчек по коду выше обнаруживаем вызов данной функции из библиотеки kernel32.dll!

Теперь, когда мы знаем все IOCTL-коды и название применяемой функции мы можем приступить к написанию тестового приложения, полный рабочий пример которого можно взять здесь. Я не буду комментировать его т.к., а я лично одобряю позицию, о которой говорил в самом начале этой статьи: не нужно постигать то, в чем мы не заинтересованы, нам важен конечный результат. Тестовое приложение реализует одним модулем необходимый набор функций для начинающего системного программиста, а именно: чтение/запись портов и MSR-регистров процессора.

Для вашего приложения понадобится лишь прилагаемый к архиву модуль PortIO.pas и сам драйвер в виде ресурса driver.res. Инсталляцию и инициализацию драйвера берет на себя модуль.

В завершении этой статьи я хотел бы акцентировать ваше внимание на том, что моя статья опубликована исключительно в образовательных целях и не носит какой-либо противозаконный характер! Удачи!

Это сообщение отредактировал(а) Sansei - 14.5.2006, 18:19

Присоединённый файл ( Кол-во скачиваний: 104 )

oscidrv.zip 17,14 Kb

Budy

Дата 9.6.2006, 20:32 (ссылка)

(нет голосов)

Загрузка ...

Опытный

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

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

Два компонента esNumLabel и esTextLabel. Ложатся в палитру Standart.
Оба компонента предназначены для необычного вывода соответственно чисел и строк.
1) Готовый BPL. Ссылка http://frombudy.narod.ru/upload/delphi/esComponent.rar.
Как установить? Заходим в меню "Component/Install packeges...", жмем "Add..." и указываем распакованный BPL.
2) Исходники. Ссылка http://frombudy.narod.ru/upload/delphi/esComponent_units.rar

Немного о компонентах:
•Размер выравнивается самостоятельно, изменение Width и Height ни к чему не привидет.
•Есть возможность использовать свой стиль символов.
•esNumLabel: обратите внимание на следующие property: Number, NumberImage, NumberShow, Transparent.
•esTextLabel: обратите внимание на следующие property: Caption, TextImage, Transparent.
•При написании компонентов использовал класс TGraphicControl.
•Предупреждаю: Использовать, изменять и распространять данные ресурсы разрешаю.

Ресурсы создал от нечего делать, да и попрактиковался немного smile

Кстати, буду рад выслушать все ваши комментарии в мой адрес, пожалуйста пользуемся Личными сообщениями или почтой mailto:[email protected].

С уважением, Budy.

--------------------

Как ты назовешь свой корабль, так на нем и напишут
user posted image

Angel_19

Дата 31.7.2006, 23:45 (ссылка)

(нет голосов)

Загрузка ...

Шустрый

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

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

Кто нибудь юзал исходники Sansei? Я попробовал, у меня чт-то они глючат...

Rouse_

Дата 11.8.2006, 18:09 (ссылка)

(нет голосов)

Загрузка ...

Опытный

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

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

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

Небольшая полезность: PEDump Shell Extension
Ссылка: http://rouse.front.ru/propsheet.zip а также в прикрепленке
Размер: 139 600 байт
В архиве, помимо исходников сама утилита.

Выглядит данная утилита вот так: user posted image

Что из себя представляет:
Выводит список импорта - экспорта выбранного РЕ файла на закладке свойств файла. Собственно, помимо демо получения самих списков импорта/экспорта показывает работу с IShellPropSheetExt, при помощи которого реализуется сама закладка, есть работа с активизацией контекста манифеста (интересно будет тем, кто работает с диалогами под ХР), в качестве вкусностей - юнит с реализацией функций ImageRvaToVa и ImageDirectoryEntryToData.

Надеюсь данная работа будет вам интересна.

Помимо этого обновил сайт примером работы с корзиной, впрочем не маленькие, сами разберетесь: http://rouse.front.ru/

smile

Всем удачных выходных.

Присоединённый файл ( Кол-во скачиваний: 153 )

propsheet.zip 136,33 Kb

--------------------

Vae Victis
(Горе побежденным (лат.))
Демо с открытым кодом: http://rouse.drkb.ru

ctulhu

Дата 11.2.2007, 09:16 (ссылка)

(нет голосов)

Загрузка ...

Новичок

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

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

Модуль для работы с файловой системой на ООП-основе.

  - класс для работы с директориями
  - класс для работы с содержимым директорий
  - возможность работы с текстовыми файлами

Присоединённый файл ( Кол-во скачиваний: 117 )

FileSystem.pas 14,75 Kb

Alexeyt

Дата 26.2.2007, 20:00 (ссылка)

(нет голосов)

Загрузка ...

Опытный

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

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

//Раз народ выкладывает свои реализации работы с ini файлами, выложу я:

Модуль работы с реестром - быстрый, на одном API. Никаких классов. Чтение/запись строки/числа/binary. Есть поддержка юникода в более новой версии, кому нужно - пишите.

Код


// RegProc.pas - simple Registry reading/writing
// Written by Alexey Torgashin, thanks to Eugene Roshal

unit RegProc;

interface

uses Windows;

procedure SetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: string);
procedure SetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: DWORD);
procedure SetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; const DataPtr: pointer; DataSize: DWORD);
function GetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: string): string;
function GetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: DWORD): DWORD;
function GetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; var DataPtr: pointer; var DataSize: DWORD): boolean;
     
implementation

function CreateRegKey(RootKey: HKEY; SubKey: PChar): HKEY;
var
  Disposition: DWORD;
begin
  if RegCreateKeyEx(RootKey, SubKey, 0, nil,
                    REG_OPTION_NON_VOLATILE, KEY_WRITE, nil,
                    Result, @Disposition)<>ERROR_SUCCESS
    then Result:= 0;
end;

function OpenRegKey(RootKey: HKEY; SubKey: PChar): HKEY;
begin
  if RegOpenKeyEx(RootKey, SubKey, 0, KEY_QUERY_VALUE, Result)<>ERROR_SUCCESS
    then Result:= 0;
end;

procedure SetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: string);
var
  h: HKEY;
begin
  h:= CreateRegKey(RootKey, SubKey);
  RegSetValueEx(h, Name, 0, REG_SZ, PChar(Value), Length(Value)+1);
  RegCloseKey(h);
end;

procedure SetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Value: DWORD);
var
  h: HKEY;
begin
  h:= CreateRegKey(RootKey, SubKey);
  RegSetValueEx(h, Name, 0, REG_DWORD, @Value, SizeOf(DWORD));
  RegCloseKey(h);
end;

procedure SetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; const DataPtr: pointer; DataSize: DWORD);
var
  h: HKEY;
begin
  h:= CreateRegKey(RootKey, SubKey);
  RegSetValueEx(h, Name, 0, REG_BINARY, DataPtr, DataSize);
  RegCloseKey(h);
end;

function GetRegKeyStr(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: string): string;
var
  h: HKEY;
  Buffer: PChar;
  DataType, DataSize: DWORD;
begin
  Result:= Default;
  h:= OpenRegKey(RootKey, SubKey);
  if (RegQueryValueEx(h, Name, nil, @DataType, nil, @DataSize)<>ERROR_SUCCESS)
    or (DataType<>REG_SZ) then
    begin RegCloseKey(h); Exit end;

  GetMem(Buffer, DataSize);
  if (RegQueryValueEx(h, Name, nil, @DataType, PByte(Buffer), @DataSize)<>ERROR_SUCCESS)
    or (DataType<>REG_SZ) then
    begin RegCloseKey(h); Exit end;

  Result:= Buffer;
  FreeMem(Buffer, DataSize);
  RegCloseKey(h);
end;

function GetRegKeyInt(RootKey: HKEY; SubKey: PChar; Name: PChar; const Default: DWORD): DWORD;
var
  h: HKEY;
  DataType, DataSize: DWORD;
begin
  DataSize:= SizeOf(DWORD);
  h:= OpenRegKey(RootKey, SubKey);
  if (RegQueryValueEx(h, Name, nil, @DataType, PByte(@Result), @DataSize)<>ERROR_SUCCESS)
    or (DataType<>REG_DWORD)
    then Result:= Default;
  RegCloseKey(h);
end;

function GetRegKeyBin(RootKey: HKEY; SubKey: PChar; Name: PChar; var DataPtr: pointer; var DataSize: DWORD): boolean;
var
  h: HKEY;
  DataType: DWORD;
begin
  h:= OpenRegKey(RootKey, SubKey);
  Result:= (RegQueryValueEx(h, Name, nil, @DataType, PByte(DataPtr), @DataSize)=ERROR_SUCCESS)
    and (DataType=REG_BINARY);
  if not Result then
    begin DataPtr:= nil; DataSize:= 0 end;
  RegCloseKey(h);
end;

end.

Alexeyt

Дата 26.2.2007, 20:47 (ссылка)

(нет голосов)

Загрузка ...

Опытный

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

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

Юнит для работы с Directory Junctions под Win2000/XP+. Чтение директории назначения + создание/удаление junctions. Плюс консольная утилита, на основе этого юнита, которая создает junctions из командной строки.

Это сообщение отредактировал(а) Alexeyt - 1.3.2007, 21:45

Присоединённый файл ( Кол-во скачиваний: 42 )

Junc.zip 32,70 Kb

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