UD_APIs.rc

#include "./utils/rc_cnst.h"

MainIcon ICON "./Utils/cubes.ico"

1 VERSIONINFO
FILETYPE VFT_APP
FILEOS VOS__WINDOWS32
FILEFLAGS VS_FF_PRERELEASE | VS_FF_PRIVATEBUILD
FILEFLAGSMASK VS_FILEFLAGSMASK
FILEVERSION  2,  0,  0,  1
PRODUCTVERSION  2,  0,  0,  1
BEGIN
    BLOCK "StringFileInfo"
    BEGIN
        BLOCK "040C04E4"
        BEGIN
            VALUE "Comments", "Exécutable 'API Windows non-documentées' avec feuille de propriétés\r\n\r\nVersion universelle définitive 9xME/NT/2000/XP compilable sous Win9x avec GWindows installé en ANSI (make ANSI=1 install)"
            VALUE "CompanyName", "LE NOM DE VOTRE SOCIÉTÉ"
            VALUE "FileDescription", "Appel des API non documentées de SHELL32.DLL"
            VALUE "FileVersion", "2.0.0"
            VALUE "InternalName", "Appel des API non documentées de SHELL32.DLL par leur ordinal"
            VALUE "LegalCopyright", "\251 Henri HAAR"
            VALUE "LegalTrademarks", "H&H"
            VALUE "OriginalFilename", "UD_APIs.exe"
            VALUE "PrivateBuild", "Appel des API non documentées de SHELL32.DLL par leur ordinal avec définitions personnelles du fichier .DEF"
            VALUE "ProductName", "UD_APIs"
            VALUE "ProductVersion", "2.0.0"
            VALUE "SpecialBuild", "Compilateur Ada 95 :\r\nGNAT 3.14p\r\n\r\nBindings Win32 :\r\nGnatCOM et GWindows\r\n\r\nCompilateur de ressources :\r\nGRC.exe (rsxdj151)\r\n\r\nCompresseur d'exécutables :\r\nUPX 1.20"
            /* Valeurs personnelles */
            VALUE "Système d'exploitation", "Windows 95/98/98SE/ME - NT4/2000/XP"
        END
    END
    BLOCK "VarFileInfo"
    BEGIN
        VALUE "Translation",  1036,  1252
    END
END

UD_Shell32.adb

with Ada.Characters.Latin_1;
with Ada.Characters.Handling;      use Ada.Characters.Handling;

package body UD_Shell32 is
-------------------------------------------------------------------------------------------------
   procedure SHRestartSystemMB  (Win       : in GWindows.Base.Base_Window_Type'Class;
                                 Prompt    : String     := "";
                                 How       : Scenario   := SHReBoot) is
      Result  : Interfaces.C.long;
      HowFlag : Interfaces.C.unsigned;
   begin
      case How is
         when SHLogOff   =>
            HowFlag := LogOff;
         when SHShutDown =>
            HowFlag := ShutDown;
         when SHReBoot   =>
            HowFlag := ReBoot;
         when SHForce    =>
            HowFlag := Force;
         when SHPowerOff =>
            HowFlag := PowerOff;
      end case;
      if IsWin9x then
         Result := SHRestartSystemMBA (hwnd    => GWindows.Base.Handle (Win),
                                       PromptA => To_C (Prompt),
                                       Flags   => HowFlag);
      else
         Result := SHRestartSystemMBW (hwnd    => GWindows.Base.Handle (Win),
                                       PromptW => To_C (To_Wide_String(Prompt)),
                                       Flags   => HowFlag);
      end if;
   end SHRestartSystemMB;
  
   procedure SHRestartSystemMB  (Prompt     : String     := "";
                                 How        : Scenario   := SHReBoot) is
      Tmp_Win : GWindows.Base.Base_Window_Type;
   begin
      SHRestartSystemMB (Tmp_Win, Prompt, How);
   end SHRestartSystemMB;
-------------------------------------------------------------------------------------------------

   procedure SHShutDownDialog is
      Result  : Interfaces.C.long;
   begin
      Result := SHShutDownDialogAW (DeskTopHwnd);
   end SHShutDownDialog;
