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

[Shegorat]

deaddima
На, попробуй...

Спойлер

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]

Shegorat, Сделал как ты написал.Кинул процедуру на кнопку
Нажал на 1 =>запуск ворда ,нажал на 2(Закрытие ворда) кинуло ошибку

Спойлер

 

[Shegorat]

deaddima
Ну тогда убери Reserved.Quit; И попробуй снова.

 

[deaddima]

Теперь всё работает!!!

 

[sergey3695]

Спасибо большое.
Под спойлеры че-то у меня не засовывается. (х.з. почему) ну да ладно.

 

[David.D.Rocco]

sergey3695,
1:

Procedure SystemTooltip; [COLOR="Red"][B]stdcall;[/B][/COLOR]

2:

procedure SystemTooltip; external 'SystemTooltip@[COLOR="Red"][B]{tmp}\[/B][/COLOR]WinHST.dll stdcall delayload';

p.s. не проверял. Всего лишь догадки

 

[sergey3695]

David.D.Rocco, я уже и так и сяк пробывал в итоге только вот
сначала вот

потом вот и закрывается

 

[Mailchik]

sergey3695, под спойлеры бы эти длинные тексты.
По теме: код для библы правильный, работающий. В инно ты не верно объявляешь.
В дельфи ты ведь для формы вызываешь WMNCMouseMove, а в инно кто вызывать будет?

Спойлер: Код

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

Проверил у себя, системные хинты скрываются.
Скрипт вместе с библой, если кому надо: ссылка

 

[sergey3695]

решил написать библиотеку для проверки ярлыка на рабочем столе
сообственно код (делфи)

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 - определяет рабочую папку
в инно пишу так, но не робит почему-то.

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;

что не так-то?

 

[AVG]

sergey3695, ну во первых в инно нельзя передавать String функцию

 

[Mailchik]

AVG, в каком смысле?
sergey3695, возможно ошибаюсь, но наверняка дело в пути:

GetFileWorkingDirectoryFromLink('{userdesktop}\Crysis 2.lnk')

Правильнее будет:

GetFileWorkingDirectoryFromLink(ExpandConstant('{userdesktop}\Crysis 2.lnk'))

 

[AVG]

Mailchik, будет ошибка в некоторых случаях при разрушении формы,лично проверено,лучше передавать функцию или типа Boolean или(в данном случае)AnsiString

 

[sergey3695]

AVG, AnsiString - если попробывать, робить будет?

 

[AVG]

sergey3695,Попробуй поменять на AnsiString(хотя есть нету ошибки то не стоит),ну и естественно добавь ExpandConstant при прописке путь к ярлыку.

 

[Mailchik]

Mailchik, будет ошибка в некоторых случаях при разрушении формы,лично проверено,лучше передавать функцию или типа Boolean или(в данном случае)AnsiString

Очень интересно. Впервые слышу о такой проблеме. Может не в инно дело?
Вот например функция: Код...

[Setup]
AppName=My Application
AppVersion=1.5
DefaultDirName={pf}\My Application

[B][[/B]Code]
#ifdef UNICODE
 #define A "W"
 type
  PChar = PAnsiChar;
#else
 #define A "A"
#endif

function GetDriveType(lpRootPathName: string): UINT;
 external 'GetDriveType{#A}@kernel32.dll stdcall';

function DriveTypeStr(sDrive: string): string;
 begin
  case GetDriveType(sDrive) of
   0: Result := 'Тип накопителя не определен';
   1: Result := 'Корневой путь недопустим';
   2: Result := 'Извлекаемый диск';
   3: Result := 'Жесткий диск';
   4: Result := 'Сетевой диск';
   5: Result := 'CD-ROM';
   6: Result := 'RAM-диск';
  end;                  
end;

procedure CurPageChanged(CurPageID : integer);
 begin
  case CurPageID of
   wpReady : begin
    if DriveTypeStr(ExtractFileDrive(WizardForm.DirEdit.Text)) = 'Жесткий диск' then
     WizardForm.NextButton.Enabled := True else WizardForm.NextButton.Enabled := False;
   end;
  end;
end;

Проверил раз 10, никакого краша.

 

[AVG]

function GetDriveType(lpRootPathName: string): UINT;

ну и где здесь ты передаешь String функцию?)

 

[Mailchik]

AVG, function DriveTypeStr(sDrive: string): string;

 

[AVG]

Mailchik, ты не понял,нельзя передавать из библиотеки функцию типа String,а созданную в инно можно

 

[sergey3695]

AVG, пишет что не может создать процесс. не пойму, че ему надо. ща с boolean попробую.

 

[AVG]

sergey3695, скинь скриншоты ошибки,посмотрим