Accueil
Accueil Le Club Delphi Kylix C C++ Java J2EE DotNET & C# Visual Basic Access Pascal Dev Web PHP ASP XML UML SQLSGBD Windows Linux Autres
logo
Sommaire > Windows
        Exemple d'utilisation de GDI+
        Connexion automatique sur un forum
        Fenêtre non cliquable (API Windows)
        ToolTip de la barre d'outils personnalisé (API)
        Comment connaître la fenêtre ayant le focus ?
        Animation sur le bureau (Inutile mais amusant)
        Procédure pour afficher les WM_xxxx des messages Window
        Lecture des adresses URL des navigateurs Internet exploreur ou Firefox.
        Utilisation des interfaces IShellFolder et IEnumIDList pour afficher le contenu d'un dossier
precedent    sommaire    suivant   

Auteur : Flype
Version : 20/02/2008
Exemple d'utilisation de GDI+

; test gdiplus.lib for pb4, flype, jul 2006
; http://msdn.microsoft.com/library/default.asp?url=/library/en-us/gdicpp/GDIPlus/GDIPlusreference.asp

Import "gdiplus.lib"
 
  ; init
  GdiplusStartup(*token, *input, *output)
  GdiplusShutdown(*token)
  GdipAlloc(Size.l)
  GdipFree(*ptr)
 
  ; codec
  GdipGetImageEncoders(numDecoders.l, Size.l, *decoders)
  GdipGetImageEncodersSize(*numDecoders, *Size)
  GdipGetImageDecoders(numDecoders.l, Size.l, *decoders)
  GdipGetImageDecodersSize(*numDecoders, *Size)
 
  ; graphic
  GdipCreateFromHDC(*hDC, *graphics)
  GdipDeleteGraphics(*graphics)
  GdipSetSmoothingMode(*graphics, Mode.l)
  GdipGraphicsClear(*graphics, color.l)
  GdipDrawBezier(*graphics, *Pen, x1.f, y1.f, x2.f, y2.f, x3.f, y3.f, x4.f, y4.f)
  GdipDrawLineI(*graphics, *Pen, x1.l, y1.l, x2.l, y2.l)
  GdipDrawEllipseI(*graphics, *Pen, x.l, y.l, Width.l, Height.l)
  GdipDrawString(*graphics, string.p-unicode, length.l, *Font, *layoutRect, *stringFormat, *Brush)
 
  ; font
  GdipCreateFont(*FontFamily, emSize.f, style.l, unit.l, *Font)
  GdipCreateFontFamilyFromName(FontName.p-unicode, *FontCollection, *FontFamily)
  GdipDeleteFontFamily(*FontFamily)
  GdipDeleteFont(*Font)
 
  ; brush
  GdipCreateHatchBrush(hatchstyle.l, forecol.l, backcol.l, *Brush)
  GdipCreateSolidFill(color.l, *Brush)
  GdipGetBrushType(*Brush, Type.l)
  GdipDeleteBrush(*Brush)
 
  ; pen
  GdipCreatePen1(color.l, Width.f, unit.l, *Pen)
  GdipCreatePen2(Brush.l, Width.f, unit.l, *Pen)
  GdipSetPenStartCap(*Pen, customCap.l)
  GdipSetPenEndCap(*Pen, customCap.l)
  GdipDeletePen(*Pen)
 
EndImport

Structure RectF
  left.f
  top.f
  Width.f
  Height.f
EndStructure
Structure ImageCodecInfo
  clsid.CLSID
  FormatID.GUID
  *CodecName;.s
  *DllName;.s
  *FormatDescription;.s
  *FilenameExtension;.s
  *MimeType;.s
  flags.l
  Version.l
  SigCount.l
  SigSize.l
  *SigPattern
  *SigMask
EndStructure
Structure GdipStartupInput
  GdiPlusVersion.l
  DebugEventCallback.l
  SuppressBackgroundThread.l
  SuppressExternalCodecs.l
EndStructure

Enumeration 0 ; BrushType
  #BrushTypeSolidColor
  #BrushTypeHatchFill
  #BrushTypeTextureFill
  #BrushTypePathGradient
  #BrushTypeLinearGradient
EndEnumeration
Enumeration 0 ; FontStyle
  #FontStyleRegular    = 0
  #FontStyleBold       = 1
  #FontStyleItalic     = 2
  #FontStyleBoldItalic = 3
  #FontStyleUnderline  = 4
  #FontStyleStrikeout  = 8
EndEnumeration