-------------------------------------------------------------------------------------------------  
   procedure SHRunDialog        (Win        : in GWindows.Base.Base_Window_Type'Class;
                                 IconName   : in String        := "";
                                 Directory  : in String        := GetEnv ("WinDir").all;
                                 Title      : in String        := "";
                                 Comment    : in String        := "";
                                 FlagArray  : in RunFlagArray  := (Others => False)) is
      Result  : Interfaces.C.long;
      HowFlag : Interfaces.C.unsigned := 0;
   begin
      for i in RunFlag loop
         if FlagArray(i) and then i /= SHNo_SeparateMem then
            HowFlag := HowFlag + 2 ** RunFlag'Pos(i);
            -- Voir les déclarations de
            -- No_Browse, No_MRU, Relative_Path & No_Label
            -- dans la partie privée de UD_Shell32.ads
         elsif FlagArray(i) and then i = SHNo_SeparateMem then
            HowFlag := HowFlag + No_SeparateMem;-- idem pour No_SeparateMem
         end if;
      end loop;
      if IsWin9x then
         Result := SHRunDialogA    (hwnd       => GWindows.Base.Handle (Win),
                                    hicon      => LoadIcon (hinst, To_C (IconName)),
                                    DirectoryA => To_C (Directory),
                                    TitleA     => To_C (Title),
                                    CommentA   => To_C (Comment),
                                    Flags      => HowFlag);
      else
         Result := SHRunDialogW    (hwnd       => GWindows.Base.Handle (Win),
                                    hicon      => LoadIcon (hinst, To_C (IconName)),
                                    DirectoryW => To_C (To_Wide_String(Directory)),
                                    TitleW     => To_C (To_Wide_String(Title)),
                                    CommentW   => To_C (To_Wide_String(Comment)),
                                    Flags      => HowFlag);
      end if;
   end SHRunDialog;
                                
   procedure SHRunDialog        (IconName   : in String        := "";
                                 Directory  : in String        := GetEnv ("WinDir").all;
                                 Title      : in String        := "";
                                 Comment    : in String        := "";
                                 FlagArray  : in RunFlagArray  := (Others => False)) is
      Tmp_Win : GWindows.Base.Base_Window_Type;
   begin
      SHRunDialog (Tmp_Win, IconName, Directory, Title, Comment, FlagArray);
   end SHRunDialog;
-------------------------------------------------------------------------------------------------
   procedure SHObjectProperties (Win        : in GWindows.Base.Base_Window_Type'Class;
                                 Target     : in SHObj_Type   := SHFile;
                                 Path_FName : in String;
                                 TabName    : in String) is
      Result      : Interfaces.C.long;
      Target_ID   : Interfaces.C.unsigned;
   begin
      Target_ID := SHObj_Type'Pos(Target) + 1;-- Voir les déclarations de Printer & File  
                                              -- dans la partie privée de UD_Shell32.ads
      if IsWin9x then
         Result := SHObjectPropertiesA (hwnd    => GWindows.Base.Handle (Win),
                                        uFlags  => Target_ID,
                                        sNameA  => To_C (Path_FName),
                                        sParamA => To_C (TabName));
      else
         Result := SHObjectPropertiesW (hwnd    => GWindows.Base.Handle (Win),
                                        uFlags  => Target_ID,
                                        sNameW  => To_C (To_Wide_String(Path_FName)),
                                        sParamW => To_C (To_Wide_String(TabName)));
      end if;
   end SHObjectProperties;
  
   procedure SHObjectProperties (Target     : in SHObj_Type   := SHFile;
                                 Path_FName : in String;
                                 TabName    : in String) is
      Tmp_Win : GWindows.Base.Base_Window_Type;
   begin
      SHObjectProperties (Tmp_Win, Target, Path_FName, TabName);
   end SHObjectProperties;
