Сайт заготовки для Дельфи&Pascal

SelectDirectory выбор каталога с кнопкой создать директорию

NetSoftWare — Thu, 10 Jan 2013 05:45:25 GMT

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) then
    Directory := '';
FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
begin
    Buffer := ShellMalloc.Alloc(MAX_PATH);
    try
      RootItemIDList := nil;
      if Root <> '' then
      begin
        SHGetDesktopFolder(IDesktopFolder);
        IDesktopFolder.ParseDisplayName(Application.Handle, nil,
          POleStr(Root), Eaten, RootItemIDList, Flags);
      end;
      with BrowseInfo do
      begin
        hwndOwner := Application.Handle;
        pidlRoot := RootItemIDList;
        pszDisplayName := Buffer;
        lpszTitle := PChar(Caption);
        ulFlags :=
         BIF_RETURNONLYFSDIRS or
         BIF_USENEWUI or
         BIF_EDITBOX * Ord(1) or
         BIF_BROWSEINCLUDEFILES * Ord(0) or
         BIF_NOCREATEDIRS * Ord(true);

        if Directory <> '' then
        begin
          lpfn := SelectDirCB;
          lParam := Integer(PChar(Directory));
        end;
      end;
      WindowList := DisableTaskWindows(0);
      OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
      try
        ItemIDList := ShBrowseForFolder(BrowseInfo);
      finally
        SetErrorMode(OldErrorMode);
        EnableTaskWindows(WindowList);
      end;
      Result := ItemIDList <> nil;
      if Result then
      begin
        ShGetPathFromIDList(ItemIDList, Buffer);
        ShellMalloc.Free(ItemIDList);
        Directory := Buffer;
      end;
    finally
      ShellMalloc.Free(Buffer);
    end;
end;
end;

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

NetSoftWare — Thu, 10 Jan 2013 05:41:56 GMT

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

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

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

var
  fullFileName : string;

begin
  // Установка полного имени файла с диском и путем
  fullFileName := 'C:\Program Files\Borland\Delphi7\Projects\Unit1.dcu';

  // Показ составляющих частей этого полного имени
  ShowMessage('Диск       = '+ExtractFileDrive (fullFileName));
  ShowMessage('Каталог    = '+ExtractFileDir   (fullFileName));
  ShowMessage('Путь       = '+ExtractFilePath  (fullFileName));
  ShowMessage('Имя        = '+ExtractFileName  (fullFileName));
  ShowMessage('Расширение = '+ExtractFileExt   (fullFileName));
end;

Диск = C:
Каталог = C:\Program Files\Borland\Delphi7\Projects
Путь = C:\Program Files\Borland\Delphi7\Projects\
Имя = Unit1.dcu
Расширение = .dcu

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

NetSoftWare — Thu, 10 Jan 2013 05:39:34 GMT

Процедурки конвертации файлов 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
Txt:TStringList;
begin
      txt:=TStringList.Create;
      txt.LoadFromFile(Fl1);
      txt.Text:=DoSToWin(txt.Text);
      txt.SaveToFile(Fl2);
      txt.Free;
end;

Конвертер группы файлов из Win в Dos также из Dos в Win

NetSoftWare — Thu, 10 Jan 2013 05:35:42 GMT

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

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

/73_WinToDos.zip

Программа для построения алгоритмов из исходного кода Pascal/Delphi

NetSoftWare — Mon, 03 Dec 2012 05:26:38 GMT

Нашел хорошую программу для построения блок схем по исходному коду

/Blocker.zip

программу можно скачать
http://programmir.far.ru/?ref=BlokShemnik

Начало и конец месяца в Delphi

NetSoftWare — Mon, 03 Dec 2012 04:04:11 GMT

последний день месяца 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;

Проверить, встречается ли в строке удвоения букв

NetSoftWare — Wed, 28 Nov 2012 03:43:20 GMT

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.

Пусть задана некоторая строка str, необходимо вывести в обратном порядке

NetSoftWare — Tue, 27 Nov 2012 11:41:02 GMT

{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.

Delphi заполнение матрицы

NetSoftWare — Tue, 27 Nov 2012 08:17:01 GMT

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;
          end;

     end;

     Procedure Display(a:TArrayInt;n,m:integer);
     var x,y:integer;
     begin
        for y:=1 to m do begin
         writeln;
         writeln;
         for X:=1 to n do begin
           write(a[x,y]:3);
         end;
     end;end;
     var l:integer;
begin
    l:=3;
    CreateMas(a,l,l);
    Display(a,l,l);
    readln;
{ TODO -oUser -cConsole Main : Insert code here }
end.

Задачи Delphi / Pascal матрицы

NetSoftWare — Tue, 27 Nov 2012 08:06:07 GMT

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

program Project2;

{$APPTYPE CONSOLE}

uses
SysUtils;
type
     TArrayReal=array [1..100,1..100] of Real;

var
    x,y:integer;
    a:TArrayReal;
    n,m:integer;

    Function Max(a,b:integer):integer; // находим максимальный среди двух элементов
    begin
       if a>b then result:=a
       else result:=b;
    end;

    Function GetDEcl(a:integer):integer; // порядок числа
    var i:integer;
        a1:real;
    begin
    i:=1;
    a1:=a;
     if a>0.9 then begin
      repeat
      a1:=a1/10;
      i:=i*10;
      until a1<0.9;
      result:=i;
      end
      else result:=1;
    end;

   Function GetDEcl_I(a:integer):integer; // порядок числа
    var i:integer;
        a1:real;
    begin
    i:=0;
    a1:=a;
     if a>0.9 then begin
      repeat
      a1:=a1/10;
      i:=i+1;
      until a1<0.9;
      result:=i;
      end
      else result:=1;
    end;

    Procedure CreateMas(var a:TArrayReal; const n,m:integer);
       var dec,x,y:integer;
    begin
      for y:=1 to n do
      for X:=1 to m do begin
      dec:=GetDEcl(max(x+1,y+1));
         a[x,y]:=(x+1)+(y+1)/dec;
      end;
    end;

   Procedure Display(a:TArrayReal;n,m:integer); // вывод матрицы на экран
   var I,x,y:integer;
   begin
      i:=GetDEcl_I(max(n,m));
      for y:=1 to n do begin
      writeln;
      for x:=1 to m do begin
        write(a[x,y]:I:I,'   ');
      end;
      end;
   end;
begin
N:=8;
m:=8;
CreateMas(a,n,m);
Display(a,n,m);
readln;
{ TODO -oUser -cConsole Main : Insert code here }

end.