Macro WCHAR(unicode)
  PeekS(unicode, -1, #PB_Unicode)
EndMacro
Macro ARGB(Alpha, RGB)
  (Blue(RGB)|Green(RGB)<<8|Red(RGB)<<16|Alpha<<24)
EndMacro

;-

Procedure.l SetRectF(*rect.RectF, x.f, y.f, w.f, h.f)
  *rect\left   = x
  *rect\top    = y
  *rect\Width  = w
  *rect\Height = h
EndProcedure

Procedure.l GdipImageDecoders()
 
  Protected num.l, Size.l
 
  GdipGetImageDecodersSize(@num, @Size)
 
  Dim info.ImageCodecInfo(Size/SizeOf(ImageCodecInfo))
 
  GdipGetImageDecoders(num, Size, @info(0))
 
  Debug "======================= DECODERS"
  For i = 0 To num - 1
    Debug WCHAR(info(i)\CodecName)
    Debug WCHAR(info(i)\MimeType)
    Debug "======================="
  Next
 
  ProcedureReturn num
 
EndProcedure
Procedure.l GdipImageEncoders()
 
  Protected num.l, Size.l
 
  GdipGetImageEncodersSize(@num, @Size)
 
  Dim info.ImageCodecInfo(Size/SizeOf(ImageCodecInfo))
 
  GdipGetImageEncoders(num, Size, @info(0))
 
  Debug "======================= ENCODERS"
  For i = 0 To num - 1
    Debug WCHAR(info(i)\CodecName)
    Debug WCHAR(info(i)\MimeType)
    Debug "======================="
  Next
 
  ProcedureReturn num
 
EndProcedure
Procedure.l GdipLine(*graphics, x1.l, y1.l, x2.l, y2.l, w.f, color.l, StartCap.l, EndCap.l)
  Protected *Pen
  GdipCreatePen1(color, w, 2, @*Pen)
  GdipSetPenStartCap(*Pen, StartCap)
  GdipSetPenEndCap(*Pen, EndCap)
  GdipDrawLineI(*graphics, *Pen, x1, y1, x2, y2)
  GdipDeletePen(*Pen)
EndProcedure
Procedure.l GdipBezier(*graphics, x1.f, y1.f, x2.f, y2.f, x3.f, y3.f, x4.f, y4.f, w.f, color.l, StartCap.l, EndCap.l)
  Protected *Pen
  GdipCreatePen1(color, w, 2, @*Pen)
  GdipSetPenStartCap(*Pen, StartCap)
  GdipSetPenEndCap(*Pen, EndCap)
  GdipDrawBezier(*graphics, *Pen, x1, y1, x2, y2, x3, y3, x4, y4)
  GdipDeletePen(*Pen)
EndProcedure
Procedure.l GdipEllipse(*graphics, x.l, y.l, w.l, h.l, color.l)
  Protected *Pen
  GdipCreatePen1(color, w, 0, @*Pen)
  GdipDrawEllipseI(*graphics, *Pen, x, y, w, h)
  GdipDeletePen(*Pen)
EndProcedure
Procedure.l GdipString(*graphics, string.s, x.l, y.l, w.l, h.l, fntName.s, fntSize.f, fntStyle.l, color1.l, color2.l)
  Protected *Family, *Font, *Brush, layout.RectF
  GdipCreateFontFamilyFromName(fntName, #Null, @*Family)
  GdipCreateFont(*Family, fntSize, fntStyle, 2, @*Font)
  GdipCreateHatchBrush(20, color1, color2, @*Brush)
  SetRectF(layout, x, y, w, h)
  GdipDrawString(*graphics, string, -1, *Font, layout, #Null, *Brush)
  GdipDeleteFontFamily(*Family)
  GdipDeleteFont(*Font)
  GdipDeleteBrush(*Brush)
EndProcedure

;-

Procedure.l myWindowCallback(*window, message.l, wParam.l, lParam.l)
 
  Protected result.l, *hDC, *graphics
 
  result = #PB_ProcessPureBasicEvents
 
  Select message
   
    Case #WM_MOUSEMOVE
      *hDC = StartDrawing(WindowOutput(0))
      If *hDC
        GdipCreateFromHDC(*hDC, @*graphics)
        GdipSetSmoothingMode(*graphics, 2)
        For i = 0 To 5
          GdipEllipse(*graphics, WindowMouseX(0)+Random(50)-25, WindowMouseY(0)+Random(50)-25, Random(30), Random(30), ARGB(10, #Gray))
        Next
        GdipDeleteGraphics(*graphics)
        StopDrawing()
      EndIf
     
    Case #WM_ERASEBKGND
      *hDC = StartDrawing(WindowOutput(0))
      If *hDC
        GdipCreateFromHDC(*hDC, @*graphics)
        GdipSetSmoothingMode(*graphics, 2)
        GdipGraphicsClear(*graphics, ARGB(255, $222222))
        GdipLine(*graphics, 550, 70, 20, 200, 20, ARGB(255, #Yellow), 18, 18)
        GdipLine(*graphics, 100, 50, 600, 200, 30, ARGB(127, #Green), 17, 2)
        GdipLine(*graphics, 600, 100, 80, 400, 40, ARGB(127, #Blue), 19, 19)
        GdipBezier(*graphics, 50, 50, 150, 60, 300, 250, 20, 500, 16, ARGB(127, #Red), 18, 18)
        GdipString(*graphics, "GDI+ 1.0 & PB4.0", 280, 280, 380, 200, "Arial", 80, #FontStyleBoldItalic|#FontStyleUnderline, ARGB(10, #Black), ARGB(80, #Blue))
        GdipDeleteGraphics(*graphics)
        StopDrawing()
      EndIf
     
  EndSelect
 
  ProcedureReturn result
 
EndProcedure

;-

Define *token, input.GdipStartupInput

input\GdiPlusVersion = 1
GdiplusStartup(@*token, @input, #Null)

GdipImageDecoders()
GdipImageEncoders()

If OpenWindow(0, 0, 0, 640, 480, "GdiPlus 1.0", #PB_Window_SystemMenu|#PB_Window_ScreenCentered)
  SetWindowCallback(@myWindowCallback(), 0)
  SendMessage_(WindowID(0), #WM_ERASEBKGND, 0, 0)
  Repeat
  Until WaitWindowEvent() = #PB_Event_CloseWindow
EndIf

GdiplusShutdown(*token)

;-

End

Auteur : Nico
Version : 09/03/2008
Connexion automatique sur un forum
Voici un exemple d'Auto Login sur un Forum, tout d'abord avant de faire une recherche sur les champs à remplir, le programme vérifie que la page présente un formulaire et que celui-ci correspond bien à ce qu'il attend, si c'est le cas alors il remplit les champs et valide.
Avant de le tester, renseignez les champs suivants :

  • AutoLogin()\Url= "http://www.developpez.net/forums/forumdisplay.php?f=911" ; Par défaut on se connecte au forum PureBasic de DVP
  • AutoLogin()\Nom= "mon identifiant" ; A remplir
  • AutoLogin()\Password= "mon mot de passe" ; A remplir
Informations
Dans la procédure ProcessDocument(*pDoc.IHTMLDocument2), *pDoc\get_forms(@*pElemColl.IHTMLElementCollection_FIXED) me permet d'obtenir un pointeur sur les parties du code HTML qui constituent un formulaire qui commence par : 

<form
Et finit par : 

</form>
Pour connaitre le nombre de formulaire de cette collection, j'appelle cette interface *pElemColl\get_length(@Number), ensuite *pElemColl\item(...) permet d'obtenir un pointeur sur l'interface Idispatch pour chaque formulaire.
Grâce à ce pointeur j'appelle une autre interface *pElemDisp\QueryInterface(?IID_IHTMLFormElement, @*pFormElement) pour avoir accès aux éléments contenus dans le formulaire.
*pFormElement\get_length(@Number) me donne le nombre d'éléments de ce formulaire
*pFormElement\item(...) permet d'obtenir un pointeur sur l'interface Idispatch pour chaque élément.
j'appelle ensuite *pElemDisp\QueryInterface(?IID_IHTMLInputElement, @*pInputElement) et j'obtiens un nouveau pointeur sur l'élément en question qui me permet d'entrer des données ou d'en extraire.

Cela fonctionne quel que soit le langage de la page. 

;----------------------------------------------------------------------------------
; Auto Login Forum
; PureBasic Version 4.10
; Ce code montre comment procéder pour remplir un formulaire
; de connexion d'accès à un Forum automatiquement
; Ce code n'est pas optimisé pour fonctionner sur des pages contenant des Frames
;----------------------------------------------------------------------------------
; Fonctionnement:
; Si l'URL de navigation correspond à un élément de la liste AutoLogin()
; on compte le nombre de <FORM> dans la page, puis
; pour chaque <FORM>, on comptabilise le nombre d'éléments ci dessous:
; <INPUT> de type text
; <INPUT> de type password
; <INPUT> de type submit
; Une <FORM> est considérée comme apte à recevoir les données si
; elle comptabilise ces 3 types mais une seule fois pour chacun d'entre eux
; et si le submit est placé à la fin de cette séquence
; La première <FORM> qui correspond à ces critères est alors remplie des données
; d'enregistrement et validée.
;----------------------------------------------------------------------------------

Enumeration
     #Main
     #Web
     #Status
     #Panel
     #Progress
EndEnumeration

Structure VARIANT_SPLIT
    StructureUnion
    Variant.VARIANT
    Split.l[4]
    EndStructureUnion
EndStructure

Interface IHTMLElementCollection_FIXED
    QueryInterface(a,b)
    AddRef()
    Release()
    GetTypeInfoCount(a)
    GetTypeInfo(a,b,c)
    GetIDsOfNames(a,b,c,d,e)
    Invoke(a,b,c,d,e,f,g,h)
    toString(a)
    put_length(a)
    get_length(a)
    get__newEnum(a)
    item(a1,a2,a3,a4,b1,b2,b3,b4,c)
    tags(a1,a2,a3,a4,b)
EndInterface

Interface IHTMLFormElement_Fixed
    QueryInterface(a, b)
    AddRef()
    Release()
    GetTypeInfoCount(a)
    GetTypeInfo(a, b, c)
    GetIDsOfNames(a, b, c, d, e)
    Invoke(a, b, c, d, e, f, g, h)
    put_action(a.p-bstr)
    get_action(a)
    put_dir(a.p-bstr)
    get_dir(a)
    put_encoding(a.p-bstr)
    get_encoding(a)
    put_method(a.p-bstr)
    get_method(a)
    get_elements(a)
    put_target(a.p-bstr)
    get_target(a)
    put_name(a.p-bstr)
    get_name(a)
    put_onsubmit(a.p-Variant)
    get_onsubmit(a)
    put_onreset(a.p-Variant)
    get_onreset(a)
    submit()
    reset()
    put_length(a)
    get_length(a)
    get__newEnum(a)
    item(a1,a2,a3,a4,b1,b2,b3,b4,c)
    tags(a.p-Variant, b)
EndInterface

Structure Login
    Url.s
    Nom.s
    Password.s
EndStructure

Global NewList AutoLogin.Login()
Global UserName.s,Password.s,WebBrowser.IWebBrowser2

AddElement (AutoLogin())
AutoLogin()\Url= "http://www.developpez.net/forums/forumdisplay.php?f=911"
AutoLogin()\Nom= " ;<--- A remplir
AutoLogin()\Password= " ;<--- A remplir

Procedure ProcessInputElement(*pFormElement.IHTMLFormElement_Fixed, Valid.l)
    Protected *pElemDisp.IDispatch = #Null
    Protected *pInputElement.IHTMLInputElement = #Null
    Protected *pElement.IHTMLElement= #Null
    Protected a.l,Number.l,varIndex.VARIANT_SPLIT
    Protected NbText.l,NbPassword.l,NbSubmit.l
    Protected hr.l,Submit.l
    
    varIndex\Variant\vt = #VT_I4
    
     If *pFormElement\get_length(@Number)= #S_OK
         For a= 0 To Number-1
            varIndex\Variant\lVal= a
            
            hr= *pFormElement\item(varIndex\Split[0], varIndex\Split[1], varIndex\Split[2], varIndex\Split[3], varIndex\Split[0], varIndex\Split[1], varIndex\Split[2], varIndex\Split[3], @*pElemDisp)
             If hr=0 And *pElemDisp>0
                hr=*pElemDisp\QueryInterface(?IID_IHTMLInputElement, @*pInputElement)
                 If hr=0 And *pInputElement>0
                    hr=*pInputElement\get_type(@*bstr)
                     If hr=0 And *bstr>0
                        Propriete.s= PeekS (*bstr,-1, #PB_Unicode )
                         SysFreeString_ (@*bstr)
                        
                         If Valid=0
                             If Propriete= "text"
                                NbText=NbText+1
                             ElseIf Propriete= "password"
                                NbPassword=NbPassword+1
                             ElseIf Propriete= "submit" And NbText=1 And NbPassword=1
                                NbSubmit=NbSubmit+1
                             EndIf
                         Else
                             If Propriete= "text"
                                *pInputElement\put_value(AutoLogin()\Nom)
                             ElseIf Propriete= "password"
                                *pInputElement\put_value(AutoLogin()\Password)
                             ElseIf Propriete= "submit"
                                 If *pElemDisp\QueryInterface(?IID_IHTMLElement, @*pElement.IHTMLElement)= #S_OK
                                    *pElement\Click()
                                    *pElement\Release()
                                    Submit= 1
                                    a= Number
                                 EndIf
                             EndIf
                         EndIf
                     EndIf
                    *pInputElement\Release()
                 EndIf
                *pElemDisp\Release()
             EndIf
         Next a
     EndIf
    
     If NbSubmit=1 And NbText=1 And NbPassword=1
         ProcedureReturn ProcessInputElement(*pFormElement,1)
     EndIf
    
     If Submit
         ProcedureReturn 1
     Else
         ProcedureReturn 0
     EndIf
EndProcedure

Procedure ProcessFormsCollection(*pElemColl.IHTMLElementCollection_FIXED)
    Protected *pElemDisp.IDispatch = #Null
    Protected *pFormElement.IHTMLFormElement_Fixed = #Null
    Protected a.l,Number.l,*bstr,varIndex.VARIANT_SPLIT
    Protected hr.l,Ret.l
    
    varIndex\Variant\vt = #VT_I4
    
     If *pElemColl\get_length(@Number)= #S_OK
         For a=0 To Number-1
            varIndex\Variant\lVal= a
            
            hr= *pElemColl\item(varIndex\Split[0], varIndex\Split[1], varIndex\Split[2], varIndex\Split[3], varIndex\Split[0], varIndex\Split[1], varIndex\Split[2], varIndex\Split[3], @*pElemDisp.IDispatch)
             If hr=0 And *pElemDisp>0
                hr= *pElemDisp\QueryInterface(?IID_IHTMLFormElement, @*pFormElement)
                 If hr=0 And *pFormElement>0
                     If ProcessInputElement(*pFormElement,0)
                        a=Number
                        Ret=1
                     EndIf
                    *pFormElement\Release()
                 EndIf
                *pElemDisp\Release()
             EndIf
         Next a
     EndIf
    
     If Ret
         ProcedureReturn 1
     Else
         ProcedureReturn 0
     EndIf
EndProcedure

Procedure ProcessDocument(*pDoc.IHTMLDocument2)
    Protected *pElemColl.IHTMLElementCollection_FIXED = #Null
    Protected hr.l,Ret.l
    
    hr= *pDoc\get_forms(@*pElemColl)
     If hr=0 And *pElemColl>0
        Ret=ProcessFormsCollection(*pElemColl)
        *pElemColl\Release()
     EndIf
    
     If Ret
         ProcedureReturn 1
     Else
         ProcedureReturn 0
     EndIf
EndProcedure

Procedure Auto_Login(Url.s)
    Protected *pDispatch.IDispatch,*pDocument2.IHTMLDocument2
    Protected hr.l,Ret.l,message.s
    
    
     ForEach AutoLogin()
         If AutoLogin()\Url=Url
            Ret=1
            Break
         EndIf
     Next
    
     If Ret
        hr= WebBrowser\get_document(@*pDispatch)
         If hr=0 And *pDispatch>0
            hr=*pDispatch\QueryInterface(?IID_IHTMLDocument2, @*pDocument2)
             If hr=0 And *pDocument2>0
                 If ProcessDocument(*pDocument2)
                    message= "Le programme à rempli ce formulaire pour vous ; )" + Chr (13)
                    message+ "Si vos informations de Login sont correctes, vous serez connecté!"
                     MessageRequester ( "Info" ,message)
                 EndIf
                *pDocument2\Release()
             EndIf
            *pDispatch\Release()
         EndIf
     EndIf
EndProcedure

OpenWindow ( #Main ,0,0,800,600, "Auto Login" , #PB_Window_SystemMenu | #PB_Window_ScreenCentered )

If CreateStatusBar ( #Status , WindowID ( #Main ))
     AddStatusBarField (600)
     AddStatusBarField (200)
EndIf

StatusBarText ( #Status , 0, "" )
StatusBarText ( #Status , 1, "" )

CreateGadgetList ( WindowID ( #Main ))
PanelGadget ( #Panel , 2, 24, 798, 550)
     AddGadgetItem ( #Panel , -1, "" )
     WebGadget ( #Web ,2,2,788,520, "http://www.developpez.net/forums/forumdisplay.php?f=911" )
CloseGadgetList ()

ProgressBarGadget ( #Progress , 10, 4, 200, 10, 0, 100)

WebBrowser.IWebBrowser2 = GetWindowLong_ ( GadgetID ( #Web ), #GWL_USERDATA )

Repeat
    Event= WaitWindowEvent ()
     Select Event
         Case #PB_Event_Gadget
             Select EventGadget ()
                 Case #Web
                     Select EventType ()
                            
                         Case #PB_EventType_TitleChange
                            Title.s= GetGadgetItemText ( #Web , #PB_Web_PageTitle )
                             SetGadgetItemText ( #Panel , 0, Title, 0)
                            
                         Case #PB_EventType_StatusChange
                            StatusTexte.s= GetGadgetItemText ( #Web , #PB_Web_StatusMessage )
                             StatusBarText ( #Status , 0, StatusTexte)
                            
                         Case #PB_EventType_DownloadProgress
                            Progress= GetGadgetAttribute ( #Web , #PB_Web_Progress )
                            ProgressMax= GetGadgetAttribute ( #Web , #PB_Web_ProgressMax )
                            
                             If Progress<>ProgressMax
                                 HideGadget ( #Progress ,0)
                                 SetGadgetState ( #Progress , Progress)
                             Else
                                 HideGadget ( #Progress ,1)
                             EndIf
                            
                         Case #PB_EventType_DownloadEnd
                            Url.s= GetGadgetText ( #Web )
                            Auto_Login(Url)
                     EndSelect
             EndSelect
            
         Case #WM_CLOSE
            quit.l=1
     EndSelect
Until quit=1
End

DataSection
    IID_IHTMLElement:
     Data.l $3050F1FF
     Data.w $98B5, $11CF
     Data.b $BB, $82, $00, $AA, $00, $BD, $CE, $0B
    
    IID_IHTMLInputElement:
     Data.l $3050F5D2
     Data.w $98B5, $11CF
     Data.b $BB, $82, $00, $AA, $00, $BD, $CE, $0B
    
    IID_IHTMLFormElement:
     Data.l $3050F1F7
     Data.w $98B5, $11CF
     Data.b $BB, $82, $00, $AA, $00, $BD, $CE, $0B
    
    IID_IHTMLDocument2:
     Data.l $332C4425
     Data.w $26CB, $11D0
     Data.b $B4, $83, $00, $C0, $4F, $D9, $01, $19
EndDataSection

Auteur : Nico
Version : 16/03/2008
Fenêtre non cliquable (API Windows)

Dans cette version, il faut passer par un raccourci clavier pour rendre la fenêtre cliquable , utilisez la touche [CTRL].

;----------------------------------------------------------------
; Un exemple pour créer une fenêtre non cliquable
; Pour la rendre de nouveau cliquable appuyer sur la touche CONTROL
;----------------------------------------------------------------
; Cela ouvre d'intéressantes perspectives...
;----------------------------------------------------------------
; Références:
; http://msdn2.microsoft.com/fr-fr/magazine/cc163698(en-us).aspx
; http://www.codeproject.com/KB/vb/ClickThroughWindows.aspx
;----------------------------------------------------------------

Procedure Cliquable(Lparam.l)
GetAsyncKeyState_ ( #VK_CONTROL )
Repeat
     If GetAsyncKeyState_ ( #VK_CONTROL )
         SetWindowLong_ ( WindowID (0), #GWL_EXSTYLE , GetWindowLong_ ( WindowID (0), #GWL_EXSTYLE )& ~#WS_EX_TRANSPARENT)
         SetLayeredWindowAttributes_ ( WindowID (0), 0, 255, #LWA_ALPHA )
     EndIf
     Delay (50)
ForEver
EndProcedure


If OpenWindow (0, 100, 200, 195, 260, "PureBasic Window" , #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget )

SetWindowLong_ ( WindowID (0), #GWL_EXSTYLE , GetWindowLong_ ( WindowID (0), #GWL_EXSTYLE )|#WS_EX_LAYERED|#WS_EX_TRANSPARENT)
SetLayeredWindowAttributes_ ( WindowID (0), 0, 155, #LWA_ALPHA )

StickyWindow (0,1)

CreateThread (@Cliquable(),Lparam)

   Repeat
    EventID = WaitWindowEvent ()

     If EventID = #PB_Event_CloseWindow
      Quit = 1
     EndIf

   Until Quit = 1
EndIf
End

Dans cette version le passage de la souris dans la barre de titre rend la fenêtre cliquable.

Procedure TimerProc(hwnd.l, uMsg.l, idEvent.l, dwTime.l)
   Select uMsg
     Case #WM_TIMER
       Select idEvent
         Case 0
            GetCursorPos_(@Point.POINT)
            GetWindowRect_(WindowID(0),@Rect.RECT)
            Hauteur_Caption=GetSystemMetrics_(#SM_CYCAPTION)
            Rect\Bottom=Rect\Top+Hauteur_Caption
            If PtInRect_(@Rect,Point\x,Point\y)
                SetWindowLong_(WindowID(0),#GWL_EXSTYLE,GetWindowLong_(WindowID(0),#GWL_EXSTYLE)& ~#WS_EX_TRANSPARENT)
                SetLayeredWindowAttributes_(WindowID(0), 0, 255, #LWA_ALPHA)
            Else
                SetWindowLong_(WindowID(0),#GWL_EXSTYLE,GetWindowLong_(WindowID(0),#GWL_EXSTYLE)|#WS_EX_TRANSPARENT)
                SetLayeredWindowAttributes_(WindowID(0), 0, 155, #LWA_ALPHA)     
            EndIf
       EndSelect
   EndSelect
EndProcedure

If OpenWindow(0, 100, 200, 195, 260, "PureBasic Window", #PB_Window_SystemMenu | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)

SetWindowLong_(WindowID(0),#GWL_EXSTYLE,GetWindowLong_(WindowID(0),#GWL_EXSTYLE)|#WS_EX_LAYERED|#WS_EX_TRANSPARENT)
SetLayeredWindowAttributes_(WindowID(0), 0, 155, #LWA_ALPHA)

StickyWindow(0,1)

SetTimer_(WindowID(0), 0, 50, @TimerProc())

  Repeat
    EventID = WaitWindowEvent()

    If EventID = #PB_Event_CloseWindow
      Quit = 1
    EndIf

  Until Quit = 1
EndIf
End

Auteur : Nico
Version : 22/03/2008
ToolTip de la barre d'outils personnalisé (API)
PureBasic dispose en natif de la commande ToolBarToolTip() pour ajouter un texte flottant sur un bouton de la barre d'outils. Ce code vous montre comment personnaliser ce texte. 

Procedure ToolBar_ToolTip(ID_Window.l,ID_Toolbar.l)
  Protected ToolInfo.ToolInfo
  Global Tooltip.l
 
   #TTF_TRANSPARENT = $100

  Tooltip = CreateWindowEx_ (0, "tooltips_class32" , "" , 0, #WS_POPUP |#TTS_ALWAYSTIP, 0, 0, 0, 0, 0, 0, 0)
   SendMessage_ (Tooltip, #TTM_SETTIPTEXTCOLOR , RGB (0, 85, 223), 0)
   SendMessage_ (Tooltip, #TTM_SETTIPBKCOLOR , RGB (255, 255, 223), 0)
   SendMessage_ (Tooltip, #TTM_SETMAXTIPWIDTH , 0, 300)

   SendMessage_ (Tooltip, #TTM_SETTITLE , #TTI_INFO , "" )

  ToolInfo\cbSize = SizeOf (ToolInfo)
  ToolInfo\uFlags = #TTF_IDISHWND | #TTF_SUBCLASS | #TTF_TRANSPARENT
  ToolInfo\hWnd = WindowID (ID_Window)
  ToolInfo\uId = ToolBarID (ID_Toolbar)
  ToolInfo\hInst = 0
  ToolInfo\lpszText = 0
  
   SendMessage_ (Tooltip, #TTM_ADDTOOL , 0, @ToolInfo)
   SendMessage_ (Tooltip, #TTM_SETDELAYTIME , #TTDT_AUTOPOP ,3000) ;Durée de l'apparition du Tooltip
   SendMessage_ (Tooltip, #TTM_SETDELAYTIME , #TTDT_INITIAL ,1000) ;Délai avant l'apparition du Tooltip
EndProcedure

Procedure Modify_ToolTip(ID_Window.l,ID_Toolbar.l,Title.s,Text.s)
    Protected ToolInfo.ToolInfo
    
    ToolInfo\cbSize = SizeOf (ToolInfo)
    ToolInfo\hwnd = WindowID (ID_Window)
    ToolInfo\uId = ToolBarID (ID_Toolbar)
    ToolInfo\lpszText = @Text
     SendMessage_ (Tooltip, #TTM_ACTIVATE ,1,0)
     SendMessage_ (Tooltip, #TTM_SETTITLE , #TTI_INFO , Title)
     SendMessage_ (Tooltip, #TTM_UPDATETIPTEXT ,0,@ToolInfo)
EndProcedure

Procedure Callback(hwnd, msg, wParam, lParam)
  result= #PB_ProcessPureBasicEvents
   Select msg
     Case #WM_NOTIFY
          *pnmhdr.NMTBHOTITEM= lParam
           If *pnmhdr\hdr\code = -713 ;#TBN_HOTITEMCHANGE
               Select *pnmhdr\idnew
                   Case 1
                      Modify_ToolTip(0,0, "Nouveau:" , "Ouvre un document vierge" )
                   Case 2
                      Modify_ToolTip(0,0, "Ouvrir:" , "Charge un nouveau fichier" )
                   Case 3
                      Modify_ToolTip(0,0, "Sauver:" , "Enregistre le fichier en cours" )
                   Default
                   SendMessage_ (Tooltip, #TTM_ACTIVATE ,0,0)
               EndSelect

           EndIf
     EndSelect
   ProcedureReturn result
EndProcedure

If OpenWindow (0, 0, 0, 220, 220, "ToolTip" , #PB_Window_SystemMenu | #PB_Window_ScreenCentered )
  SetWindowCallback (@Callback(),0)

   CreateGadgetList ( WindowID (0))

   If CreateToolBar (0, WindowID (0))
     ToolBarStandardButton (1, #PB_ToolBarIcon_New )
     ToolBarStandardButton (2, #PB_ToolBarIcon_Open )
     ToolBarStandardButton (3, #PB_ToolBarIcon_Save )
     ToolBarSeparator ()
     ToolBarStandardButton (4, #PB_ToolBarIcon_Print )
     ToolBarStandardButton (5, #PB_ToolBarIcon_Find )
     ToolBarSeparator ()
   EndIf

  ToolBar_ToolTip(0,0)
  
   Repeat
    Event = WaitWindowEvent ()
   Until Event = #PB_Event_CloseWindow
EndIf

Auteur : Sparkie
Version : 15/06/2008
Comment connaître la fenêtre ayant le focus ?
Valable uniquement avec Windows (utilisation de l'API).
Ce programme affiche une icône à droite, dans la barre des tâches Windows. Un clic droit de la souris sur cette icône permet d'afficher la fenêtre ayant le focus avec son handle et le titre de la fenêtre. 

Procedure IdWindow(hwnd)
  className$ = Space(260)
  GetClassName_(hwnd, @className$, 260)
  If className$ <> "Shell_TrayWnd" And hwnd <> WindowID(0)
    tLen = GetWindowTextLength_(hwnd) + 1
    winText$ = Space(tLen)
    GetWindowText_(hwnd, @winText$, tLen)
    SetGadgetText(1, Str(hwnd) + #CRLF$ + winText$)
  EndIf
EndProcedure

Procedure WinProc(hwnd, msg, wParam, lParam)
  result = #PB_ProcessPureBasicEvents
  Select msg
    Case #WM_HOTKEY
      lastWindow = GetForegroundWindow_()
      IdWindow(lastWindow)
      wf$ = GetGadgetText(1)
      MessageRequester("La fenêtre ayant le focus est ", wf$, #PB_MessageRequester_Ok | #MB_ICONINFORMATION)
      DisplayPopupMenu(0, WindowID(0))
    Case #WM_USER + 11478
      ;... Ce message est reçu quand la souris est déplacée au dessus de notre icone dans le systray
      lastWindow = GetForegroundWindow_()
      IdWindow(lastWindow)
  EndSelect
  ProcedureReturn result
EndProcedure

If OpenWindow(0, 10, 10, 700, 100, "Test SysTray", #PB_Window_Invisible | #PB_Window_SystemMenu | #PB_Window_MaximizeGadget | #PB_Window_MinimizeGadget | #PB_Window_Minimize)
  CreatePopupMenu(0)
  MenuItem(0, "Continuer")
  MenuBar()
  MenuItem(1, "Quitter")
  CreateGadgetList(WindowID(0))
  SetWindowCallback(@WinProc())
  AddSysTrayIcon(1, WindowID(0), CatchImage(0, ?myImage))
  SysTrayIconToolTip(1, "Icon 1")
  TextGadget(1, 10, 10, 680, 75, "")
  HideGadget(1, 1)
  RegisterHotKey_(WindowID(0), 1, 0, #VK_F10)
  quit = #False
  Repeat
    event = WaitWindowEvent()
    If event = #PB_Event_Menu And EventMenu() = 1
      quit = #True
    EndIf
    If event = #PB_Event_SysTray
      If EventType() = #PB_EventType_RightClick
        wf$ = GetGadgetText(1)
        MessageRequester("La fenêtre ayant le focus est ", wf$, #PB_MessageRequester_Ok | #MB_ICONINFORMATION)
        DisplayPopupMenu(0, WindowID(0))
      EndIf
     
    EndIf
  Until quit
  UnregisterHotKey_(WindowID(0), 1)
EndIf
DataSection
myImage:
Data.b $00,$00,$01,$00,$01,$00,$20,$20,$04,$00,$01,$00,$04,$00,$E8,$02
Data.b $00,$00,$16,$00,$00,$00,$28,$00,$00,$00,$20,$00,$00,$00,$40,$00
Data.b $00,$00,$01,$00,$04,$00,$00,$00,$00,$00,$80,$02,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$80,$00,$00,$80,$00,$00,$00,$80,$80,$00,$00,$00,$00
Data.b $80,$00,$00,$80,$80,$00,$80,$00,$80,$00,$80,$80,$80,$00,$C0,$C0
Data.b $C0,$00,$00,$FF,$00,$00,$FF,$00,$00,$00,$FF,$FF,$00,$00,$00,$00
Data.b $FF,$00,$00,$FF,$FF,$00,$FF,$00,$FF,$00,$FF,$FF,$FF,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$B8,$FF,$BF,$BF,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$8B,$8B,$FF,$FB,$FB,$FB,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$08,$B8,$B8,$FF,$BF,$BF,$BF,$A0,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$FF,$8B,$8B,$FF,$FB,$FB,$FA,$AA,$00,$00,$00,$00,$00,$00
Data.b $00,$0F,$BF,$F8,$B8,$FF,$BF,$BF,$BA,$AF,$A0,$00,$00,$00,$00,$00
Data.b $00,$FB,$FB,$FF,$8B,$8F,$FB,$FB,$AA,$FB,$FB,$00,$00,$00,$00,$00
Data.b $00,$BF,$BF,$BF,$F8,$BF,$BF,$BA,$AF,$BF,$BF,$00,$00,$00,$00,$00
Data.b $0B,$FB,$FB,$FB,$FF,$8F,$FB,$AA,$FB,$FB,$FB,$F0,$00,$00,$00,$00
Data.b $0F,$BF,$BF,$BF,$BF,$00,$00,$AF,$BF,$BF,$BF,$B0,$00,$00,$00,$00
Data.b $0E,$EE,$EE,$FB,$F0,$00,$00,$0B,$FB,$FB,$FB,$F0,$00,$00,$00,$00
Data.b $0E,$EE,$EE,$EE,$E0,$00,$00,$0E,$EE,$EE,$EE,$E0,$00,$00,$00,$00
Data.b $0B,$FB,$FB,$FB,$F0,$00,$00,$0B,$FB,$EE,$EE,$E0,$00,$00,$00,$00
Data.b $0F,$BF,$BF,$BF,$BA,$00,$00,$FF,$BF,$BF,$BF,$B0,$00,$00,$00,$00
Data.b $0B,$FB,$FB,$FB,$AA,$FB,$F8,$FF,$FB,$FB,$FB,$F0,$00,$00,$00,$00
Data.b $0F,$BF,$BF,$BA,$AF,$BF,$FB,$8F,$FF,$BF,$BF,$B0,$00,$00,$00,$00
Data.b $00,$FB,$FB,$AA,$FB,$FB,$F8,$B8,$FF,$FB,$FB,$00,$00,$00,$00,$00
Data.b $00,$BF,$BA,$AF,$BF,$BF,$FF,$8B,$8F,$FF,$BF,$00,$00,$00,$00,$00
Data.b $00,$0B,$AA,$AB,$FB,$FB,$FF,$B8,$B8,$FF,$F0,$00,$00,$00,$00,$00
Data.b $00,$00,$AA,$BF,$BF,$BF,$FF,$8B,$8B,$8F,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$0B,$FB,$FB,$FB,$FF,$B8,$B8,$B0,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$BF,$BF,$BF,$FF,$8B,$8B,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$FB,$FB,$FF,$B8,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00
Data.b $00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$FF,$FF
Data.b $FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$F0
Data.b $0F,$FF,$FF,$C0,$03,$FF,$FF,$80,$01,$FF,$FF,$00,$00,$FF,$FE,$00
Data.b $00,$7F,$FC,$00,$00,$3F,$F8,$00,$00,$1F,$F8,$00,$00,$1F,$F0,$00
Data.b $00,$0F,$F0,$00,$00,$0F,$F0,$03,$C0,$0F,$F0,$03,$C0,$0F,$F0,$03
Data.b $C0,$0F,$F0,$00,$00,$0F,$F0,$00,$00,$0F,$F0,$00,$00,$0F,$F8,$00
Data.b $00,$1F,$F8,$00,$00,$1F,$FC,$00,$00,$3F,$FE,$00,$00,$7F,$FF,$00
Data.b $00,$FF,$FF,$80,$01,$FF,$FF,$C0,$03,$FF,$FF,$F0,$0F,$FF,$FF,$FF
Data.b $FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF,$FF
EndDataSection

Auteur : netmaestro
Version : 23/06/2008
Téléchargez le zip
Animation sur le bureau (Inutile mais amusant)
L'archive contient les images et les sons, ainsi qu'un exécutable pour tester le programme sans PureBasic. 

;========================================================================
; Program:          Resize Window Improvement                           
; Author:           Lloyd Gallant (netmaestro)                                     
; Date:             June 21, 2008                                       
; Target OS:        Windows 2000/XP and later                           
; Target Compiler:  PureBasic 4.0 and later                             
; License:          Free, unrestricted, no warranty                     
; Why:              I just haven't written anything silly in a while   
;========================================================================   

Declare CatchPNG(ImageNumber, Address, Length)
Declare MainThread(void)
Declare WalkingW(void)
Declare WalkingE(void)
Declare WalkingNE(void)
Declare WalkingSE(void)
Declare HammeringE(void)
Declare HammeringW(effect)
Declare UpdateWindow(window,img)
Declare WinProc(hwnd, msg, wparam, lparam)
Declare Instance_Running(LockStr$)

DataSection
  sheet:  IncludeBinary "builder2.png" : endsheet:
  win1:   IncludeBinary "win1.png"     : endwin1:
  tilt1:  IncludeBinary "win2.png"     : endtilt1:
  tilt2:  IncludeBinary "win3.png"     : endtilt2:
  bent1:  IncludeBinary "win4.png"     : endbent1:
  bent2:  IncludeBinary "win5.png"     : endbent2:
  swear:  IncludeBinary "swear.png"    : endswear:
  giveup: IncludeBinary "giveup.png"   : endgiveup:
  walk:   IncludeBinary "move.wav"
  hammer: IncludeBinary "walk.wav"
EndDataSection

If Instance_Running("netmaestro's Resize Window Improvement")
  End
EndIf

Global soundon = InitSound()
If soundon
  CatchSound(0, ?hammer)
  CatchSound(1, ?walk)
EndIf

CatchPNG(0, ?sheet,?endsheet-?sheet)
Global win1    = CatchPNG(#PB_Any, ?win1, ?endwin1-?win1)
Global tilt1   = CatchPNG(#PB_Any, ?tilt1, ?endtilt1-?tilt1)
Global tilt2   = CatchPNG(#PB_Any, ?tilt2, ?endtilt2-?tilt2)
Global bent1   = CatchPNG(#PB_Any, ?bent1, ?endbent1-?bent1)
Global bent2   = CatchPNG(#PB_Any, ?bent2, ?endbent2-?bent2)
Global swear   = CatchPNG(#PB_Any, ?swear, ?endswear-?swear)
Global giveup  = CatchPNG(#PB_Any, ?giveup, ?endgiveup-?giveup)
Global wait    = GrabImage(0,#PB_Any, 16*96,192,96,96)
Global threadfinished=0

Global NewList hammerw()
For i=0 To 10
  AddElement(hammerw())
  hammerw()=GrabImage(0, #PB_Any, (96*8)+i*96,96,96,96)
Next
FirstElement(hammerw())

Global NewList hammere()
For i=0 To 10
  AddElement(hammere())
  hammere()=GrabImage(0, #PB_Any, (96*8)+i*96,0,96,96)
Next
FirstElement(hammerw())

Global NewList walkw()
For i=0 To 7
  AddElement(walkw())
  walkw()=GrabImage(0, #PB_Any, i*96,96,96,96)
Next
FirstElement(walkw())

Global NewList walke()
For i=0 To 7
  AddElement(walke())
  walke()=GrabImage(0,#PB_Any, 96*i,0,96,96)
Next
FirstElement(walke())

Global NewList walkne()
For i=0 To 7
  AddElement(walkne())
  walkne()=GrabImage(0,#PB_Any, i*96,192,96,96)
Next
FirstElement(walkne())

Global NewList walkse()
For i=0 To 7
  AddElement(walkse())
  walkse()=GrabImage(0,#PB_Any, (96*8)+i*96,192,96,96)
Next
FirstElement(walkse())

win=OpenWindow(0,0,0,320,290,"ResizeWindow Improvement",#PB_Window_BorderLess|#PB_Window_Invisible|#PB_Window_ScreenCentered)
SetWindowLong_(win,#GWL_EXSTYLE, GetWindowLong_(win,#GWL_EXSTYLE)|#WS_EX_LAYERED|#WS_EX_TOOLWINDOW)
UpdateWindow(0, win1)
StickyWindow(0,1)

win2=OpenWindow(1,0,0,320,290,"",#PB_Window_BorderLess|#PB_Window_Invisible)
SetWindowLong_(win2,#GWL_EXSTYLE, GetWindowLong_(win2,#GWL_EXSTYLE)|#WS_EX_LAYERED|#WS_EX_TOOLWINDOW)
UpdateWindow(1, swear)
StickyWindow(1,1)

HideWindow(0,0)

man = OpenWindow(9,0,0,96,96,"",#PB_Window_BorderLess|#PB_Window_Invisible|#PB_Window_ScreenCentered)
SetWindowLong_(man,#GWL_EXSTYLE, GetWindowLong_(man,#GWL_EXSTYLE)|#WS_EX_LAYERED|#WS_EX_TOOLWINDOW)
StickyWindow(9,1)
UpdateWindow(9,wait)

SetWindowCallback(@WinProc(), 0) ; To keep builder in the foreground

main_tid = CreateThread(@MainThread(),0)

Repeat : Until WaitWindowEvent() = #PB_Event_CloseWindow

End

Procedure MainThread(void)
  Protected tid
 
  ; Opening view
  Delay(1000)
  HideWindow(9,0)
  Delay(1000)
 
  ; Walk to top right corner
  tid=CreateThread(@WalkingNE(),0)
  Repeat
    Delay(1)
  Until WindowX(9)>=WindowX(0)+WindowWidth(0)-20
  threadfinished = #True:WaitThread(tid)
 
  ; Hammer on right corner
  tid=CreateThread(@HammeringW(),0)
  WaitThread(tid)
  Delay(500)
  ResizeWindow(1, WindowX(9)+10,WindowY(9)-80,#PB_Ignore,#PB_Ignore)
  HideWindow(1,0):Delay(1400):HideWindow(1,1)

  ; Walk to top left corner
  tid=CreateThread(@WalkingW(),0)
  Repeat
    Delay(1)
  Until WindowX(9)<=WindowX(0)-110
  threadfinished = #True:WaitThread(tid)
  tid=CreateThread(@WalkingSE(),0)
  Repeat
    Delay(1)
  Until WindowX(9)>=WindowX(0)-80
  threadfinished = #True:WaitThread(tid) 
 
  ; Hammer on left corner
  tid=CreateThread(@HammeringE(),0)
  WaitThread(tid)

  ; Walk to right of mid-window
  tid=CreateThread(@WalkingSE(),0)
  Repeat
    Delay(1)
  Until WindowX(9)>=WindowX(0)+20
  threadfinished = #True:WaitThread(tid) 
  tid=CreateThread(@WalkingE(),0)
  Repeat
    Delay(1)
  Until WindowX(9)>=WindowX(0)+WindowWidth(0)-20
  threadfinished = #True:WaitThread(tid) 
 
  ; Hammer on mid-window
  tid=CreateThread(@HammeringW(),1) ; parameter specifies effect of hammering: 0=tilt,1=dent
  WaitThread(tid)
  Delay(500)
  ResizeWindow(1, WindowX(9)+10,WindowY(9)-80,#PB_Ignore,#PB_Ignore)
  HideWindow(1,0):Delay(1400):HideWindow(1,1)   
   
  ; Walk back to mid window and give up
  tid=CreateThread(@WalkingW(),0)
  Repeat
    Delay(1)
  Until WindowX(9)<=WindowX(0)+110
  threadfinished = #True:WaitThread(tid)
  UpdateWindow(9, wait)
  Delay(1000)
  UpdateWindow(1, giveup)
  ResizeWindow(1, WindowX(9)+10,WindowY(9)-80,#PB_Ignore,#PB_Ignore)
  HideWindow(1,0):Delay(3000):HideWindow(1,1)   
 
  ; End the program
  PostMessage_(WindowID(0), #WM_SYSCOMMAND, #SC_CLOSE,0)
     
EndProcedure

Procedure HammeringW(effect)
  Protected hits = 0 ; Counts the hits
  Protected cc   = 0 ; Counts the sprite frames, record a hit on 7th frame
 
  Repeat
    UpdateWindow(9, hammerw())
    If cc=7
      If soundon
        PlaySound(0)
      EndIf
      hits+1
    EndIf
    Delay(100)
    If Not NextElement(hammerw())
      FirstElement(hammerw())
      cc=0
    Else
      cc+1 
    EndIf
    Select effect
      Case 0
        If hits = 2
          UpdateWindow(0, tilt1)
        EndIf
        If hits = 4
          UpdateWindow(0,tilt2)
        EndIf
      Case 1
        If hits = 2
          UpdateWindow(0,bent1)
          ResizeWindow(9,WindowX(9)-1,#PB_Ignore,#PB_Ignore,#PB_Ignore)
        EndIf
        If hits = 4
          UpdateWindow(0,bent2)
        EndIf
    EndSelect     
  Until hits = 4 And cc=0
EndProcedure

Procedure HammeringE(void)
  Protected hits = 0 ; Counts the hits
  Protected cc   = 0 ; Counts the sprite frames, record a hit on 7th frame
 
  Repeat
    UpdateWindow(9, hammere())
    If cc=7
      If soundon
        PlaySound(0)
      EndIf
      hits+1
    EndIf
    Delay(100)
    If Not NextElement(hammere())
      FirstElement(hammere())
      cc=0
    Else
      cc+1 
    EndIf
    If hits = 2
      UpdateWindow(0,tilt1)
    EndIf
    If hits = 4
      UpdateWindow(0,win1)
    EndIf

  Until hits = 4 And cc=0
EndProcedure

Procedure WalkingW(void)
  threadfinished=0
  Repeat
    UpdateWindow(9,walkw())
    If (cc=1 Or cc=5) And soundon
      PlaySound(1)
    EndIf
    ResizeWindow(9, WindowX(9)-5,#PB_Ignore,#PB_Ignore,#PB_Ignore)
    Delay(100)
    If Not NextElement(walkw())
      FirstElement(walkw())
      cc=0
    Else
      cc+1 
    EndIf
  Until threadfinished
EndProcedure

Procedure WalkingE(void)
  threadfinished=0
  Repeat
    UpdateWindow(9,walke())
    If (cc=1 Or cc=5) And soundon
      PlaySound(1)
    EndIf
    ResizeWindow(9, WindowX(9)+5,#PB_Ignore,#PB_Ignore,#PB_Ignore)
    Delay(100)
    If Not NextElement(walke())
      FirstElement(walke())
      cc=0
    Else
      cc+1 
    EndIf
  Until threadfinished
EndProcedure

Procedure WalkingNE(void)
  threadfinished=0
  Repeat
    UpdateWindow(9,walkne())
    If (cc=1 Or cc=5) And soundon
      PlaySound(1)
    EndIf
    ResizeWindow(9, WindowX(9)+5,WindowY(9)-3,#PB_Ignore,#PB_Ignore)
    Delay(100)
    If Not NextElement(walkne())
      FirstElement(walkne())
      cc=0
    Else
      cc+1 
    EndIf
  Until threadfinished
EndProcedure

Procedure WalkingSE(void)
  threadfinished=0
  Repeat
    UpdateWindow(9,walkse())
    If (cc=1 Or cc=5) And soundon
      PlaySound(1)
    EndIf
    ResizeWindow(9, WindowX(9)+5,WindowY(9)+5,#PB_Ignore,#PB_Ignore)
    Delay(100)
    If Not NextElement(walkse())
      cc=0
      FirstElement(walkse())
    Else
      cc+1
    EndIf
  Until threadfinished
EndProcedure

Procedure UpdateWindow(window,img)
  hDC = StartDrawing(ImageOutput(img))
    sz.SIZE
    sz\cx = ImageWidth(img)
    sz\cy = ImageHeight(img)
    ContextOffset.POINT
    BlendMode.BLENDFUNCTION
    BlendMode\SourceConstantAlpha = 255
    BlendMode\AlphaFormat = 1
    UpdateLayeredWindow_(WindowID(window), 0, 0, @sz, hDC, @ContextOffset, 0, @BlendMode, 2)
  StopDrawing()
EndProcedure

Procedure WinProc(hwnd, msg, wparam, lparam)
  result=#PB_ProcessPureBasicEvents
  Select msg
    Case #WM_LBUTTONDOWN,#WM_LBUTTONDBLCLK,#WM_RBUTTONDOWN,#WM_RBUTTONDBLCLK,#WM_MBUTTONDOWN,#WM_MBUTTONDBLCLK 
      SetForegroundWindow_(WindowID(9))
      If IsWindowVisible_(WindowID(1))
        SetForegroundWindow_(WindowID(1))
      EndIf
  EndSelect 
  ProcedureReturn result
EndProcedure

Procedure CatchPNG(ImageNumber, Address, Length)

  CompilerIf Defined(GdiplusStartupInput, #PB_Structure) = 0
    Structure GdiplusStartupInput
      GdiPlusVersion.l
      *DebugEventCallback.Debug_Event
      SuppressBackgroundThread.l
      SuppressExternalCodecs.l
    EndStructure
  CompilerEndIf 
 
  Structure StreamObject
    block.l
    *bits
    stream.ISTREAM
  EndStructure

  Protected lib
  lib = OpenLibrary(#PB_Any, "gdiplus.dll")
  If Not lib
    ProcedureReturn -1
  EndIf
 
  input.GdiplusStartupInput
  input\GdiPlusVersion = 1
 
  CallFunction(lib, "GdiplusStartup", @*token, @input, #Null)
  If *token
    stream.streamobject
    Stream\block = GlobalAlloc_(#GHND, Length)
    Stream\bits = GlobalLock_(Stream\block)
    CopyMemory(address, stream\bits, Length)
    If CreateStreamOnHGlobal_(stream\bits, 0, @Stream\stream) = #S_OK
      CallFunction(lib, "GdipCreateBitmapFromStream", Stream\stream , @*image)
      Stream\stream\Release()
      GlobalUnlock_(Stream\bits)
      GlobalFree_(Stream\block)
    Else
      CallFunction(lib, "GdiplusShutdown", *token)
      ProcedureReturn 0
    EndIf
   
    If *image
      CallFunction(lib, "GdipGetImageWidth", *image, @Width.l)
      CallFunction(lib, "GdipGetImageHeight", *image, @Height.l)
      If imagenumber = #PB_Any
        return_imagenumber = CreateImage(#PB_Any, Width, Height, 32)
      Else
        CreateImage(return_imagenumber, Width, Height, 32)
      EndIf
      hDC = StartDrawing(ImageOutput(return_imagenumber))
        CallFunction(lib, "GdipCreateFromHDC", hdc, @*gfx)
        CallFunction(lib, "GdipDrawImageRectI", *gfx, *image, 0, 0, Width, Height)
      StopDrawing() 
      CallFunction(lib, "GdipDeleteGraphics", *gfx) 
      CallFunction(lib, "GdipDisposeImage", *image)
      CallFunction(lib, "GdiplusShutdown", *token)
      CloseLibrary(0)
     
      ProcedureReturn return_imagenumber
    Else
      ProcedureReturn -1
    EndIf
  Else
    ProcedureReturn -1
  EndIf
EndProcedure

Procedure Instance_Running(LockStr$)
  *MyMutex = CreateMutex_(#Null, 1, LockStr$)
  If *MyMutex <> 0 And GetLastError_() = #ERROR_ALREADY_EXISTS
    CloseHandle_(*MyMutex)
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
EndProcedure

Auteur : Nico
Version : 23/07/2008
Procédure pour afficher les WM_xxxx des messages Window
J'utilise ce code pour connaître quel événement intervient lors de certaines actions sur les gadgets ou fenêtres, utile pour comprendre ce qui se passe et intervenir sur le message qui nous intéresse.

Une liste non exhaustive des messages window qui permettra de faire la correspondance entre la valeur numérique et le message WM_xxx associé que l'on pourra mettre à jour.

Le fichier Event_View.pb: 

Global Event_View.s, NoEvent_View.s

Event_View + "WM_ACTIVATE               0006"
Event_View + "WM_ACTIVATEAPP            001C"
Event_View + "WM_AFXFIRST               0360"
Event_View + "WM_AFXLAST                037F"
Event_View + "WM_APP                    8000"
Event_View + "WM_APPCOMMAND             0319"
Event_View + "WM_ASKCBFORMATNAME        030C"
Event_View + "WM_CANCELJOURNAL          004B"
Event_View + "WM_CANCELMODE             01F"
Event_View + "WM_CAPTURECHANGED         0215"
Event_View + "WM_CHANGECBCHAIN          030D"
Event_View + "WM_CHANGEUISTATE          0127"
Event_View + "WM_CHAR                   0102"
Event_View + "WM_CHARTOITEM             02F"
Event_View + "WM_CHILDACTIVATE          0022"
Event_View + "WM_CLEAR                  0303"
Event_View + "WM_CLOSE                  0010"
Event_View + "WM_COMMAND                0111"
Event_View + "WM_COMMNOTIFY             0044"
Event_View + "WM_COMPACTING             0041"
Event_View + "WM_COMPAREITEM            0039"
Event_View + "WM_CONTEXTMENU            007B"
Event_View + "WM_CONVERTREQUEST         010A"
Event_View + "WM_CONVERTREQUESTEX       0108"
Event_View + "WM_CONVERTRESULT          010B"
Event_View + "WM_COPY                   0301"
Event_View + "WM_COPYDATA               004A"
Event_View + "WM_CREATE                 0001"
Event_View + "WM_CTLCOLOR               0019"
Event_View + "WM_CTLCOLORBTN            0135"
Event_View + "WM_CTLCOLORDLG            0136"
Event_View + "WM_CTLCOLOREDIT           0133"
Event_View + "WM_CTLCOLORLISTBOX        0134"
Event_View + "WM_CTLCOLORMSGBOX         0132"
Event_View + "WM_CTLCOLORSCROLLBAR      0137"
Event_View + "WM_CTLCOLORSTATIC         0138"
Event_View + "WM_CUT                    0300"
Event_View + "WM_DDE_ACK                03E4"
Event_View + "WM_DDE_ADVISE             03E2"
Event_View + "WM_DDE_DATA               03E5"
Event_View + "WM_DDE_EXECUTE            03E8"
Event_View + "WM_DDE_FIRST              03E0"
Event_View + "WM_DDE_LAST               03E8"
Event_View + "WM_DDE_POKE               03E7"
Event_View + "WM_DDE_REQUEST            03E6"
Event_View + "WM_DDE_TERMINATE          03E1"
Event_View + "WM_DDE_UNADVISE           03E3"
Event_View + "WM_DEADCHAR               0103"
Event_View + "WM_DELETEITEM             002D"
Event_View + "WM_DESTROY                0002"
Event_View + "WM_DESTROYCLIPBOARD       0307"
Event_View + "WM_DEVICECHANGE           0219"
Event_View + "WM_DEVMODECHANGE          001B"
Event_View + "WM_DISPLAYCHANGE          007E"
Event_View + "WM_DRAWCLIPBOARD          0308"
Event_View + "WM_DRAWITEM               002B"
Event_View + "WM_DROPFILES              0233"
Event_View + "WM_ENABLE                 000A"
Event_View + "WM_ENDSESSION             0016"
Event_View + "WM_ENTERIDLE              0121"
Event_View + "WM_ENTERMENULOOP          0211"
Event_View + "WM_ENTERSIZEMOVE          0231"
Event_View + "WM_ERASEBKGND             0014"
Event_View + "WM_EXITMENULOOP           0212"
Event_View + "WM_EXITSIZEMOVE           0232"
Event_View + "WM_FONTCHANGE             001D"
Event_View + "WM_FORWARDMSG             037F"
Event_View + "WM_GETDLGCODE             0087"
Event_View + "WM_GETFONT                0031"
Event_View + "WM_GETHOTKEY              0033"
Event_View + "WM_GETICON                007F"
Event_View + "WM_GETMINMAXINFO          0024"
Event_View + "WM_GETOBJECT              003D"
Event_View + "WM_GETTEXT                000D"
Event_View + "WM_GETTEXTLENGTH          000E"
Event_View + "WM_HANDHELDFIRST          0358"
Event_View + "WM_HANDHELDLAST           035F"
Event_View + "WM_HELP                   0053"
Event_View + "WM_HOTKEY                 0312"
Event_View + "WM_HSCROLL                0114"
Event_View + "WM_HSCROLLCLIPBOARD       030E"
Event_View + "WM_ICONERASEBKGND         0027"
Event_View + "WM_IME_CHAR               0286"
Event_View + "WM_IME_COMPOSITION        010F"
Event_View + "WM_IME_COMPOSITIONFULL    0284"
Event_View + "WM_IME_CONTROL            0283"
Event_View + "WM_IME_ENDCOMPOSITION     010E"
Event_View + "WM_IME_KEYDOWN            0290"
Event_View + "WM_IME_KEYLAST            010F"
Event_View + "WM_IME_KEYUP              0291"
Event_View + "WM_IME_NOTIFY             0282"
Event_View + "WM_IME_REPORT             0280"
Event_View + "WM_IME_REQUEST            0288"
Event_View + "WM_IME_SELECT             0285"
Event_View + "WM_IME_SETCONTEXT         0281"
Event_View + "WM_IME_STARTCOMPOSITION   010D"
Event_View + "WM_IMEKEYDOWN             0290"
Event_View + "WM_IMEKEYUP               0291"
Event_View + "WM_INITDIALOG             0110"
Event_View + "WM_INITMENU               0116"
Event_View + "WM_INITMENUPOPUP          0117"
Event_View + "WM_INPUTLANGCHANGE        0051"
Event_View + "WM_INPUTLANGCHANGEREQUEST 0050"
Event_View + "WM_INTERIM                010C"
Event_View + "WM_KEYDOWN                0100"
;Event_View + "WM_KEYFIRST               0100" idem que WM_KEYDOWN ?
Event_View + "WM_KEYLAST                0108"
Event_View + "WM_KEYUP                  0101"
Event_View + "WM_KILLFOCUS              0008"
Event_View + "WM_LBUTTONDBLCLK          0203"
Event_View + "WM_LBUTTONDOWN            0201"
Event_View + "WM_LBUTTONUP              0202"
Event_View + "WM_MBUTTONDBLCLK          0209"
Event_View + "WM_MBUTTONDOWN            0207"
Event_View + "WM_MBUTTONUP              0208"
Event_View + "WM_MDIACTIVATE            0222"
Event_View + "WM_MDICASCADE             0227"
Event_View + "WM_MDICREATE              0220"
Event_View + "WM_MDIDESTROY             0221"
Event_View + "WM_MDIGETACTIVE           0229"
Event_View + "WM_MDIICONARRANGE         0228"
Event_View + "WM_MDIMAXIMIZE            0225"
Event_View + "WM_MDINEXT                0224"
Event_View + "WM_MDIREFRESHMENU         0234"
Event_View + "WM_MDIRESTORE             0223"
Event_View + "WM_MDISETMENU             0230"
Event_View + "WM_MDITILE                0226"
Event_View + "WM_MEASUREITEM            002C"
Event_View + "WM_MENUCHAR               0120"
Event_View + "WM_MENUCOMMAND            0126"
Event_View + "WM_MENUDRAG               0123"
Event_View + "WM_MENUGETOBJECT          0124"
Event_View + "WM_MENURBUTTONUP          0122"
Event_View + "WM_MENUSELECT             011F"
Event_View + "WM_MOUSEACTIVATE          0021"
;Event_View + "WM_MOUSEFIRST             0200" idem que WM_MOUSEMOVE ?
Event_View + "WM_MOUSEHOVER             02A1"
Event_View + "WM_MOUSELAST              0209"
Event_View + "WM_MOUSELEAVE             02A3"
Event_View + "WM_MOUSEMOVE              0200"
Event_View + "WM_MOUSEWHEEL             020A"
Event_View + "WM_MOVE                   0003"
Event_View + "WM_MOVING                 0216"
Event_View + "WM_NCACTIVATE             0086"
Event_View + "WM_NCCALCSIZE             0083"
Event_View + "WM_NCCREATE               0081"
Event_View + "WM_NCDESTROY              0082"
Event_View + "WM_NCHITTEST              0084"
Event_View + "WM_NCLBUTTONDBLCLK        00A3"
Event_View + "WM_NCLBUTTONDOWN          00A1"
Event_View + "WM_NCLBUTTONUP            00A2"
Event_View + "WM_NCMBUTTONDBLCLK        00A9"
Event_View + "WM_NCMBUTTONDOWN          00A7"
Event_View + "WM_NCMBUTTONUP            00A8"
Event_View + "WM_NCMOUSEHOVER           02A0"
Event_View + "WM_NCMOUSELEAVE           02A2"
Event_View + "WM_NCPAINT                0085"
Event_View + "WM_NCRBUTTONDBLCLK        00A6"
Event_View + "WM_NCRBUTTONDOWN          00A4"
Event_View + "WM_NCRBUTTONUP            00A5"
Event_View + "WM_NCXBUTTONDBLCLK        00AD"
Event_View + "WM_NCXBUTTONDOWN          00AB"
Event_View + "WM_NCXBUTTONUP            00AC"
Event_View + "WM_NEXTDLGCTL             0028"
Event_View + "WM_NEXTMENU               0213"
Event_View + "WM_NOTIFY                 004E"
Event_View + "WM_NOTIFYFORMAT           0055"
Event_View + "WM_NULL                   0000"
Event_View + "WM_OTHERWINDOWCREATED     0042"
Event_View + "WM_OTHERWINDOWDESTROYED   0043"
Event_View + "WM_PAINT                  000F"
Event_View + "WM_PAINTCLIPBOARD         0309"
Event_View + "WM_PAINTICON              0026"
Event_View + "WM_PALETTECHANGED         0311"
Event_View + "WM_PALETTEISCHANGING      0310"
Event_View + "WM_PARENTNOTIFY           0210"
Event_View + "WM_PASTE                  0302"
Event_View + "WM_PENWINFIRST            0380"
Event_View + "WM_PENWINLAST             038F"
Event_View + "WM_POWER                  0048"
Event_View + "WM_POWERBROADCAST         0218"
Event_View + "WM_PRINT                  0317"
Event_View + "WM_PRINTCLIENT            0318"
Event_View + "WM_QUERYDRAGICON          0037"
Event_View + "WM_QUERYENDSESSION        0011"
Event_View + "WM_QUERYNEWPALETTE        030F"
Event_View + "WM_QUERYOPEN              0013"
Event_View + "WM_QUERYUISTATE           0129"
Event_View + "WM_QUEUESYNC              0023"
Event_View + "WM_QUIT                   0012"
Event_View + "WM_RASDIALEVENT           CCCD"
Event_View + "WM_RBUTTONDBLCLK          0206"
Event_View + "WM_RBUTTONDOWN            0204"
Event_View + "WM_RBUTTONUP              0205"
Event_View + "WM_RENDERALLFORMATS       0306"
Event_View + "WM_RENDERFORMAT           0305"
Event_View + "WM_SETCURSOR              0020"
Event_View + "WM_SETFOCUS               0007"
Event_View + "WM_SETFONT                0030"
Event_View + "WM_SETHOTKEY              0032"
Event_View + "WM_SETICON                0080"
Event_View + "WM_SETREDRAW              000B"
Event_View + "WM_SETTEXT                000C"
Event_View + "WM_SHOWWINDOW             0018"
Event_View + "WM_SIZE                   0005"
Event_View + "WM_SIZECLIPBOARD          030B"
Event_View + "WM_SIZING                 0214"
Event_View + "WM_SPOOLERSTATUS          002A"
Event_View + "WM_STYLECHANGED           007D"
Event_View + "WM_STYLECHANGING          007C"
Event_View + "WM_SYNCPAINT              0088"
Event_View + "WM_SYSCHAR                0106"
Event_View + "WM_SYSCOLORCHANGE         0015"
Event_View + "WM_SYSCOMMAND             0112"
Event_View + "WM_SYSDEADCHAR            0107"
Event_View + "WM_SYSKEYDOWN             0104"
Event_View + "WM_SYSKEYUP               0105"
Event_View + "WM_TCARD                  0052"
Event_View + "WM_TIMECHANGE             001E"
Event_View + "WM_TIMER                  0113"
Event_View + "WM_UNDO                   0304"
Event_View + "WM_UNINITMENUPOPUP        0125"
Event_View + "WM_UPDATEUISTATE          0128"
Event_View + "WM_USER                   0400"
Event_View + "WM_USERCHANGED            0054"
Event_View + "WM_VKEYTOITEM             002E"
Event_View + "WM_VSCROLL                0115"
Event_View + "WM_VSCROLLCLIPBOARD       030A"
Event_View + "WM_WINDOWPOSCHANGED       0047"
Event_View + "WM_WINDOWPOSCHANGING      0046"
Event_View + "WM_WININICHANGE           001A"
Event_View + "WM_WNT_CONVERTREQUESTEX   0109"
Event_View + "WM_XBUTTONDBLCLK          020D"
Event_View + "WM_XBUTTONDOWN            020B"
Event_View + "WM_XBUTTONUP              020C"
Procedure RemoveEvent(RemoveMessage.s)
    NoEvent_View = NoEvent_View + RemoveMessage + " "
EndProcedure

Procedure.l ViewEvent(Number.l)
    Protected Message.s, NumberHex.s
   
    NumberHex = RSet(Hex(number), 4, "0")
    PositionDepart = FindString(Event_View, NumberHex, 1)
    If PositionDepart
      Message = Mid(Event_View, PositionDepart-26, 25)
      Message = RTrim(Message)
      If FindString(NoEvent_View, Message, 1) = 0
         Debug Message
         ProcedureReturn 1
      Else
         ProcedureReturn 0
      EndIf
    EndIf
    Debug "Message Inconnu= " + NumberHex
    ProcedureReturn 1
EndProcedure
Un code pour tester : 

CompilerIf #PB_Compiler_Debugger
   IncludeFile : "Event_View.pb"
CompilerEndIf

Procedure WinCallback(hWnd, uMsg, wParam, lParam)
   
   CompilerIf #PB_Compiler_Debugger
      ViewEvent(uMsg)
   CompilerEndIf
   
   If uMsg = #WM_SIZE
      Select wParam
         Case #SIZE_MINIMIZED
            Debug "La fenêtre est minimisée"
         Case #SIZE_RESTORED
            Debug "La fenêtre est rétablie"
         Case #SIZE_MAXIMIZED
            Debug "La fenêtre est agrandie"
      EndSelect
   EndIf
   
   ProcedureReturn #PB_ProcessPureBasicEvents
EndProcedure

If OpenWindow(0, 0, 0, 200, 100, "Messages", #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)
   
   CompilerIf #PB_Compiler_Debugger
      ; Cette fonction permet de supprimer de notre liste certains messages
      ; que l'on connait ou qui reviennent trop souvent
      RemoveEvent("WM_MOUSEMOVE WM_NCMOUSEMOVE WM_SETCURSOR")
   CompilerEndIf
   
   SetWindowCallback(@WinCallback())
   
   Repeat
      Select WaitWindowEvent()
         Case #PB_Event_CloseWindow
            End
      EndSelect
   ForEver
   
EndIf

Auteur : netmaestro
Auteur : Sparkie
Version : 27/07/2008
Lecture des adresses URL des navigateurs Internet exploreur ou Firefox.

; ************************************************
; Code          : Read Browser URL (IE, Firefox)
; Author(s)     : Sparkie, netmaestro
; Other credits : PB, rsts
; Rel Date      : December 21, 2006 7:41 PM
; Update        : July 26, 2008 10:49 AM
;                 -fix for Firefox 3
; Target OS     : Windows only
; Target PB     : 4.x
;...Code converted from VB to PB
;...Feel free to clean it up and use as you wish.
; ************************************************

;################
; Constants
;################
#CHILDID_SELF = 0
#WINEVENT_OUTOFCONTEXT = 0
#WINEVENT_SKIPOWNPROCESS = $2
#EVENT_OBJECT_FOCUS = $8005
#EVENT_OBJECT_VALUECHANGE = $800E
#ROLE_SYSTEM_DOCUMENT = $F
#ROLE_SYSTEM_PANE = $10
#ROLE_SYSTEM_TEXT = $2A

;################
; Convert to BSTR
;################
; Thanks to freak for this one
Procedure.l ASCIItoBSTR(asciiString$)
  Protected result = 0
  CompilerIf #PB_Compiler_Unicode
  result = SysAllocString_(@asciiString$)
  CompilerElse
  Protected *buff = AllocateMemory(Len(asciiString$)*2 + 2)
  If *buff
    PokeS(*buff, asciiString$, -1, #PB_Unicode)
    result = SysAllocString_(*buff)
    FreeMemory(*buff)
  EndIf
  CompilerEndIf
  ProcedureReturn result
EndProcedure

;################
; Set Hook
;################
Procedure WinEventFunc(HookHandle.l, hEvent.l, hwnd.l, idObject.l, idChild.l, idEventThread.l, dwmsEventTime.l)
  Protected *objectIa.IAccessible
  Static previousUrl$
  Select hEvent
    Case #EVENT_OBJECT_FOCUS, #EVENT_OBJECT_VALUECHANGE
      className$ = Space(256)
      GetClassName_(hwnd, @className$, 256)
      If className$ = "MozillaWindowClass" Or className$ = "Internet Explorer_Server"
        If CallFunction(0, "AccessibleObjectFromEvent", hwnd, idObject, idChild, @*objectIa, @v.VARIANT) = #S_OK
          v.VARIANT\vt = #VT_I4
          v\lVal = #CHILDID_SELF
          *value = AllocateMemory(#MAX_PATH *2 + 2)
          If *objectIa\get_accRole(v, @v) = #S_OK
            If v\lVal = #ROLE_SYSTEM_PANE Or v\lVal = #ROLE_SYSTEM_DOCUMENT Or v\lVal = #ROLE_SYSTEM_TEXT
              v\vt = #VT_I4
              v\lVal = #CHILDID_SELF
              url$ = Space(#MAX_PATH)
              bstr = ASCIItoBSTR(Space(#MAX_PATH))
              If *objectIa\get_accValue(v, @bstr) = #S_OK
                len = WideCharToMultiByte_(#CP_ACP, 0, bstr, -1, 0, 0, 0, 0)
                url$ = Space(len)
                WideCharToMultiByte_(#CP_ACP, 0, bstr, -1, @url$, len, 0, 0)   
                If previousUrl$ <> url$ And url$ <> ""
                  AddGadgetItem(1, -1, url$)
                  previousUrl$ = url$
                EndIf
              EndIf
            EndIf
            *objectIa\Release()
          EndIf
        EndIf
      EndIf
  EndSelect
EndProcedure

;################
; Main Window
;################
If OpenWindow(0, 0, 0, 500, 400, "Read Browser URL", #PB_Window_SystemMenu) And CreateGadgetList(WindowID(0))
  CoInitialize_(0);
  hdll = OpenLibrary(0, "Oleacc.dll")
  EditorGadget(1, 10, 15, 480, 380)
  ;...Set event hook
  eHook = SetWinEventHook_(#EVENT_OBJECT_FOCUS, #EVENT_OBJECT_VALUECHANGE, #Null, @WinEventFunc(), 0, 0, #WINEVENT_OUTOFCONTEXT | #WINEVENT_SKIPOWNPROCESS)
  Repeat
    event = WaitWindowEvent()
  Until event = #PB_Event_CloseWindow
  ;...Cleanup
  CoUninitialize_()
  If eHook
    UnhookWinEvent_(eHook)
  EndIf
  If hdll
    CloseLibrary(0)
  EndIf
EndIf
End

Auteur : Denis
Version : 10/08/2008
Utilisation des interfaces IShellFolder et IEnumIDList pour afficher le contenu d'un dossier

; Auteur : Denis
; Version de PB : 3.91
; Date : 02 juin 2004
; Testé sous WIN98 SE

; Modifié le 10 août 2008
; Version de PB : 4.20
; Testé sous VISTA home edition + SP1



;
; Explication du programme :
; Utilisation des interfaces IShellFolder et IEnumIDList pour afficher le contenu
; du dossier 'Cache intenet'  pour cet exemple



; constantes possibles utilisables par la méthode EnumObjects de l'interface IShellFolder
#SHCONTF_FOLDERS = $0020
#SHCONTF_NONFOLDERS = $0040
#SHCONTF_INCLUDEHIDDEN = $0080
#SHCONTF_INIT_ON_FIRST_NEXT = $0100
#SHCONTF_NETPRINTERSRCH = $0200
#SHCONTF_SHAREABLE = $0400
#SHCONTF_STORAGE = $0800

; constantes possibles utilisables par la méthode GetDisplayNameOf de l'interface IShellFolder
#SHGDN_NORMAL = $0000
#SHGDN_INFOLDER = $0001
; #SHGDN_FOREDITING = 2
; #SHGDN_FORADDRESSBAR = 3
; #SHGDN_FORPARSING = 4

; constantes possibles pour le paramètre uType de la structure STRRET
#STRRET_WSTR = 0
#STRRET_OFFSET = 1
#STRRET_CSTR = 2

; quelques constantes possibles pour l'API SHGetSpecialFolderLocation
#CSIDL_DESKTOP = 0
#CSIDL_PRINTERS = 4
#CSIDL_RECENT = 8
#CSIDL_SENDTO = 9
#CSIDL_STARTMENU = 11
; #CSIDL_FONTS = $14
#CSIDL_INTERNET_CACHE = $0020
#CSIDL_INTERNET       = $0001


; constantes possibles pour l'API CoInitializeEx
#COINIT_MULTITHREADED = 0
#COINIT_APARTMENTTHREADED = 2
#COINIT_DISABLE_OLE1DDE = 4
#COINIT_SPEED_OVER_MEMORY = 8

;- Constantes utilisateur
Enumeration
     #MainWindow      ; fenêtre principale
     #ListIconGadget = 1
     #shlwapi_dll = 0 ; identifiant dll
EndEnumeration



;- Structure
Structure STRRET
     uType.l
     StructureUnion
          pOleStr.l
          uOffset.l
          cStr.b[#MAX_PATH]
     EndStructureUnion
EndStructure

;- Variables globales
Global ppMalloc.l ; pointeur sur l'interface Shell IMalloc
; ; /\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\
; ; \/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/\/


;- Debut prog
If OpenWindow(#MainWindow, 0, 0, 600, 400, "Explorer les dossiers avec IShellFolder", #PB_Window_ScreenCentered | #PB_Window_SystemMenu)
     If CreateGadgetList(WindowID(#MainWindow))
          IdListIcon = ListIconGadget(#ListIconGadget, 10, 10, 580, 380, "Contenu du Dossier SEND TO", 575, #LVS_SHAREIMAGELISTS)
          HideGadget(#ListIconGadget, 1)
         
          CoInitializeEx_(0, #COINIT_SPEED_OVER_MEMORY) ; Initialise la librairie COM pour le thread courant
         
          shlwapiDll = OpenLibrary(#shlwapi_dll, "shlwapi.dll")
         
          SHGetMalloc_(@pMalloc)
          pszDisplayName = AllocateMemory((#MAX_PATH * 2) + 2)
         
          ; l'API SHGetSpecialFolderLocation retourne  #S_OK en cas de succès sinon une  erreur
          ; Cette API est remplacée par l'API SHGetFolderLocation depuis Windows 2000, mais
          ; fonctionne avec les nouveaux OS
          ; L'API retourne dans ppidl un pointeur sur un élément identifiant une liste specifiant
          ; la localisation du dossier relatif à la racine du 'name space' (le bureau)
          If SHGetSpecialFolderLocation_(0, #CSIDL_INTERNET_CACHE, @ppidl.l) = #NOERROR And shlwapiDll
               
               ; SHGetDesktopFolder retourne dans ppshf le pointeur sur l'interface IShellFolder
               ; pour le dossier 'Bureau'
               If SHGetDesktopFolder_(@ppshf.IShellFolder) = #NOERROR
                   
                    ; la méthode BindToObject de l'interface IShellFolder retrouve un object IShellFolder
                    ; pour un sous-dossier
                    If ppshf\BindToObject(ppidl, 0, ?IID_IShellFolder, @ppvOut.IShellFolder) = #NOERROR
                         
                         ppshf\Release() ; on libère l'interface IShellFolder retournée par
                         ; SHGetDesktopFolder, on n'en a plus besoin
                         
                         ; La méthode BindToObject de l'interface IShellFolder a retourné dans ppvOut
                         ; un pointeur sur une interface IShellFolder  pour un sous-dossier
                         ; on peut donc commencer l'énumération avec la méthode EnumObjects (interface IShellFolder)
                         ; EnumObjects permet de déterminer le contenu d'un dossier en créant un élément
                         ; identifiant un object 'énumeration' et retournant son interface IEnumIDList.
                         ; Les méthodes supportée par cette interface peuvent être utilisées pour énumérer
                         ; le contenu d'un dossier.
                         If ppvOut\EnumObjects(0, #SHCONTF_FOLDERS | #SHCONTF_NONFOLDERS, @ppenum.IEnumIDList) = #S_OK
                             
                              ; La méthode Next de l'interface IEnumIDList permet de commencer l'énumération
                              ; La méthode Next énumère dans notre cas les éléments un par un (1er paramètre quui indique
                              ; aussi que pidlItems est un tableau à un élément. Pour retrouver plus d'éléments à la fois,
                              ; il faut dimensionner le tableau avec SHGetMalloc
                              ; celtFetched retourne une valeur qui indique combien d'éléments sont retournés par
                              ; la fonction et dans notre cas au max 1 sinon 0 si plus d'éléments
                              hr = ppenum\Next(1, @pidlItems, @celtFetched)
                             
                              ; on teste dans la boucle qu'il n'y a pas d'erreur et qu'il y a bien un élément
                              While ((hr = #NOERROR) And (celtFetched = 1))
                                   
                                   ; la méthopde GetDisplayNameOf de l'interface IShellFolder retrouve
                                   ; le nom d'affichage pour le dossier)fichier object spécifié.
                                   ; le 3ème paramètre est une variable basée sur la structure STRRET
                                   strDispName.STRRET\uType = #STRRET_OFFSET
                                   If ppvOut\GetDisplayNameOf(pidlItems, #SHGDN_INFOLDER, @strDispName.STRRET) = #NOERROR
                                       
                                        ; La chaine retournée par GetDisplayNameOf doit être formatée avant d'être
                                        ; affichée correctement avec l'API StrRetToBufA de la dll shlwapi.dll
                                        ; pszDisplayName est le buffer qui recevra la chaine à afficher
                                        CallFunction(#shlwapi_dll, "StrRetToBufA", @strDispName, pidlItems, pszDisplayName, #MAX_PATH)
                                       
                                        ; on affiche dans la Listicon
                                        AddGadgetItem(#ListIconGadget, 0, PeekS(pszDisplayName))
                                        ;
                                        hr = ppenum\Next(1, @pidlItems, @celtFetched)
                                   EndIf
                              Wend
                              CloseLibrary(#shlwapi_dll) ; ferme shlwapi.dll
                         EndIf
                    EndIf
               EndIf
          EndIf
          If pszDisplayName
               FreeMemory(pszDisplayName)
          EndIf
          HideGadget(#ListIconGadget, 0)
     EndIf
     
     CoTaskMemFree_(ppidl) ; libère la mémoire pointée par ppidl
     
     
     ; on affiche le nombre d'éléments dans la barre de la listeicongadget
     SetGadgetItemText(#ListIconGadget, -1, GetGadgetItemText(#ListIconGadget, -1, 0)+"  - "+Str(CountGadgetItems(#ListIconGadget))+ " objets trouvés")
     
     ;- boucle evenements
     While WaitWindowEvent() <> #PB_Event_CloseWindow And EventWindow() <> WindowID(#MainWindow)
     Wend
     
EndIf
CoUninitialize_() ; ferme la librairie COM pour le thread courant

End


DataSection
     ; Interface IShellFolder;
     ; helpstring("IShellFolder"),
     ; uuid(000214E6-0000-0000-C000-000000000046)
     
     IID_IShellFolder : ; cléf du registre mise sous la forme de DATA
     Data.l $000214E6
     Data.w $0000, $0000
     Data.b $C0, $00, $00, $00, $00, $00, $00, $46
EndDataSection
precedent    sommaire    suivant   

Consultez les autres pages sources

Les sources présentés sur cette pages sont libre de droits, et vous pouvez les utiliser à votre convenance. Par contre cette page de présentation de ces sources constitue une oeuvre intellectuelle protégée par les droits d'auteurs. Copyright ©2008  Developpez LLC. Tout droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à 3 ans de prison et jusqu'à 300 000 E de dommages et intérets. Cette page est déposée à la SACD.
Vos questions techniques : forum d'entraide Accueil - Publiez vos articles, tutoriels, cours et rejoignez-nous dans l'équipe de rédaction du club d'entraide des développeurs francophones. Nous contacter - Copyright 2000..2005 www.developpez.com