-------------------------------------------------------------------------------------------------
   procedure SHChangeIconDialog (Win           : in      GWindows.Base.Base_Window_Type'Class;
                                 IconFile      : in out  SHString_Access;
                                 SystemDir     : in      Boolean :=True;
                                 NumIcon       : in out  Integer;
                                 Cancel        : out     Boolean) is
      GSysDir         : GString_C (1..Max_Path);
      SysDir_length   : Interfaces.C.size_t := GetSystemDirectory(GSysDir, Max_Path);
      SysDir_DLL      : String              := "\" & IconFile.all;
      NoSysDir_DLL    : String              := IconFile.all;
      SysDir_Rest     : Integer             := Integer (Max_Path - SysDir_length - SysDir_DLL'Length);
      NoSysDir_Rest   : Integer             := Integer (Max_Path - NoSysDir_DLL'Length);
      Rest            : Integer;
      EndString       : SHString_Access;
      InitialNumIcon  : Interfaces.C.long   := Interfaces.C.long(NumIcon);
      pragma Warnings (off, GSysDir);
   begin
      if SystemDir then
         Rest       := SysDir_Rest;
      else
         Rest       := NoSysDir_Rest;
      end if;
      EndString     := new String(1..Rest);
      EndString.all := (others => Ada.Characters.Latin_1.nul);
      declare
         type NumIcon_Pointer_Type is access Interfaces.C.long;
         type IconFile_Pointer_Type is access char_array;   -- pour la version ANSI
         type wIconFile_Pointer_Type is access wchar_array; -- pour la version UNICODE
         NumIcon_Pointer : NumIcon_Pointer_Type := new Interfaces.C.long'(InitialNumIcon);
         IntSysDir_length: Integer := Integer(SysDir_length);
         SysDir          : String (1..IntSysDir_length);
         Local_IconFile  : SHString_Access;
         Result          : Interfaces.C.long;
         IconFileA       : IconFile_Pointer_Type;
         IconFileW       : wIconFile_Pointer_Type;
      begin
         if SystemDir then
            SysDir         := To_Ada (GSysDir(1..SysDir_length), False);
            Local_IconFile := new String'(SysDir & SysDir_DLL & EndString.all);
         else
            Local_IconFile := new String'(NoSysDir_DLL & EndString.all);
         end if;
         if IsWin9x then
            IconFileA := new char_array'(To_C(Local_IconFile.all, False));
            Result := SHChangeIconDialogA (hwnd      => GWindows.Base.Handle (Win),
                                           FileNameA => IconFileA.all,
                                           nMaxFile  => Interfaces.C.long (Max_Path),
                                           IconIndex => NumIcon_Pointer);

            Iconfile := new String'(To_Ada (IconFileA.all));
         else
            IconFileW := new wchar_array'(To_C(To_Wide_String(Local_IconFile.all), False));
            Result := SHChangeIconDialogW (hwnd      => GWindows.Base.Handle (Win),
                                           FileNameW => IconFileW.all,
                                           nMaxFile  => Interfaces.C.long (Max_Path),
                                           IconIndex => NumIcon_Pointer);

            Iconfile := new String'(To_String(To_Ada (IconFileW.all)));
         end if;
         NumIcon  := Integer (NumIcon_Pointer.all);
         case Result is
            when gwCancel => Cancel := True;
            when others   => Cancel := False;
         end case;
      end;
   end SHChangeIconDialog;
                            
   procedure SHChangeIconDialog (IconFile      : in out  SHString_Access;
                                 SystemDir     : in      Boolean :=True;
                                 NumIcon       : in out  Integer;
                                 Cancel        : out     Boolean) is
      Tmp_Win : GWindows.Base.Base_Window_Type;
   begin
      SHChangeIconDialog (Tmp_Win, IconFile, SystemDir, NumIcon, Cancel);
   end SHChangeIconDialog;
-------------------------------------------------------------------------------------------------
   function IsWin9x return Boolean is
      OVI      : aliased OSVERSIONINFO;
      LP_OVI   : LPOSVERSIONINFO := OVI'Unrestricted_Access;
      Result   : Interfaces.C.int;
   begin
      LP_OVI.dwOSVersionInfoSize := OSVERSIONINFO'size / 8;
      Result := GetVersionEx (LP_OVI);
      return LP_OVI.dwPlatformId = OVI_Win9x;
   end IsWin9x;
  
end UD_Shell32;                               

UD_APIs.adb

with Ada.Characters.Latin_1;  use Ada.Characters.Latin_1;
with GNAT.OS_Lib;
with GWindows.Windows.Main;   use GWindows.Windows.Main;
with GWindows.Application;
with GWindows.Buttons;        use GWindows.Buttons;
with GWindows.Base;           use GWindows.Base;
with GWindows.Packing_Boxes;  use GWindows.Packing_Boxes;
with GWindows.Message_Boxes;  use GWindows.Message_Boxes;

with UD_Shell32;
with Use_GUI_Fonts;

procedure UD_APIs is

   pragma Linker_Options ("-mwindows", "UD_APIs.coff", "-s");
   
   procedure Do_RestartSystemMB (Window : in out Base_Window_Type'Class ) is
      use UD_Shell32;
   begin
      SHRestartSystemMB  (Win       => Window,
                          Prompt    => "Alors, on redémarre ?" & LF & LF,
                          How       => SHReBoot);
   end Do_RestartSystemMB ;

  
   procedure Do_ShutDownDialog (Window : in out Base_Window_Type'Class ) is
      pragma Warnings (off, Window);
   begin
      UD_Shell32.SHShutDownDialog;
   end Do_ShutDownDialog;

  
   procedure Do_RunDialog (Window    : in out Base_Window_Type'Class ) is
      pragma Warnings (off, Window);
      use UD_Shell32;
   begin
      SHRunDialog  (IconName  => "MainIcon",
                    Title     => "Exécuter mon petit programme...",
                    Comment   => "N'importe quel blabla explicatif " &
                                 "servant à documenter cette boîte de dialogue personnalisée.",
                    FlagArray => RunFlagArray'(SHNo_MRU | SHRelative_Path => True, others => False));
                    -- voir dans UD_Shell32.ads pour Flags
   end Do_RunDialog;

   InSystemDir   : Boolean := True;
   Icon          : Integer := 2;
  
   procedure Do_ChangeIconDialog (Window    : in out Base_Window_Type'Class ) is
      use UD_Shell32;
      SysIconFile   : SHString_Access := new String'("pifmgr.dll");
      MyIconFile    : SHString_Access := new String'(GNAT.OS_Lib.GetEnv ("WinDir").all & "\Explorer.exe");
      IsCanceled    : Boolean;
   begin
      if InSystemDir then
         SHChangeIconDialog (Win        => Window,
                             IconFile   => SysIconFile,
                             SystemDir  => InSystemDir,
                             NumIcon    => Icon,
                             Cancel     => IsCanceled);
      else
         SHChangeIconDialog (Win        => Window,
                             IconFile   => MyIconFile,
                             SystemDir  => InSystemDir,
                             NumIcon    => Icon,
                             Cancel     => IsCanceled);
      end if;     
      if not IsCanceled Then
            if InSystemDir then
               Message_Box (Window   => Window,
                            Title    => "Icône choisie...",
                            Text     => "Fichier : " & SysIconFile.all & LF & LF &
                                        "Numéro d'icône : " & Icon'Img,
                            Icon     => Information_Icon);
               InSystemDir := False;
               Icon        := 5;        
            else
               Message_Box (Window   => Window,
                            Title    => "Icône choisie...",
                            Text     => "Fichier : " & MyIconFile.all & LF & LF &
                                        "Numéro d'icône : " & Icon'Img,
                            Icon     => Information_Icon);
               InSystemDir := True;
               Icon        := 2;
            end if;
      end if;
   end Do_ChangeIconDialog;
  
   procedure Do_ObjectProperties (Window : in out Base_Window_Type'Class ) is
      pragma Warnings (off, Window);
   begin
      UD_Shell32.SHObjectProperties (Target      => UD_Shell32.SHFile,
                                     Path_FName  => GNAT.OS_Lib.GetEnv ("WinDir").all & "\Explorer.exe",
                                     TabName     => "Version");
   end Do_ObjectProperties;

  
   Main_Window               : Main_Window_Type;
   RestartSystemMB_Button    : Button_Type;
   ShutDownDialog_Button     : Button_Type;
   RunDialog_Button          : Button_Type;
   ChangeIconDialog_Button   : Button_Type;
   ObjectProperties_Button   : Button_Type;
   Box                       : Packing_Box_Type;
  
begin
   Create (Main_Window, "API Windows non-documentées", Width => 300, Height => 270);
   Small_Icon (Main_Window, "MainIcon");
   Large_Icon (Main_Window, "MainIcon");

   Keyboard_Support (Main_Window);
   Use_GUI_Fonts.Set_Gui_Font (Main_Window);

   Center (Main_Window);
   Visible (Main_Window, True);
  
   Create (Box, Main_Window, 0, 0, 0, 0, Vertical);
   Dock (Box, GWindows.Base.Fill);
   Fill_Width (Box);
   Fill_Height (Box);
   Padding (Box, 10);
   Insets (Box, (20, 20, 20, 20));
   Dock_Children (Main_Window);
  
   Create (RestartSystemMB_Button, Box,
           "Boîte de dialogue '&Redémarrage de Windows'", 0, 0, 0, 0);
   Create (ShutDownDialog_Button, Box,
           "Boîte de dialogue 'Arrê&t de Windows'", 0, 0, 0, 0);
   Create (RunDialog_Button, Box,
           "E&xécuter", 0, 0, 0, 0);
   Create (ChangeIconDialog_Button, Box,
           "C&hanger d'icône", 0, 0, 0, 0);
   Create (ObjectProperties_Button, Box,
           "&Feuille de propriétés", 0, 0, 0, 0);

   Pack (Box);
   Focus (ObjectProperties_Button);

   On_Click_Handler (RestartSystemMB_Button, Do_RestartSystemMB'Unrestricted_Access);
   On_Click_Handler (ShutDownDialog_Button, Do_ShutDownDialog'Unrestricted_Access);
   On_Click_Handler (RunDialog_Button, Do_RunDialog'Unrestricted_Access);
   On_Click_Handler (ChangeIconDialog_Button, Do_ChangeIconDialog'Unrestricted_Access);
   On_Click_Handler (ObjectProperties_Button, Do_ObjectProperties'Unrestricted_Access);
  
   GWindows.Application.Message_Loop;

end UD_APIs;