1. Уважаемые гости и пользователи форума.
    Администрация настоятельно рекомендует не регистрировать несколько аккаунтов для одного пользователя. При выявлении наличия мультиаккаунтов будут заблокированы все учетные записи данного пользователя.
    Аккаунты, зарегистрированные на временную почту будут также заблокированы.

Вопросы и решения

Тема в разделе "Архив", создана пользователем LexBell, 3 авг 2011.

Статус темы:
Закрыта.
  1. Безумный Лорд Администратор

    Регистрация:
    15 июн 2011
    Сообщения:
    693
    Симпатии:
    1.019
    Пол:
    Мужской
    deaddima
    На, попробуй...
    Код (Text):
    library Project1;

    uses
      Windows, Variants;

    const
      CLSCTX_INPROC_SERVER     = 1;
      CLSCTX_INPROC_HANDLER    = 2;
      CLSCTX_LOCAL_SERVER      = 4;
      CLSCTX_INPROC_SERVER16   = 8;
      CLSCTX_REMOTE_SERVER     = $10;
      CLSCTX_INPROC_HANDLER16  = $20;
      CLSCTX_INPROC_SERVERX86  = $40;
      CLSCTX_INPROC_HANDLERX86 = $80;

    type
      PCLSID = PGUID;
      TCLSID = TGUID;
      PIID = PGUID;
      TIID = TGUID;

      POleStr = PWideChar;

    var
      Reserved: array of Variant;

    function CLSIDFromProgID(pszProgID: POleStr; out clsid: TCLSID): HResult; stdcall;
      external 'ole32.dll' name 'CLSIDFromProgID';

    function CoCreateInstance(const clsid: TCLSID; unkOuter: IUnknown;
      dwClsContext: Longint; const iid: TIID; out pv): HResult; stdcall;
      external 'ole32.dll' name 'CoCreateInstance';

    function CreateOleObject(const ClassName: string): IDispatch;
    var
      ClassID: TCLSID;
    begin
      if Succeeded(CLSIDFromProgID(PWideChar(WideString(ClassName)), CLassID)) then
        CoCreateInstance(ClassID, nil, CLSCTX_INPROC_SERVER or CLSCTX_LOCAL_SERVER, IDispatch, Result);
    end;

    Function CreateWord: Boolean; stdcall;
    var
      i: Integer;
    begin
      Result:=true;
      try
        i:= Length(Reserved);
        SetLength(Reserved, i+1);
        Reserved[i]:= CreateOleObject('Word.Application');
      except
        Result:=false;
      end;
    end;

    procedure FreeWords(); stdcall;
    var
      i: Integer;
    begin
      for i:=0 to Length(Reserved)-1 do begin
        Reserved[i].Quit;
        Reserved[i]:= Unassigned;
      end;
      SetLength(Reserved, 0);
    end;

    exports
      FreeWords,
      CreateWord;

    begin
    end.
     
    deaddima нравится это.
  2. Новичок

    Регистрация:
    15 янв 2012
    Сообщения:
    32
    Симпатии:
    2
    Shegorat, Сделал как ты написал.Кинул процедуру на кнопку
    Нажал на 1 =>запуск ворда ,нажал на 2(Закрытие ворда) кинуло ошибку
    [​IMG]
     
  3. Безумный Лорд Администратор

    Регистрация:
    15 июн 2011
    Сообщения:
    693
    Симпатии:
    1.019
    Пол:
    Мужской
    deaddima
    Ну тогда убери Reserved.Quit; И попробуй снова.
     
    deaddima нравится это.
  4. Новичок

    Регистрация:
    15 янв 2012
    Сообщения:
    32
    Симпатии:
    2
    Теперь всё работает!!!
     
  5. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.049
    Симпатии:
    703
    Спасибо большое. :acute:
    Под спойлеры че-то у меня не засовывается. (х.з. почему) ну да ладно.
     
    Последнее редактирование: 9 фев 2013
  6. Ветеран Проверенный

    Регистрация:
    28 июн 2011
    Сообщения:
    165
    Симпатии:
    218
    Пол:
    Мужской
    sergey3695,
    1:
    Код (Text):
    Procedure SystemTooltip; [COLOR="Red"][B]stdcall;[/B][/COLOR]
    2:
    Код (Text):
    procedure SystemTooltip; external 'SystemTooltip@[COLOR="Red"][B]{tmp}\[/B][/COLOR]WinHST.dll stdcall delayload';
    p.s. не проверял. Всего лишь догадки
     
    sergey3695 нравится это.
  7. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.049
    Симпатии:
    703
    David.D.Rocco, я уже и так и сяк пробывал в итоге только вот
    сначала вот
    [​IMG]
    потом вот и закрывается
    [​IMG]
     
  8. Ветеран Проверенный

    Регистрация:
    19 дек 2011
    Сообщения:
    349
    Симпатии:
    401
    sergey3695, под спойлеры бы эти длинные тексты.
    По теме: код для библы правильный, работающий. В инно ты не верно объявляешь.
    В дельфи ты ведь для формы вызываешь WMNCMouseMove, а в инно кто вызывать будет?
    Код (Text):
    [Setup]
    AppName=My Application
    AppVersion=1.5
    DefaultDirName={pf}\My Application

    [Files]
    Source: WinHST.dll; Flags: dontcopy;

    [B][[/B]Code]
    #ifdef UNICODE
     #define A "W"
    #else
     #define A "A"
    #endif
    const
      GWL_WNDPROC = -4;
      WM_NCMOUSEMOVE      = $00A0;

    type
      LPARAM = Integer;
      WPARAM = Integer;
      LRESULT = Integer;
      TFNWndProc = Integer;

    var
      SysTooltip: HWND;
      OldWindowProc: Longint;

    procedure SystemTooltip;
     external 'SystemTooltip@{tmp}\WinHST.dll stdcall delayload';
    function SetWindowLong(hWnd: HWND; nIndex: Integer; dwNewLong: Longint): Longint;
      external 'SetWindowLong{#A}@user32.dll stdcall';
    function CallWindowProc(lpPrevWndFunc: TFNWndProc; hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
      external 'CallWindowProc{#A}@user32.dll stdcall';
    function IsWindow(hWnd: HWND): BOOL;
      external 'IsWindow@user32.dll stdcall';
    function IsWindowVisible(hWnd: HWND): BOOL;
      external 'IsWindowVisible@user32.dll stdcall';

    function WindowProc(hWnd: HWND; Msg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT;
     begin
      case Msg of
       WM_NCMOUSEMOVE: begin
        if not IsWindow(SysTooltip) then
         SystemTooltip;
        if not IsWindowVisible(SysTooltip) then Exit;
       end;
      end;
      Result := CallWindowProc(OldWindowProc, hWnd, Msg, wParam, lParam);
    end;

    procedure InitializeWizard;
     begin
      ExtractTemporaryFile('WinHST.dll');
      OldWindowProc := SetWindowLong(WizardForm.Handle, GWL_WNDPROC, CallbackAddr('WindowProc'));
    end;

    procedure DeinitializeSetup();
     begin
      SetWindowlong(WizardForm.Handle, GWL_WNDPROC, OldWindowProc);
    end;
     
    Проверил у себя, системные хинты скрываются.
    Скрипт вместе с библой, если кому надо: ссылка
     
  9. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.049
    Симпатии:
    703
    решил написать библиотеку для проверки ярлыка на рабочем столе
    сообственно код (делфи)
    Код (Text):
    library Link;

    uses
      ComObj, SysUtils, Windows, ActiveX, System, ShlObj;

    function GetFileWorkingDirectoryFromLink(LinkFileName: string): string;
    var
    MyObject: IUnknown;
    MySLink: IShellLink;
    MyPFile: IPersistFile;
    WidePath: array[0..MAX_PATH] of WideChar;
    Buff: array[0..MAX_PATH] of Char;
    begin
    Result := '';
    if ( FileExists( LinkFileName ) = false ) then
    Exit;
    MyObject := CreateComObject( CLSID_ShellLink );
    MyPFile := MyObject as IPersistFile;
    MySLink := MyObject as IShellLink;
    StringToWideChar( LinkFileName, WidePath, SizeOf( WidePath ) );
    MyPFile.Load( WidePath, STGM_READ );
    MySLink.GetWorkingDirectory( Buff, MAX_PATH );
    Result := buff;
    end;

    exports
      GetFileWorkingDirectoryFromLink;

    begin
    end.
     
    где LinkFileName - расположение ярлыка (например '{userdesktop}\Crysis 2.lnk' )
    GetFileWorkingDirectoryFromLink - определяет рабочую папку
    в инно пишу так, но не робит почему-то.
    Код (Text):

    function InitializeSetup(): Boolean;
    begin
      Result:= True;
    end;

    procedure GetFileWorkingDirectoryFromLink(LinkFileName: string); external 'GetFileWorkingDirectoryFromLink@{tmp}\Link.dll stdcall delayload';

    procedure InitializeWizard;
    var
      Check: boolean;
    begin
      ExtractTemporaryFile('Link.dll');
    if  GetFileWorkingDirectoryFromLink('{userdesktop}\Crysis 2.lnk')= 'D:\Games\Crysis 2' tnen
    deletefile('{userdesktop}\Crysis 2.lnk');
    end;
     
    что не так-то?
     
  10. AVG AVG

    Ветеран

    Регистрация:
    1 ноя 2011
    Сообщения:
    32
    Симпатии:
    10
    sergey3695, ну во первых в инно нельзя передавать String функцию :)
     
    sergey3695 нравится это.
  11. Ветеран Проверенный

    Регистрация:
    19 дек 2011
    Сообщения:
    349
    Симпатии:
    401
    AVG, в каком смысле?
    sergey3695, возможно ошибаюсь, но наверняка дело в пути:
    Код (Text):
    GetFileWorkingDirectoryFromLink('{userdesktop}\Crysis 2.lnk')
    Правильнее будет:
    Код (Text):
    GetFileWorkingDirectoryFromLink(ExpandConstant('{userdesktop}\Crysis 2.lnk'))
     
  12. AVG AVG

    Ветеран

    Регистрация:
    1 ноя 2011
    Сообщения:
    32
    Симпатии:
    10
    Mailchik, будет ошибка в некоторых случаях при разрушении формы,лично проверено,лучше передавать функцию или типа Boolean или(в данном случае)AnsiString
     
    sergey3695 нравится это.
  13. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.049
    Симпатии:
    703
    AVG, AnsiString - если попробывать, робить будет?
     
  14. AVG AVG

    Ветеран

    Регистрация:
    1 ноя 2011
    Сообщения:
    32
    Симпатии:
    10
    sergey3695,Попробуй поменять на AnsiString(хотя есть нету ошибки то не стоит),ну и естественно добавь ExpandConstant при прописке путь к ярлыку.
     
    sergey3695 нравится это.
  15. Ветеран Проверенный

    Регистрация:
    19 дек 2011
    Сообщения:
    349
    Симпатии:
    401
    Очень интересно. Впервые слышу о такой проблеме. Может не в инно дело?
    Вот например функция: Код...
    Проверил раз 10, никакого краша.
     
    sergey3695 нравится это.
  16. AVG AVG

    Ветеран

    Регистрация:
    1 ноя 2011
    Сообщения:
    32
    Симпатии:
    10
    Код (Text):
    function GetDriveType(lpRootPathName: string): UINT;
    ну и где здесь ты передаешь String функцию?)
     
    sergey3695 нравится это.
  17. Ветеран Проверенный

    Регистрация:
    19 дек 2011
    Сообщения:
    349
    Симпатии:
    401
    AVG, function DriveTypeStr(sDrive: string): string;
     
    sergey3695 нравится это.
  18. AVG AVG

    Ветеран

    Регистрация:
    1 ноя 2011
    Сообщения:
    32
    Симпатии:
    10
    Mailchik, ты не понял,нельзя передавать из библиотеки функцию типа String,а созданную в инно можно
     
    sergey3695 нравится это.
  19. Ветеран Модератор

    Регистрация:
    26 июн 2011
    Сообщения:
    1.049
    Симпатии:
    703
    AVG, пишет что не может создать процесс. не пойму, че ему надо. ща с boolean попробую.
     

    Вложения:

    Последнее редактирование: 29 апр 2013
  20. AVG AVG

    Ветеран

    Регистрация:
    1 ноя 2011
    Сообщения:
    32
    Симпатии:
    10
    sergey3695, скинь скриншоты ошибки,посмотрим
     
    sergey3695 нравится это.
Статус темы:
Закрыта.

Поделиться этой страницей