お知らせ

電子会議

ライブラリ

パレット

Delphi FAQ検索

Delphi FAQ一覧

サンプル蔵





FDelphi FAQ
１６番会議室「玉石混淆みんなで作るSample蔵」に寄せられたサンプル

"[D3]InternetShortcut関係:[注]長文" 


この発言に対し以下のコメントが寄せられています

#00378　ヒシアマゾン    さん　RE:[D3]InternetShortcut関係:[注]長文







{
InternetShortcut自体 INIファイル形式で読み取りができるのですが
IUniformResourceLocatorを 使用してInternetShortcutからURL取得、
InternetShortcutを作成、InternetShortcutからブラウザ起動の
サンプルを Delphi用に作ってみました。
# IE4が インストールしていないと作動しません。 
}
///////////////////////////////////////////////////////////////////////////
unit IE4;

interface

uses Windows;

const
  CLSID_InternetShortcut: TGUID = (
    D1:$FBF23B40; D2:$E3F0; D3:$101B; D4:($84,$88,$00,$AA,$00,$3E,$56,$F8));
  IID_IUniformResourceLocatorA: TGUID = (
    D1:$FBF23B80; D2:$E3F0; D3:$101B; D4:($84,$88,$00,$AA,$00,$3E,$56,$F8));
  SID_IUniformResourceLocatorA = '{FBF23B80-E3F0-101B-8488-00AA003E56F8}';

// Input flags for IUniformResourceLocator::SetURL().

   IURL_SETURL_FL_GUESS_PROTOCOL        = $0001;
   IURL_SETURL_FL_USE_DEFAULT_PROTOCOL  = $0002;

// Input flags for IUniformResourceLocator()::InvokeCommand().

   IURL_INVOKECOMMAND_FL_ALLOW_UI                  = $0001;
   IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB          = $0002;

// Command info for IUniformResourceLocator::InvokeCommand().

type
  PUrlinvokecommandinfoA = ^TUrlinvokecommandinfoA;
  TUrlinvokecommandinfoA = packed record
    dwcbSize: DWORD;
    dwFlags: DWORD;
    hwndParent: HWND;
    pcszVerb: Pchar;
  end;
  TUrlinvokecommandinfo = TUrlinvokecommandinfoA;
  PUrlinvokecommandinfo = PUrlinvokecommandinfoA;

  IUniformResourceLocatorA = interface(IUnknown)
    [SID_IUniformResourceLocatorA]
    function SetURL(const pcszURL: Pchar; dwInFlags: DWORD):HResult; stdcall
;
    function GetURL(var pcszURL: Pchar):HResult; stdcall;
    function InvokeCommand(purlici: PUrlinvokecommandinfo):HResult; stdcall;
  end;
  IUniformResourceLocator = IUniformResourceLocatorA;

function SHGetSpecialFolderPath(hwndOwner: HWND; lpszPath: pchar; 
                     nFolder: integer; fCreate: BOOL):HResult; stdcall;

implementation

const
  shell32 = 'shell32.dll';

function SHGetSpecialFolderPath; external 
                                 shell32 name 'SHGetSpecialFolderPathA';

end.
///////////////////////////////////////////////////////////////////////////
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, 
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Edit1: TEdit;
    Edit2: TEdit;
    Edit3: TEdit;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses
  ShlObj, ActiveX, ComObj, Urlmon, IE4;

function GetInterface(out purl: IUniformResourceLocator; 
                      out ppf: IPersistFile): HResult;
var
  UnknownObject: IUnknown;
begin
  Result:= E_OUTOFMEMORY;
  UnknownObject:= CreateComObject(CLSID_InternetShortcut);
  if not Assigned(UnknownObject) then exit;
  purl:= UnknownObject as IUniformResourceLocator;
  ppf := UnknownObject as IPersistFile;
  if Assigned(purl) or Assigned(ppf) then
    Result:= S_OK;
end;

function IsShortcut(const swIntShortcutName: WideString): HResult;
begin
  Result:= IsValidURL(nil, PWideChar(swIntShortcutName), 0);
end;

function GetUrlFromIntShortcut(const szIntShortcutName: string): string;
var
  ppmem: IMalloc;
  purl: IUniformResourceLocator;
  ppf: IPersistFile;
  pstrURL: Pchar;
  swIntShortcutName: WideString;
