Delphi заготовки

uses  ShlObj,ActiveX;


.....

function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
begin
  if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then
    SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);
  result := 0;
end;

function SelectDirectory(const Caption: string; const Root: WideString;
  var Directory: string): Boolean;
  const
 BIF_USENEWUI = $0040;
 BIF_NOCREATEDIRS = $0200;
var
  WindowList: Pointer;
  BrowseInfo: TBrowseInfo;
  Buffer: PChar;
  OldErrorMode: Cardinal;
  RootItemIDList, ItemIDList: PItemIDList;
  ShellMalloc: IMalloc;
  IDesktopFolder: IShellFolder;
  Eaten, Flags: LongWord;
begin
  Result := False;
  if not DirectoryExists(Directory) ... Читать дальше »

Получить имя файла без разришения

 function ExtractOnlyFileName(const FileName: string): string;
 begin
   result:=StringReplace(ExtractFileName(FileName),ExtractFileExt(FileName),'',[]);
 end;



дополнительно с сайта 
http://www.delphibasics.ru/ExtractFileName.php
... Читать дальше »

Процедурки конвертации файлов WinToDos  DosToWin

uses Classes,Windows;

function DosToWin(St: string): string; // из Dos в Win кодировку
var
  Ch: PChar;
begin
  Ch := StrAlloc(Length(St) + 1);
  OemToAnsi(PChar(St), Ch);
  Result := Ch;
  StrDispose(Ch)
end;

Function WinToDos(const S: string):string;
var
  NewStr: string;
begin
  SetLength(NewStr, Length(S));
  Windows.CharToOem(PChar(S), PChar(NewStr));
  result:=NewStr;
end;

procedure CvWinToDos(Fl1,fl2:string);
var
  Txt:TStringList;
  begin
      txt:=TStringList.Create;
      txt.LoadFromFile(Fl1);
      txt.Text:=WinToDos(txt.Text);
      txt.SaveToFile(Fl2);
      txt.Free;
  end;

procedure CvDosToWin(Fl1,fl2:string);
var
  T ... Читать дальше »

Представляю программу для конвертации кодировок файлов из Win кодировки в Dos
Полезная программа для перевода из Pascal ABC  / Delphi В Borland Turbo Pascal

Написана на Delphi 7 для добавления функций пишите
ICQ 368-254-335
denis-naymov1985@mail.ru



/73_WinToDos.zip

последний день месяца Delphi
function LastDayOfCurrentMonth: TDate;
 var
   y, m, d: Word;
 begin
   DecodeDate(now, y, m, d);
   m := m + 1;
   if m >12 then
   begin
     y := y + 1;
     m := 1;
   end;
   Result := EncodeDate(y, m, 1) - 1;
 end;

// первый день месяца Delphi
Function FirstDayCurrentMonth:Tdate;
var
  y, m, d: Word;
 begin
   DecodeDate(now, y, m, d);
   Result := EncodeDate(y, m, 1);
 end;

 procedure TForm1.Button1Click(Sender: TObject);
 begin
 ShowMessage(DateToStr(FirstDayCurrentMonth)); // дата начала действия 
  ShowMessage(DateToStr(LastDayOfCurrentMonth)); 
 end;

Function GetDoubleCharInStr(value:string):boolean;
var
  x:integer;
  begin
  result:=false;
    for x:=1 to length(value)-1 do begin
       if (value[x]=value[x+1]) and (value[x] in ['A'..'Z','a'..'z','а'..'я','А'..'Я']) then begin  // проверяем только буквы
          result:=true;
       end;
    end;
  end;
 
var s:string;

  begin
  s:='Проверить, встречается ли в строке  е удвоения букв. ';
   if GetDoubleCharInStr(s) then Writeln('Есть удвоения букв')
   else Writeln('Удвоеных букв нет');
  end.

{2.    Пусть задана некоторая строка str, необходимо вывести в обратном порядке. }
  var s2,s:string;
      x:integer;
 
begin
  s:='2.    Пусть задана некоторая строка str, необходимо вывести в обратном порядке.';
  s2:='';
  for x:=length(s) downto 1 do begin
     s2:=s2+s[x];
  end;
  writeln(s2);
end.

2.    Пусть задана матрица размером N строк на M столбцов
(N<=100,M<=100).
Необходимо заполнить матрицу таким образом, чтобы все элементы
пронумерованы слева направо и сверху вниз по порядку, начиная с единицы.
 
program Project2;

{$APPTYPE CONSOLE}

uses
  SysUtils;


 type
 TArrayInt = array[1..100,1..100] of integer;
 var
     a:TArrayInt;
     n,m:integer;

     procedure CreateMas(var a:TArrayInt; const n,m:integer);
       var l,x,y:integer;
     begin
     l:=1;
     for y:=1 to m do
      for X:=1 to n do begin
            a[x,y]:=l;
            l:=l+1;
   & ... Читать дальше »

... Читать дальше »