Core/DBDWindows.pas - master - YakuninAV/Convertors

Core/DBDWindows.pas
180 строк7 KB
YakuninAV
begin with gitflick
31 июл 2026, 15:21
31 июл 2026, 15:211dc0fc6
unit DBDWindows;

{$I mormot.defines.inc}

interface

uses
{$IFDEF ISDELPHIXE2}
//System.SysUtils, Winapi.Windows, Winapi.ShellApi, System.Win.ComObj, Winapi.ActiveX, vcl.ClipBrd
  SysUtils, Windows, ShellApi, ComObj, ActiveX, Vcl.Clipbrd, System.UITypes
{$ELSE}
  SysUtils, Windows, ShellApi, ComObj, ActiveX, Clipbrd, Messages
{$ENDIF}
  ;

/// Процедура показывает сообщение в окне Windows, и является обёрткой на функцией MessageBox из Windows API
// ! Str - текст сообщения
// ! Hdr - заголовок окна с сообщением
// ! mbFlag - MessageBox() Flags - константы определённые в модуле Windows
// ! MB_OK              = $00000000
// ! MB_ICONHAND        = $00000010
// ! MB_ICONQUESTION    = $00000020
// ! MB_ICONEXCLAMATION = $00000030
// ! MB_ICONASTERISK    = $00000040
// ! MB_ICONWARNING     = MB_ICONEXCLAMATION
// ! MB_ICONERROR       = MB_ICONHAND
// ! MB_ICONINFORMATION = MB_ICONASTERISK
// ! MB_ICONSTOP        = MB_ICONHAND
// ! MB_OKCANCEL        = $00000001

function ShowMsg(const Str, Hdr: string; const mbflag: Integer=MB_ICONASTERISK): Boolean; inline;

procedure ShowFolder(const FldName: TFileName);// inline;

/// Выполняет команду
procedure ShellExecute(const AWnd: HWND; const AOperation, AFileName: String;
                       const AParameters: String = ''; const ADirectory: String = ''; const AShowCmd: Integer = SW_SHOWNORMAL);

/// запускает процесс
function WinExecAndWait32(const Cmd, Par: string; Visibility: integer; const WaitForEnd: Boolean=False): integer;
{$IFNDEF FPC}
//Копирует правильно русский текст в буфер обмена
procedure TextToClipboard(const sSrt:string);
{$ENDIF}
implementation

function FindAppWindow(const Caption: string): THandle;
begin
  Result:= FindWindow(nil, PChar('Турбо сметчик'));
end;

function ShowMsg(const Str, Hdr: string; const mbflag: Integer=MB_ICONASTERISK): Boolean; inline;
var {$IFDEF ISDELPHIXE2} wT,wH: WideString; {$ELSE} aT,aH: AnsiString; {$ENDIF}  i: Integer;
begin
//+MB_SYSTEMMODAL+MB_TOPMOST
{$IFDEF ISDELPHIXE2}
  wT:=str; wH:=Hdr;
  i:=MessageBox(0, PWideChar(wT), PWideChar(wH), mbFlag+MB_SYSTEMMODAL+MB_TOPMOST);
{$ELSE}
  aT:=str; aH:=Hdr;
  i:=MessageBox(0, PAnsiChar(aT), PAnsiChar(aH), mbFlag+MB_SYSTEMMODAL+MB_TOPMOST);
{$ENDIF}
  Result:= (i=idOK) or (i=idYes);
end;

procedure ShowFolder(const FldName: TFileName);
var fld: TFileName;
begin
  if FldName=''                        then ShowMsg('Имя папки не задано', 'Ошибка просмотра папки', $00000010)
  else if not DirectoryExists(FldName) then ShowMsg('Папка "' + FldName + '" не найдена', 'Ошибка просмотра папки', $00000010)
  else                                      ShellExecute(0,'explore', FldName);
end;

procedure ShellExecute(const AWnd: HWND; const AOperation, AFileName: String;
                       const AParameters: String = ''; const ADirectory: String = ''; const AShowCmd: Integer = SW_SHOWNORMAL);
var
  ExecInfo: TShellExecuteInfo;
  NeedUnitialize: Boolean;