begin
  Result:= '';
  swIntShortcutName:= szIntShortcutName;
  if FAILED(IsShortcut(swIntShortcutName)) or
     FAILED(GetInterface(purl, ppf)) then exit;
  if FAILED(ShGetMalloc(ppmem)) or
     FAILED(ppf.Load(PWideChar(swIntShortcutName), STGM_READ)) or
     FAILED(purl.GetURL(pstrURL)) then exit;
  if Assigned(pstrURL) then
  begin
    Result:= pstrURL;
    ppmem.Free(pstrURL);
  end;
end;

function SetUrlFromIntShortcut(const szIntShortcutName: 
                               string; szURL: string): HResult;
var
  ppmem: IMalloc;
  purl: IUniformResourceLocator;
  ppf: IPersistFile;
  swIntShortcutName: WideString;
begin
  Result:= E_OUTOFMEMORY;
  if FAILED(GetInterface(purl, ppf)) then exit;
  if FAILED(ShGetMalloc(ppmem)) or
    FAILED(purl.SetURL(pchar(szURL), IURL_SETURL_FL_USE_DEFAULT_PROTOCOL))
    then exit;
  swIntShortcutName:= szIntShortcutName +'.url';
  Result:= ppf.Save(PWideChar(swIntShortcutName), False);
end;

function UrlInvokeCommand(const szIntShortcutName: string): HResult;
var
  ppmem: IMalloc;
  purl: IUniformResourceLocator;
  ppf: IPersistFile;
  swIntShortcutName: WideString;
  purlici: PUrlinvokecommandinfo;
begin
  Result:= E_OUTOFMEMORY;
  swIntShortcutName:= szIntShortcutName;
  if FAILED(IsShortcut(swIntShortcutName)) or
     FAILED(GetInterface(purl, ppf)) then exit;
  if FAILED(ShGetMalloc(ppmem)) or
     FAILED(ppf.Load(PWideChar(swIntShortcutName), STGM_READ)) then exit;
  purlici:= ppmem.Alloc(sizeof(TUrlinvokecommandinfo));
  with purlici^ do begin
    dwcbSize:= sizeof(TUrlinvokecommandinfo);
    dwFlags:= IURL_INVOKECOMMAND_FL_USE_DEFAULT_VERB;
    hwndParent:= 0;
    pcszVerb:= '';
  end;
  Result:= purl.InvokeCommand(purlici);
  ppmem.Free(purlici);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  Edit1.text:= '';
  Edit2.text:= '';
end;

//  Edit1.textに インターネットショートカットのフルパスを
//  入れて Button1をクリックするとEdit2.textにURLが表示されます。

procedure TForm1.Button1Click(Sender: TObject);
begin
  if Edit1.text <> '' then
    Edit2.text:= GetUrlFromIntShortcut(Edit1.text);
end;

//  Edit1.textに インターネットショートカットのタイトルを
//  入れて Edit2.textにURLを入力してButton２をクリックすると。
//  Edit１.textにフルパスが表示されてDESKTOPにインターネット
//  ショートカットができます。

procedure TForm1.Button2Click(Sender: TObject);
var
  SDir: pchar;
begin
  if (Edit1.text <> '') or (Edit2.text <> '') then
  begin
    SDir:= AllocMem(MAX_PATH);
    try
      if SUCCEEDED(SHGetSpecialFolderPath(0, SDir, CSIDL_DESKTOPDIRECTORY, 
                   False)) then
      begin
        Edit1.text:= SDir +'\'+ Edit1.text;
        if  SUCCEEDED(SetUrlFromIntShortcut(Edit1.text, Edit2.text)) then
          Edit3.text:= 'SUCCEEDED' else
          Edit3.text:= 'FAILED';
      end;
    finally
      FreeMem(SDir);
    end;
  end;
end;

//  Edit1.textに インターネットショートカットのフルパスを
//  入れて Button3をクリックするとブラウザが起動します。

procedure TForm1.Button3Click(Sender: TObject);
begin
  if SUCCEEDED(UrlInvokeCommand(Edit1.text)) then
    Edit3.text:= 'SUCCEEDED' else
    Edit3.text:= 'FAILED';
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
  Edit1.text:= '';
  Edit2.text:= '';
end;

end.
//////////////////////////////////////////////////////////////////////

でわ〜でわ〜
                                   by ヒシアマゾン
                                   BXC05221@niftyserve.or.jp
                                   ken_fu@mx4.meshnet.or.jp

Original document by ヒシアマゾン    氏 ID:(BXC05221)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。
Copyright 1996-2002 Delphi Users' Forum