6 заметок с тегом

free pascal

рекурсивное удаление директории

аналог

rmdir /s /q или rm -rf

function DeleteDirectoryEx(DirectoryName: string): boolean;
// адаптирована функция DeleteDirectory из модуля fileutil, спасибо Павлу Дмитруку
var
  FileInfo: TSearchRec;
  CurSrcDir: String;
  CurFilename: String;
begin
  Result:=false;
  CurSrcDir:=CleanAndExpandDirectory(DirectoryName);
  try
         if FindFirstUTF8(CurSrcDir+GetAllFilesMask,faAnyFile,FileInfo)=0 then
         begin
           repeat
             if (FileInfo.Name<>'.') and (FileInfo.Name<>'..') and (FileInfo.Name<>'') then
             begin
               CurFilename:=CurSrcDir+FileInfo.Name;
               if (FileInfo.Attr and faReadOnly)>0 then
                 FileSetAttrUTF8(CurFilename, FileInfo.Attr-faReadOnly);
               if (FileInfo.Attr and faDirectory)>0 then
               begin
                 if not DeleteDirectoryEx(CurFilename) then exit;
               end
               else
               begin
                 if not DeleteFileUTF8(CurFilename) then exit;
               end;
             end;
           until FindNextUTF8(FileInfo)<>0;
         end;
         FindCloseUTF8(FileInfo);
         if (not RemoveDirUTF8(DirectoryName)) then
           begin
             exit;
             Result:=true;
           end;
  except
    Result:=false;
  end;
end;
 Нет комментариев    7   3 мес   free pascal   lazarus

запускаем внешнее приложение, ждем завершения и получаем вывод

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

function RunScript(sCommand: String): TStringList;
var
  OurCommand: String;
  OutputLines: TStringList;
  MemStream: TMemoryStream;
  OurProcess: TProcess;
  NumBytes: LongInt;
  BytesRead: LongInt;
const
  READ_BYTES = 204800;
begin
  MemStream := TMemoryStream.Create;
  BytesRead := 0;
  OurProcess := TProcess.Create(nil);
  OurCommand := sCommand;
  OurProcess.CommandLine := OurCommand;
  OurProcess.ShowWindow:=swoHIDE;
  OurProcess.Options := [poUsePipes, poNoConsole];
  OurProcess.Execute;
  while OurProcess.Running do
  begin
    MemStream.SetSize(BytesRead + READ_BYTES);
    NumBytes := OurProcess.Output.Read((MemStream.Memory + BytesRead)^, READ_BYTES);
    if NumBytes > 0
    then begin
      Inc(BytesRead, NumBytes);
      Sleep(100);
    end
    else begin
      Sleep(100);
    end;
  end;
  Sleep(1000);
  repeat
    MemStream.SetSize(BytesRead + READ_BYTES);
    NumBytes := OurProcess.Output.Read((MemStream.Memory + BytesRead)^, READ_BYTES);
    if NumBytes > 0
    then begin
      Inc(BytesRead, NumBytes);
    end;
    Sleep(100);
  until NumBytes <= 0;
  MemStream.SetSize(BytesRead);
  OutputLines := TStringList.Create;
  OutputLines.LoadFromStream(MemStream);
  result := OutputLines;
  OurProcess.Free;
  MemStream.Free;
end;
 Нет комментариев    4   3 мес   free pascal   lazarus

получаем содержимое url (поддерживается http, https)

Бывает в приложении для windows нужно по ссылке получить какую нибудь информацию, ниже представлена функция, которая это сделает быстро и без дополнительных библиотек

function get_from_server(const Url: string): string;
const
  UserAgent = 'Mozilla/5.0 (compatible)';
var
  hInet: HINTERNET;
  hURL: HINTERNET;
  Buffer: array[0..1023] of AnsiChar;
  BufferLen: cardinal;
begin
  result := '';
  hInet := InternetOpen(PChar(UserAgent), INTERNET_OPEN_TYPE_PRECONFIG, nil, nil, 0);
  if hInet = nil then RaiseLastOSError;
  try
    hURL := InternetOpenUrl(hInet, PChar(URL), nil, 0, 0, 0);
    if hURL = nil then RaiseLastOSError;
    try
      repeat
        if not InternetReadFile(hURL, @Buffer, SizeOf(Buffer), BufferLen) then
          RaiseLastOSError;
        result := result + UTF8Decode(Copy(Buffer, 1, BufferLen))
      until BufferLen = 0;
    finally
      InternetCloseHandle(hURL);
    end;
  finally
    InternetCloseHandle(hInet);
  end;
end;
 Нет комментариев    4   3 мес   free pascal   lazarus

получаем namingContexts контроллера домена

Некоторую информацию можно получить от контроллера домена без авторизации, например, namingContexts.

function get_ldap_namingContexts(server: string): string;
var
  ldap: TLDAPsend;
  attr: TStringList;
begin
  ldap:= TLDAPsend.Create;
  attr := TStringList.Create;
  attr.Add('namingContexts');
  try
       ldap.TargetHost := server;
       ldap.TargetPort := '389';
         if ldap.Login then
          begin
           if ldap.Bind then
            begin
              ldap.SearchScope:=SS_BaseObject;
              if ldap.Search('', False, '(objectClass=*)', attr) then
               begin
                  result:= ldap.SearchResult.Items[0].Attributes.Get('namingContexts')
               end;
            end;
           ldap.Logout;
          end;
  finally
     ldap.Free;
     attr.Free;
  end;
end;

результатом работы этой функции будет: DC=domain,DC=loc

про другие параметры можно почитать здесь: https://msdn.microsoft.com/en-us/library/ms684291(v=vs.85).aspx

 Нет комментариев    3   3 мес   free pascal   lazarus   ldapsend

путь к папке system32

часто надо выполнить системную команду cmd, ipconfig и т. д. запуск осуществляется от имени системы без окружения (отсутствуют глобальные переменные), путь приходится писать полный, для универсальности определим расположение папки system32

function SystemFolder: string;
begin
  SetLength(Result, Windows.MAX_PATH);
  SetLength(
    Result, Windows.GetSystemDirectory(PChar(Result), Windows.MAX_PATH)
  );
end;

обычно, результатом работы будет следующий путь: c:\windows\system32

 Нет комментариев    4   3 мес   free pascal   windows
Ранее Ctrl + ↓