Difference between revisions of "Windows Programming Tips"

From Free Pascal wiki
(New page: This page is dedicated to desktop Windows programming tips. __TOC__ {{Other Interfaces}} ==Code snipets== ===Listing all available drives=== <delphi> program listdevices; {$ifdef fpc...)
 
(Added Windows shortcut/.lnk code from forum: http://lazarus.freepascal.org/index.php/topic,13845.msg72867.html#msg72867)
Line 5: Line 5:
 
{{Other Interfaces}}
 
{{Other Interfaces}}
  
==Code snipets==
+
==Code snippets==
  
 
===Listing all available drives===
 
===Listing all available drives===
Line 44: Line 44:
 
   ReadLn(DriveLetter);
 
   ReadLn(DriveLetter);
 
end.
 
end.
 +
</delphi>
 +
 +
===Creating a shortcut (.lnk) file===
 +
<delphi>
 +
UNIT shortcut;
 +
 +
INTERFACE
 +
 +
  uses windows;
 +
 +
  FUNCTION createShortcut(lnkpos : widestring; dstfn,dstargs,dstwdir,descr,iconfn : AnsiString; iconnum : longint) : boolean;
 +
 +
  // create a windows shortcut file (*.lnk)@lnkpos.
 +
  // example: createSohrtcut('c:\test.lnk','c:\pascal\myprog.exe','-L 1000','c:\pascal','A nice Program.','c:\pascal\myprog.exe',0);
 +
 +
IMPLEMENTATION
 +
 +
TYPE
 +
REFCLSID = PGUID;
 +
REFIID  = PGUID;
 +
 +
CONST
 +
CLSID_ShellLink  : TGUID = '{00021401-0000-0000-C000-000000000046}';
 +
IID_IShellLink  : TGUID = '{000214EE-0000-0000-C000-000000000046}';
 +
IID_IPersistFile : TGUID = '{0000010b-0000-0000-C000-000000000046}';
 +
CLSCTX_INPROC_SERVER = 1;
 +
 +
FUNCTION CoInitialize(p : pointer) : HRESULT; stdcall;  external 'ole32.dll';
 +
FUNCTION CoUninitialize(p : pointer) : HRESULT; stdcall;  external 'ole32.dll';
 +
FUNCTION CoCreateInstance(a:REFCLSID; b:pointer; c:DWORD; d:REFIID; e:pointer)  : HRESULT; stdcall;  external 'ole32.dll';
 +
 +
TYPE
 +
PPISHellLink = ^PISHellLink;
 +
PISHellLink = ^ISHellLink;
 +
ISHellLink = packed record
 +
  QueryInterface : FUNCTION(basis,id,p : pointer) : Hresult; stdcall;
 +
  AddRef : FUNCTION(basis : pointer) : Hresult; stdcall;
 +
  Release : FUNCTION(basis : pointer) : Hresult; stdcall;
 +
  GetPath : pointer;
 +
  GetIDList : pointer;
 +
  SetIDList : pointer;
 +
  GetDescription : pointer;
 +
  SetDescription : FUNCTION(basis : pointer; descr : Pchar) : Hresult; stdcall;
 +
  GetWorkingDirectory : pointer;
 +
  SetWorkingDirectory : FUNCTION(basis : pointer; descr : Pchar) : Hresult; stdcall;
 +
  GetArguments : pointer;
 +
  SetArguments : FUNCTION(basis : pointer; args : Pchar) : Hresult; stdcall;
 +
  GetHotkey : pointer;
 +
  SetHotkey : pointer;
 +
  GetShowCmd : pointer;
 +
  SetShowCmd : pointer;
 +
  GetIconLocation : pointer;
 +
  SetIconLocation : FUNCTION(basis : pointer; iconfile : Pchar; icon : longint) : Hresult; stdcall;
 +
  SetRelativePath : pointer;
 +
  Resolve : pointer;
 +
  SetPath : FUNCTION(basis : pointer; path : Pchar) : Hresult; stdcall;
 +
end;
 +
 +
PPIPersistFile = ^PIPersistFile;
 +
PIPersistFile  = ^IPersistFile;
 +
IPersistFile  = packed record
 +
  QueryInterface : FUNCTION(basis,id,p : pointer) : Hresult; stdcall;
 +
  AddRef : FUNCTION(basis : pointer) : Hresult; stdcall;
 +
  Release : FUNCTION(basis : pointer) : Hresult; stdcall;
 +
  GetClassID : FUNCTION(basis,p : pointer) : Hresult; stdcall;
 +
  IsDirty : FUNCTION(basis : pointer) : Hresult; stdcall;
 +
  Load : FUNCTION(basis : pointer; fn : Pchar; dw : dword) : Hresult; stdcall;
 +
  Save : FUNCTION(basis : pointer; fn : Pchar; dw : dword) : Hresult; stdcall;
 +
  SaveCompleted : FUNCTION(basis : pointer; fn : Pchar) : Hresult; stdcall;
 +
  GetCurFile : FUNCTION(basis : pointer; fn : PPchar) : Hresult; stdcall;
 +
end;
 +
 +
 +
FUNCTION createShortcut(lnkpos : widestring; dstfn,dstargs,dstwdir,descr,iconfn : AnsiString; iconnum : longint) : boolean;
 +
VAR psl : PPISHellLink; psp : PPIPersistFile;
 +
BEGIN
 +
  createShortcut := FALSE;
 +
  if CoCreateInstance(@CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,@IID_IShellLink,@psl)=0 then begin
 +
//    writeln('got IShellLink');
 +
    if  (psl^^.setPath(psl,@dstfn[1])=0)
 +
    and (psl^^.SetArguments(psl,@dstargs[1])=0)
 +
    and (psl^^.SetWorkingDirectory(psl,@dstwdir[1])=0)
 +
    and (psl^^.SetDescription(psl,@descr[1])=0)
 +
    and (psl^^.SetIconLocation(psl,@iconfn[1],iconnum)=0)
 +
    and (psl^^.queryInterface(psl,@IID_IPersistFile,@psp)=0) then begin
 +
      if psp^^.save(psp,@lnkpos[1],0)=0 then createShortcut := true; 
 +
      psp^^.release(psp);
 +
    end;
 +
    psl^^.Release(psl);
 +
  end;
 +
END;
 +
 +
BEGIN
 +
  CoInitialize(nil);
 +
END.
 
</delphi>
 
</delphi>

Revision as of 10:43, 16 July 2011

This page is dedicated to desktop Windows programming tips.

Other Interfaces

Platform specific Tips

Interface Development Articles

Code snippets

Listing all available drives

<delphi> program listdevices;

{$ifdef fpc}{$mode delphi}{$endif} {$apptype console}

uses

 Windows;

var

 Drive: Char;
 DriveLetter: string;

begin

 WriteLn('The following drives were found in this computer:');
 WriteLn();
 // Search all drive letters
 for Drive := 'A' to 'Z' do
 begin
   DriveLetter := Drive + ':\';
  
   case GetDriveType(PChar(DriveLetter)) of
    DRIVE_REMOVABLE: WriteLn(DriveLetter + ' Floppy Drive');
    DRIVE_FIXED:     WriteLn(DriveLetter + ' Fixed Drive');
    DRIVE_REMOTE:    WriteLn(DriveLetter + ' Network Drive');
    DRIVE_CDROM:     WriteLn(DriveLetter + ' CD-ROM Drive');
    DRIVE_RAMDISK:   WriteLn(DriveLetter + ' RAM Disk');
   end;
 end;
 // Also add a stop to see the result under Windows
 WriteLn();
 WriteLn('Please press <ENTER> to exit the program.');
 ReadLn(DriveLetter);

end. </delphi>

Creating a shortcut (.lnk) file

<delphi> UNIT shortcut;

INTERFACE

 uses windows;
 FUNCTION createShortcut(lnkpos : widestring; dstfn,dstargs,dstwdir,descr,iconfn : AnsiString; iconnum : longint) : boolean;
 // create a windows shortcut file (*.lnk)@lnkpos.
 // example: createSohrtcut('c:\test.lnk','c:\pascal\myprog.exe','-L 1000','c:\pascal','A nice Program.','c:\pascal\myprog.exe',0);

IMPLEMENTATION

TYPE REFCLSID = PGUID; REFIID = PGUID;

CONST CLSID_ShellLink  : TGUID = '{00021401-0000-0000-C000-000000000046}'; IID_IShellLink  : TGUID = '{000214EE-0000-0000-C000-000000000046}'; IID_IPersistFile : TGUID = '{0000010b-0000-0000-C000-000000000046}'; CLSCTX_INPROC_SERVER = 1;

FUNCTION CoInitialize(p : pointer) : HRESULT; stdcall; external 'ole32.dll'; FUNCTION CoUninitialize(p : pointer) : HRESULT; stdcall; external 'ole32.dll'; FUNCTION CoCreateInstance(a:REFCLSID; b:pointer; c:DWORD; d:REFIID; e:pointer)  : HRESULT; stdcall; external 'ole32.dll';

TYPE PPISHellLink = ^PISHellLink; PISHellLink = ^ISHellLink; ISHellLink = packed record

 QueryInterface : FUNCTION(basis,id,p : pointer) : Hresult; stdcall;
 AddRef : FUNCTION(basis : pointer) : Hresult; stdcall;
 Release : FUNCTION(basis : pointer) : Hresult; stdcall;
 GetPath : pointer;
 GetIDList : pointer;
 SetIDList : pointer;
 GetDescription : pointer;
 SetDescription : FUNCTION(basis : pointer; descr : Pchar) : Hresult; stdcall;
 GetWorkingDirectory : pointer;
 SetWorkingDirectory : FUNCTION(basis : pointer; descr : Pchar) : Hresult; stdcall;
 GetArguments : pointer;
 SetArguments : FUNCTION(basis : pointer; args : Pchar) : Hresult; stdcall;
 GetHotkey : pointer;
 SetHotkey : pointer;
 GetShowCmd : pointer;
 SetShowCmd : pointer;
 GetIconLocation : pointer;
 SetIconLocation : FUNCTION(basis : pointer; iconfile : Pchar; icon : longint) : Hresult; stdcall;
 SetRelativePath : pointer;
 Resolve : pointer;
 SetPath : FUNCTION(basis : pointer; path : Pchar) : Hresult; stdcall;

end;

PPIPersistFile = ^PIPersistFile; PIPersistFile = ^IPersistFile; IPersistFile = packed record

 QueryInterface : FUNCTION(basis,id,p : pointer) : Hresult; stdcall;
 AddRef : FUNCTION(basis : pointer) : Hresult; stdcall;
 Release : FUNCTION(basis : pointer) : Hresult; stdcall;
 GetClassID : FUNCTION(basis,p : pointer) : Hresult; stdcall;
 IsDirty : FUNCTION(basis : pointer) : Hresult; stdcall;
 Load : FUNCTION(basis : pointer; fn : Pchar; dw : dword) : Hresult; stdcall;
 Save : FUNCTION(basis : pointer; fn : Pchar; dw : dword) : Hresult; stdcall;
 SaveCompleted : FUNCTION(basis : pointer; fn : Pchar) : Hresult; stdcall;
 GetCurFile : FUNCTION(basis : pointer; fn : PPchar) : Hresult; stdcall;

end;


FUNCTION createShortcut(lnkpos : widestring; dstfn,dstargs,dstwdir,descr,iconfn : AnsiString; iconnum : longint) : boolean; VAR psl : PPISHellLink; psp : PPIPersistFile; BEGIN

 createShortcut := FALSE;
 if CoCreateInstance(@CLSID_ShellLink,nil,CLSCTX_INPROC_SERVER,@IID_IShellLink,@psl)=0 then begin

// writeln('got IShellLink');

   if  (psl^^.setPath(psl,@dstfn[1])=0)
   and (psl^^.SetArguments(psl,@dstargs[1])=0)
   and (psl^^.SetWorkingDirectory(psl,@dstwdir[1])=0)
   and (psl^^.SetDescription(psl,@descr[1])=0)
   and (psl^^.SetIconLocation(psl,@iconfn[1],iconnum)=0)
   and (psl^^.queryInterface(psl,@IID_IPersistFile,@psp)=0) then begin
     if psp^^.save(psp,@lnkpos[1],0)=0 then createShortcut := true;   
     psp^^.release(psp);
   end;
   psl^^.Release(psl);
 end;

END;

BEGIN

 CoInitialize(nil);

END. </delphi>