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

Статус
В этой теме нельзя размещать новые ответы.

Shegorat

Lord of Madness
Администратор
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(Закрытие ворда) кинуло ошибку
 

sergey3695

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

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;
что не так-то?
 

Mailchik

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

AVG

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

AVG

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

Mailchik

Старожил
Проверенный
Mailchik, будет ошибка в некоторых случаях при разрушении формы,лично проверено,лучше передавать функцию или типа Boolean или(в данном случае)AnsiString
Очень интересно. Впервые слышу о такой проблеме. Может не в инно дело?
Вот например функция: Код...Проверил раз 10, никакого краша.
 

AVG

Новичок
Код:
function GetDriveType(lpRootPathName: string): UINT;
ну и где здесь ты передаешь String функцию?)
 

AVG

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

sergey3695

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

Вложения

Последнее редактирование:
Статус
В этой теме нельзя размещать новые ответы.
Сверху