begin
  Assert(AFileName <> '');

  NeedUnitialize := Succeeded(CoInitializeEx(nil, COINIT_APARTMENTTHREADED or COINIT_DISABLE_OLE1DDE));
  try
    FillChar(ExecInfo, SizeOf(ExecInfo), 0);
    ExecInfo.cbSize := SizeOf(ExecInfo);

    ExecInfo.Wnd := AWnd;
    ExecInfo.lpVerb := Pointer(AOperation);
    ExecInfo.lpFile := PChar(AFileName);
    ExecInfo.lpParameters := Pointer(AParameters);
    ExecInfo.lpDirectory := Pointer(ADirectory);
    ExecInfo.nShow := AShowCmd;
{$IFDEF ISDELPHIXE2}
    ExecInfo.fMask := SEE_MASK_NOASYNC { = SEE_MASK_FLAG_DDEWAIT для старых версий Delphi }
{$ELSE}
    ExecInfo.fMask := SEE_MASK_FLAG_DDEWAIT { = SEE_MASK_FLAG_DDEWAIT для старых версий Delphi }
{$ENDIF}
                   or SEE_MASK_FLAG_NO_UI;
    {$IFDEF UNICODE}
    // Необязательно, см. http://www.transl-gunsmoker.ru/2015/01/what-does-SEEMASKUNICODE-flag-in-ShellExecuteEx-actually-do.html
    ExecInfo.fMask := ExecInfo.fMask or SEE_MASK_UNICODE;
    {$ENDIF}
{$IFDEF FPC}

{$ELSE}
    {$WARN SYMBOL_PLATFORM OFF}
    Win32Check(ShellExecuteEx(@ExecInfo));
    {$WARN SYMBOL_PLATFORM ON}
{$ENDIF}
  finally
    if NeedUnitialize then
      CoUninitialize;
  end;
end;

function WinExecAndWait32(const Cmd, Par: string; Visibility: integer; const WaitForEnd: Boolean=False): integer;
var
  zApp: array[0..255] of char;
  zPar: array[0..512] of char;
  zCurDir: array[0..255] of char;
  CmdLine, WorkDir: String;
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  ret: Cardinal;
begin
  CmdLine := Format('"%s" %s', [Cmd, Par]);
  StrPCopy(zApp, Cmd);
  StrPCopy(zPar, CmdLine);
  GetDir(0, WorkDir);
  StrPCopy(zCurDir, WorkDir);
  FillChar(StartupInfo, Sizeof(StartupInfo), #0);
  FillChar(ProcessInfo, Sizeof(ProcessInfo), #0);
  StartupInfo.cb := Sizeof(StartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := Visibility;
  if not CreateProcess(zApp,
                       zPar,                          { указатель командной строки }
                       nil,                           { указатель на процесс атрибутов безопасности }
                       nil,                           { указатель на поток атрибутов безопасности }
                       false,                         { флаг родительского обработчика }
                       CREATE_NEW_CONSOLE or          { флаг создания }
                       NORMAL_PRIORITY_CLASS,
                       nil,                           { указатель на новую среду процесса }
                       nil,                           { указатель на имя текущей директории }
                       StartupInfo,                   { указатель на STARTUPINFO }
                       ProcessInfo) then Result := -1 { указатель на PROCESS_INF }
  else if WaitForEnd then begin
    WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
    GetExitCodeProcess(ProcessInfo.hProcess, ret);
    Result := ret;
  end else Result:=0;
end;
{$IFNDEF FPC}
procedure TextToClipboard(const sSrt:string);
var N:Integer; mem:THandle; ptr:Pointer;
begin
  with Clipboard do try
    Open;
    if IsClipboardFormatAvailable(CF_UNICODETEXT) then
    begin
      N:=(Length(sSrt)+1)*2;
      mem:=GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE,N);
      ptr:=GlobalLock(mem);
      Move(PWideChar(widestring(sSrt))^, ptr^,N);
      GlobalUnlock(mem);
      SetAsHandle(CF_UNICODETEXT,mem);
    end;
    AsText:=sSrt;
    mem:=GlobalAlloc(GMEM_MOVEABLE+GMEM_DDESHARE,SizeOf(dword));
    ptr:=GlobalLock(mem);
    dword(ptr^):=(SUBLANG_NEUTRAL shl 10) or LANG_RUSSIAN;
    GlobalUnLock(mem);
    SetAsHandle(CF_LOCALE,mem);

  finally
    Close;
  end;
end;
{$ENDIF}
end.