Sources PureBasicConsultez toutes les sources

Nombre d'auteurs : 41, nombre de sources : 88, dernière mise à jour : 13 août 2011 

 
OuvrirSommaireWindows

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 :

 
Sélectionnez

<form 

Et finit par :

 
Sélectionnez

</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.

 
Sélectionnez

;----------------------------------------------------------------------------------
; 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
Créé le 9 mars 2008  par Nico

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

 
Sélectionnez

;----------------------------------------------------------------
; 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.

 
Sélectionnez

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 << 32))
                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 
Mis à jour le 21 décembre 2008  par Nico

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.

 
Sélectionnez

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
Créé le 15 juin 2008  par Sparkie

L'archive contient les images et les sons, ainsi qu'un exécutable pour tester le programme sans PureBasic.

 
Sélectionnez

;========================================================================
; 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
Créé le 23 juin 2008  par netmaestro

Téléchargez le zip

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:

 
Sélectionnez

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 :

 
Sélectionnez

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
Créé le 23 juillet 2008  par Nico
 
Sélectionnez

; ************************************************
; 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) 
  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 
Créé le 16 mars 2008  par netmaestro, Sparkie
 
Sélectionnez

; 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
Créé le 10 août 2008  par Denis
Image non disponible

L'archive de 7 ko contient 3 fichiers PureBasic (4.30):

  • Le premier contient la déclaration d'une interface 'MenuColorPickerObject'
  • Le second la définition de cette interface.
  • Le troisième fichier contient un exemple d'utilisation (voir le code source ci-dessous et l'image ci-dessus).
 
Sélectionnez

;/////////////////////////////////////////////////////////////////////////////////
;Demo of the OOP class for implementing a menu color picker.

;By Stephen Rodriguez.

;Demonstrates some of the methods exposed by the 'MenuColorPickerObject' class.
;/////////////////////////////////////////////////////////////////////////////////

XIncludeFile "menuColorPickerClass.pbi"


;Our user-defined menu color picker callback.
  Procedure Callback(row, column, selectedItem, color)
    Debug "Hovering over color $" + RSet(Hex(color, #PB_Long), 8, "0")
  EndProcedure


;Create a menu color picker object.
  MyMenuColorPickerObject.MenuColorPickerObject
  MyMenuColorPickerObject = NewMenuColorPicker()

If MyMenuColorPickerObject
  ;Add some standard menu items. We must do this immediately after creating the object.
    MenuItem(1, "New")
    MenuBar()
    OpenSubMenu("File")
      MenuItem(2, "&Open" + Chr(9) + "Ctrl O")
      MenuItem(3, "&Close")
    CloseSubMenu()
    MenuBar()
  ;Add the colors. (This library will prevent you from placing the color items in a submenu.)
    MyMenuColorPickerObject\AddColors()
    MenuBar()
    MenuItem(4, "Exit")

  ;Set a user callback to receive notifications whilst the user is navigating the colors. This is of course optional.
    MyMenuColorPickerObject\SetUserCallback(@Callback())

  ;Open a window ready to diplay the color picker.
    If OpenWindow(0, 200, 200, 400, 400, "MenuColourPicker class demo")

      Repeat
        Select WaitWindowEvent()
          Case #WM_RBUTTONDOWN
            color.q = MyMenuColorPickerObject\DisplayColorPicker(WindowID(0))
            Debug "=============================================="
            If color = -1
              Debug "Cancelled!"
              MyMenuColorPickerObject\SetDefaultColor(-1) ;In case a subsequent call uses the 'More colors...' option.
            ElseIf color&$ffffffff00000000
              color = color>>32
              Debug "Selected menu item " + Str(color)
            Else
              Debug "Selected colour = $" + RSet(Hex(color, #PB_Long), 8, "0")
              MyMenuColorPickerObject\SetDefaultColor(color)  ;In case a subsequent call uses the 'More colors...' option.
            EndIf
          Case #PB_Event_CloseWindow
            Quit = 1
        EndSelect
      Until Quit = 1
    EndIf

  ;Destroy the object when no longer required.
    MyMenuColorPickerObject\Destroy()
Else
  MessageRequester("Error :", "There was a memory allocation problem creating the menu color picker object.")
EndIf
Créé le 27 février 2009  par srod

Téléchargez le zip

Ce code permet de retrouver le répertoire réel correspondant à un fichier ou répertoire système comme par exemple "Documents and Settings".
Le code fonctionne aussi bien sur un sytème 32 bits qu'un système 64 bits. Il fonctionnera avec toutes les versions basées sur NT, pas seulement sur Vista. Il renvoie le chemin d'origine sur les anciens systèmes.

 
Sélectionnez

; WinIoCtl.h
;
#FILE_DEVICE_FILE_SYSTEM         = $00000009
#METHOD_BUFFERED                 = 0
#FILE_ANY_ACCESS                 = 0
#FILE_SPECIAL_ACCESS             = (#FILE_ANY_ACCESS)

Macro CTL_CODE( DeviceType, Function, Method, Access )
  (((DeviceType) << 16) | ((Access) << 14) | ((Function) << 2) | (Method))
EndMacro

#FSCTL_SET_REPARSE_POINT         = CTL_CODE(#FILE_DEVICE_FILE_SYSTEM, 41, #METHOD_BUFFERED, #FILE_SPECIAL_ACCESS)
#FSCTL_GET_REPARSE_POINT         = CTL_CODE(#FILE_DEVICE_FILE_SYSTEM, 42, #METHOD_BUFFERED, #FILE_ANY_ACCESS)
#FSCTL_DELETE_REPARSE_POINT      = CTL_CODE(#FILE_DEVICE_FILE_SYSTEM, 43, #METHOD_BUFFERED, #FILE_SPECIAL_ACCESS)

; Winbase.h
;
#FILE_FLAG_OPEN_REPARSE_POINT    = $00200000

; WinNT.h
;
#IO_REPARSE_TAG_MOUNT_POINT  = $A0000003       
#IO_REPARSE_TAG_HSM          = $C0000004       
#IO_REPARSE_TAG_HSM2         = $80000006       
#IO_REPARSE_TAG_SIS          = $80000007       
#IO_REPARSE_TAG_DFS          = $8000000A       
#IO_REPARSE_TAG_SYMLINK      = $A000000C       
#IO_REPARSE_TAG_DFSR         = $80000012


; From Windows Driver Kit.
; http://msdn.microsoft.com/en-us/library/ms791514.aspx
;
Structure SymbolicLinkReparseBuffer
  SubstituteNameOffset.w
  SubstituteNameLength.w
  PrintNameOffset.w
  PrintNameLength.w
  Flags.l
  PathBuffer.w[1]
EndStructure

Structure MountPointReparseBuffer
  SubstituteNameOffset.w
  SubstituteNameLength.w
  PrintNameOffset.w
  PrintNameLength.w
  PathBuffer.w[1]
EndStructure

Structure GenericReparseBuffer
  DataBuffer.b[1]
EndStructure

Structure REPARSE_DATA_BUFFER
  ReparseTag.l
  ReparseDataLength.w
  Reserved.w
  StructureUnion
    SymbolicLinkReparseBuffer.SymbolicLinkReparseBuffer
    MountPointReparseBuffer.MountPointReparseBuffer
    GenericReparseBuffer.GenericReparseBuffer
  EndStructureUnion
EndStructure




; Tries to follow a directory link on Windows Vista (should also work for files)
;
; - If the directory is no link, the result is the original directory
; - If the target cannot be read, the result is ""
;
Procedure.s GetDirectoryTarget(Directory$)
  Protected TokenHandle, BufferSize, hDirectory, BytesReturned.l
  Protected Privileges.TOKEN_PRIVILEGES
  Protected *Buffer.REPARSE_DATA_BUFFER
  Protected Result$ = ""

  ; Check if the directory is a reparse point (link or mount point)
  ;
  If GetFileAttributes_(@Directory$) & #FILE_ATTRIBUTE_REPARSE_POINT

    ; The backup privilege is required to open a directory for io queries
    ; So try to set it on our process token. (usually it should be set already)
    ;
    If OpenProcessToken_(GetCurrentProcess_(), #TOKEN_ADJUST_PRIVILEGES, @TokenHandle)
      Privileges\PrivilegeCount = 1
      Privileges\Privileges[0]\Attributes = #SE_PRIVILEGE_ENABLED
   
      If LookupPrivilegeValue_(#Null, @"SeBackupPrivilege", @Privileges\Privileges[0]\Luid)       
        AdjustTokenPrivileges_(TokenHandle, #False, @Privileges, SizeOf(TOKEN_PRIVILEGES), #Null, #Null)
      EndIf   
      CloseHandle_(TokenHandle)
    EndIf
   
    ; Open the directory
    ;   Have to pass 0 as access right (not #GENERIC_READ), as it fails otherwise
    ;   http://www.codeproject.com/KB/vista/Windows_Vista.aspx
    ;
    hDirectory = CreateFile_(@Directory$, 0, #FILE_SHARE_READ|#FILE_SHARE_WRITE, #Null, #OPEN_EXISTING, #FILE_FLAG_OPEN_REPARSE_POINT | #FILE_FLAG_BACKUP_SEMANTICS, #Null)
    If hDirectory <> #INVALID_HANDLE_VALUE
   
      ; Allocate a buffer for the io query. 1000 bytes should be enough for the real path (in unicode)
      ;
      BufferSize = SizeOf(REPARSE_DATA_BUFFER) + 1000
      *Buffer = AllocateMemory(BufferSize)
     
      If *Buffer
       
        ; Query the directory for reparse point information
        ;
        If DeviceIoControl_(hDirectory, #FSCTL_GET_REPARSE_POINT, #Null, 0, *Buffer, BufferSize, @BytesReturned, #Null) <> 0
       
          ; Check the kind of reparse point (device drivers can create their own tags, so this is important)
          ; The "& $FFFFFFFF" is for 64bit, as the tags are negative when interpreted as quads
          ;
          If *Buffer\ReparseTag & $FFFFFFFF = #IO_REPARSE_TAG_MOUNT_POINT

            ; Read the result. The offset and length are in bytes. PeekS needs length in characters
            ;
            Result$ = PeekS(@*Buffer\MountPointReparseBuffer\PathBuffer[0] + *Buffer\MountPointReparseBuffer\SubstituteNameOffset, *Buffer\MountPointReparseBuffer\SubstituteNameLength / 2, #PB_Unicode)

          ElseIf *Buffer\ReparseTag & $FFFFFFFF = #IO_REPARSE_TAG_SYMLINK
         
            Result$ = PeekS(@*Buffer\SymbolicLinkReparseBuffer\PathBuffer[0] + *Buffer\SymbolicLinkReparseBuffer\SubstituteNameOffset, *Buffer\SymbolicLinkReparseBuffer\SubstituteNameLength / 2, #PB_Unicode)
           
          EndIf
       
        EndIf     
     
        FreeMemory(*Buffer)
      EndIf
   
      CloseHandle_(hDirectory)
    EndIf
 
  Else
 
    ; It is not a reparse point, so return the original path
    ;
    Result$ = Directory$
   
  EndIf
 
  ; Since the result is a unicode directory name, it can have the "\??\" prefix which allows a length of 32767 characters.
  ;
  If Left(Result$, 4) = "\??\"
    Result$ = Right(Result$, Len(Result$)-4)
  EndIf

  ProcedureReturn Result$
EndProcedure



; ----------------------------------------------------------------------------


Directory$ = "C:\Documents and Settings\"

Debug "Testing: " + Directory$
Debug "Target: " + GetDirectoryTarget(Directory$)
Créé le 11 avril 2009  par Freak

Ce code permet de changer le texte des boutons dans les boîtes de dialogue.

 
Sélectionnez

; PureBasic-Lounge.com
; Hroudtwolf
; Date: 20-02-2009
; Windows

Structure tDLGHook
   hHook.i
   sExpr.s [ $FF ]
EndStructure

Procedure _DLGHook ()
   Static this.tDLGHook
   
   ProcedureReturn this
EndProcedure

Procedure _DlGHookCB ( idMsg.i , wParam.i , lParam.i )
   Protected *this   .tDLGHook = _DLGHook ()
   Protected sBuffer .s        = Space ( $FF )
   
   Select idMsg
      Case #HCBT_ACTIVATE
      For nI = 0 To $FE
         If *this\sExpr [ nI ] And GetDlgItemText_( wParam , nI , @ sBuffer , $FF )
            SetDlgItemText_( wParam , nI , *this\sExpr [ nI ] )
         EndIf
      Next nI
     
   EndSelect
   
   ProcedureReturn #False
EndProcedure

Procedure DLGHook_Start ()
   Protected *this.tDLGHook = _DLGHook ()

   *this\hHook = SetWindowsHookEx_ ( #WH_CBT , @ _DlGHookCB () , GetModuleHandle_ ( #Null ) , GetCurrentThreadId_ () )
   
   ProcedureReturn #Null
EndProcedure

Procedure DLGHook_Stop ()
   Protected *this.tDLGHook = _DLGHook ()
   
   UnhookWindowsHookEx_( *this\hHook )
   
   ProcedureReturn #Null
EndProcedure

Procedure DLGHook_SetExpression ( idDLGItem.i , sText.s )
   Protected *this.tDLGHook = _DLGHook ()
   
   *this\sExpr [ idDLGItem ] = sText
   
   ProcedureReturn #Null
EndProcedure

;---- Test

; Start hooking
DLGHook_Start ()

; Set new texts for miscellaneous dialog items.
DLGHook_SetExpression ( #IDYES    , "Oh Ouiiiii" )
DLGHook_SetExpression ( #IDNO     , "Oh nooooon" )
DLGHook_SetExpression ( #IDCANCEL , "Plutôt mourir" )
DLGHook_SetExpression ( #IDOK     , "Bon d'accord" )

; A few of tests.
MessageRequester  ( "blup"  , "bla"  , #PB_MessageRequester_YesNoCancel )
MessageRequester  ( "blup"  , "bla"  , #PB_MessageRequester_YesNo )
MessageRequester  ( "blup"  , "bla"  , #PB_MessageRequester_Ok )
ColorRequester    ( 0 )
FontRequester     ( "Arial" , 12 , #PB_FontRequester_Effects )
OpenFileRequester ( "test" , "*.*" , "*.*" , 0 )

; Stop hooking.
DLGHook_Stop ()
Créé le 24 avril 2009  par Hroudtwolf

Voici un code mettant en place un Hook clavier global, tout ce que vous tapez dans n'importe quelle application est intercepté par le programme.

Le programme :

 
Sélectionnez

#Librairie=0
#WM_MONMESSAGE= #WM_USER+1

Structure Partage
  Hook.l
  HandleApplication.l
  HandleFocusClavier.l
  ActiverHook.l     
EndStructure

Global *Vue.Partage

Procedure ProcedureCallback(WindowID.l, Message.l, wParam.l, lParam.l)
 
  Resultat = #PB_ProcessPureBasicEvents
  Select Message
    Case #WM_MONMESSAGE
      ;Si wParam >0, alors on à un code ascii sinon c'est ue touche système
      If wParam>0
        ;Code ascii
        AddGadgetItem(0,-1,Chr(wParam))
      Else
        ;Code virtuel de la touche
        AddGadgetItem(0,-1,"Code virtuel de la touche="+Str(lParam))
      EndIf
     

  EndSelect
  ProcedureReturn Resultat
EndProcedure


If OpenWindow(0,0,0,200,200,"Capture du clavier",#PB_Window_ScreenCentered|#PB_Window_SystemMenu|#PB_Window_TitleBar)
 
  EditorGadget(0,10,10,180,140,#PB_Editor_ReadOnly)
  ButtonGadget(1,50,160,100,30,"Quitter")
  SetWindowCallback(@ProcedureCallback())
 
  StickyWindow(0,1)
 
  Hmodule = OpenLibrary(#Librairie,"Hook_Clavier_Global_dll.dll")
  If Hmodule=0
    MessageRequester("Info","La Dll (Hook_Clavier_Global_dll.dll) n'a pu être chargée!, le programme va se terminer")
    End
  EndIf
 
  *Vue=CallFunction(#Librairie, "Initialiser_Hook", WindowID(0),Hmodule)
  If *Vue=0
    MessageRequester("Info","L'installation du Hook a échoué!, le programme va se terminer")
    End
  EndIf
 
 
  Repeat
    Event = WaitWindowEvent()
    Select event
      Case #PB_Event_Gadget
        Select EventGadget()
          Case 1
            Quit=1
        EndSelect
       
      Case #WM_CLOSE
        Quit=1
    EndSelect
   
  Until Quit=1
 
  If *Vue<>0
    If CallFunction(#Librairie, "Fermeture_Hook")=0
      MessageRequester("Info","La désinstallation du Hook à échoué!")
    EndIf
  EndIf
 
EndIf

la DLL, à compiler sous le nom de Hook_Clavier_Global_dll.dll:

 
Sélectionnez

#WM_MONMESSAGE= #WM_USER+1

Structure Partage
  Hook.l
  HandleApplication.l
  HandleFocusClavier.l
  ActiverHook.l     
EndStructure


Global MemoirePartagee.l,*Vue.Partage
Global Dim Key.b(255)


Procedure.l Keyboard_Hook(nCode.l, wParam.l, lParam.l)
  ;Quel que soit le type de hook, La valeur nCode doit toujours être vérifiée
  ;car si elle est inférieur à 0, il faut passer l'évènement à la procédure
  ;d'interception suivante.
 
  If nCode < 0
    ProcedureReturn CallNextHookEx_(*Vue\Hook, nCode, wParam, lParam)
  EndIf
 
  If *Vue\ActiverHook=#True
    If nCode=#HC_ACTION
      If lParam & 2147483648=0 ;(Test du bit 31= 2^31  0 si enfoncé, 1 si relaché)
        ;
        Ascii.w=0
        GetKeyboardState_(@Key(0))
       
        ;Le paramètre wparam renvoie le code virtuel de la touche
        ;pour le convertir en Ascii si c'est un caractère, on utilise cette fonction
        ToAscii_(wParam,(lParam>>16) & $FF ,@Key(0),@Ascii,0)
       
        ; Control ayant le focus clavier
        *Vue\HandleFocusClavier=GetFocus_()

        PostMessage_(*Vue\HandleApplication,#WM_MONMESSAGE,Ascii, wParam)

      EndIf
    EndIf
  EndIf   
  ProcedureReturn CallNextHookEx_(*Vue\Hook, nCode, wParam, lParam)
EndProcedure

ProcedureDLL AttachProcess(Instance.l)
  MemoirePartagee=CreateFileMapping_($FFFFFFFF,#Null, #PAGE_READWRITE, 0, SizeOf(Partage),"Mapping")
  *Vue=MapViewOfFile_(MemoirePartagee, #FILE_MAP_WRITE, 0, 0, 0)
EndProcedure

ProcedureDLL DetachProcess(Instance.l)
  UnmapViewOfFile_(VueDonnees)
  CloseHandle_(MemoirePartagee)
EndProcedure
 
ProcedureDLL AttachThread(Instance.l)
EndProcedure
 
ProcedureDLL DetachThread(Instance.l)
EndProcedure
 
ProcedureDLL.L Initialiser_Hook(Handle.l,Hinst.l)
  Protected Hook.l
  *Vue\HandleApplication=Handle
  Hook.l = SetWindowsHookEx_(#WH_KEYBOARD,@Keyboard_Hook(),Hinst,0)
  If Hook = #False
    ProcedureReturn 0
  EndIf
  *Vue\Hook=Hook
  *Vue\ActiverHook=#True
  ProcedureReturn *Vue
EndProcedure   

ProcedureDLL.l Fermeture_Hook()
  Protected Result.l
  Result.l= UnhookWindowsHookEx_(*Vue\Hook)
  ProcedureReturn Result
EndProcedure
Créé le 5 juillet 2009  par Nico

Voici un exemple de Hooking sur le Bloc-notes (Testé sur Window XP), Tout d'abord, compilez cette Dll en unicode:

 
Sélectionnez

Global Dim hook.b(6)
Global *memoire
Global Library.s

Procedure.l HookFunction( *lpModule, *lpFuncName, *lpFunction, *lpBackup)
 
  dwAddr.l=GetProcAddress_(GetModuleHandle_(*lpModule), *lpFuncName)
 
  Dim jmp.b(5)
  jmp(0)=$e9 ;//jmp
  ;-------------------------
  jmp(1)=$00 ;//address
  jmp(2)=$00
  jmp(3)=$00
  jmp(4)=$00
  jmp(5)=$c3
 
  ReadProcessMemory_(GetCurrentProcess_(), dwAddr, *lpBackup, 6, 0)
 
  dwCalc.l=(*lpFunction-dwAddr-5);   //((to)-(from)-5)
 
  CopyMemory(@dwCalc,@jmp(1), 4);   //build the jmp
 
  WriteProcessMemory_(GetCurrentProcess_(), dwAddr, @jmp(), 6, 0)
 
  ProcedureReturn dwAddr
EndProcedure


Procedure.l UnHookFunction( *lpModule, *lpFuncName, *lpBackup)
 
  dwAddr.l=GetProcAddress_(GetModuleHandle_(*lpModule),*lpFuncName);
 
  If (WriteProcessMemory_(GetCurrentProcess_(), dwAddr, *lpBackup, 6, 0))
    ProcedureReturn #True
  Else
    ProcedureReturn #False
  EndIf
EndProcedure

Procedure.l MyMessageBox( hWnd.l, *lpText, *lpCaption, uType.l)
 
  UnHookFunction( @Library, *memoire, @hook())
 
  Message.s=PeekS(*lpText)+Chr(13)+"(MessageBox Hooked)"
  x.l=MessageBox_(hWnd, Message, PeekS(*lpCaption), uType)
 
  HookFunction ( @Library, *memoire, @MyMessageBox(), @hook())
  ProcedureReturn x
EndProcedure

; This procedure is called once, when the program loads the library
; for the first time. All init stuffs can be done here (but not DirectX init)
ProcedureDLL AttachProcess(Instance)
  API.s="MessageBoxW"
  Library="user32.dll"
 
  Longueur=MemoryStringLength(@API)
  *memoire=AllocateMemory(Longueur+1)
  PokeS(*memoire, API,-1,#PB_Ascii)
 
  HookFunction(@Library, *memoire, @MyMessageBox(), @hook())
EndProcedure

; Called when the program release (free) the DLL
;
ProcedureDLL DetachProcess(Instance)
EndProcedure

; Both are called when a thread in a program call or release (free) the DLL
;
ProcedureDLL AttachThread(Instance)
EndProcedure

ProcedureDLL DetachThread(Instance)
EndProcedure

Ensuite lancez le Bloc-notes, puis exécutez le code suivant qui permet d'injecter une Dll dans un exécutable.
Il va vous demander le Target Process Name, écrire Notepad.exe.
Ensuite, il va falloir lui indiquer la dll à injecter, indiquez celle que vous avez créée précédemment.
Tapez n'importe quoi dans le bloc-notes, cliquez sur la croix de fermeture ou faites menu--> fichier--> quitter.
Vous pouvez constater que le texte "MessageBox Hooked" est ajouté au message du Bloc-notes.

Le code qui permet d'injecter une Dll dans un exécutable:

 
Sélectionnez

; Code de SFSxOI
; Injecter une Dll dans un exécutable

Prototype.i PFNCreateToolhelp32Snapshot(dwFlags.i, th32ProcessID.i) ;
Prototype.b PFNProcess32First(hSnapshot.i, *lppe.PROCESSENTRY32) ;
Prototype.b PFNProcess32Next(hSnapshot.i, *lppe.PROCESSENTRY32) ;

Procedure GetPidByName(p_name$)
    Protected hDLL.i, process_name$
    Protected PEntry.PROCESSENTRY32, hTool32.i
    Protected pCreateToolhelp32Snapshot.PFNCreateToolhelp32Snapshot
    Protected pProcess32First.PFNProcess32First
    Protected pProcess32Next.PFNProcess32Next
    Protected pid.i
   
    hDLL = OpenLibrary(#PB_Any,"kernel32.dll")
   
    If hDLL
        pCreateToolhelp32Snapshot = GetFunction(hDLL,"CreateToolhelp32Snapshot")
        pProcess32First = GetFunction(hDLL,"Process32First")
        pProcess32Next = GetFunction(hDLL,"Process32Next")
    Else
        ProcedureReturn 0
    EndIf
   
    PEntry\dwSize = SizeOf(PROCESSENTRY32)
    hTool32 = pCreateToolhelp32Snapshot(#TH32CS_SNAPPROCESS, 0)
    pProcess32First(hTool32, @PEntry)
    process_name$ = Space(#MAX_PATH)
    CopyMemory(@PEntry\szExeFile,@process_name$,#MAX_PATH)
   
    If  UCase(process_name$) = UCase(p_name$)
        ProcedureReturn PEntry\th32ProcessID
    EndIf
   
    While pProcess32Next(hTool32, @PEntry) > 0
        process_name$ = Space(#MAX_PATH)
        CopyMemory(@PEntry\szExeFile,@process_name$,#MAX_PATH)
       
        If  UCase(process_name$) = UCase(p_name$)
            ProcedureReturn PEntry\th32ProcessID
        EndIf
   
    Wend
   
    CloseLibrary(hDLL)
   
    ProcedureReturn 0
EndProcedure

Procedure InjectLibA(dwProcessId.i, pszLibFile$)
  hProcess.i
  hThread.i
  lzLibFileRemote.i
  lSize.i
  endSize.i
  lsThreadRtn.i

  hProcess = OpenProcess_(#PROCESS_QUERY_INFORMATION | #PROCESS_CREATE_THREAD | #PROCESS_VM_OPERATION | #PROCESS_VM_WRITE, 0, dwProcessId)

  If hProcess = 0 : Goto ErrHandle : EndIf
  lSize = 1 + Len(pszLibFile$)
  endSize = lSize

  lzLibFileRemote = VirtualAllocEx_(hProcess, #Null, endSize, #MEM_COMMIT, #PAGE_READWRITE)

  If lzLibFileRemote = 0 : Goto ErrHandle : EndIf

  If (WriteProcessMemory_(hProcess, lzLibFileRemote, pszLibFile$, endSize, #Null) = 0) : Goto ErrHandle : EndIf

  OpenLibrary(0, "Kernel32.dll") : lsThreadRtn = GetFunction(0, "LoadLibraryA") : CloseLibrary(0)

  If lsThreadRtn = 0 : Goto ErrHandle : EndIf

  hThread = CreateRemoteThread_(hProcess, #Null, #Null, lsThreadRtn, lzLibFileRemote, #Null, #Null)

  If (hThread = 0) : Goto ErrHandle : EndIf

  WaitForSingleObject_(hThread, #INFINITE)

  If lzLibFileRemote<>0
    VirtualFreeEx_(hProcess, lzLibFileRemote, 0, #MEM_RELEASE)
    MessageRequester("Inject Status", "Injection Suceeded", 0)
    Else
    VirtualFreeEx_(hProcess, lzLibFileRemote, 0, #MEM_RELEASE)
    MessageRequester("Inject Status", "Injection Failed !!!", 0)
  EndIf
  End

  ErrHandle:
      CloseHandle_(hThread)
      CloseHandle_(hProcess)
EndProcedure

Input_proc$ = InputRequester("Simple DLL injector", "Please enter target process name (.exe):", "") ;enter process name i.e...notepad.exe
val_pid.i = GetPidByName(Input_proc$)
Delay(10)
File_dll$ = OpenFileRequester("Choose .dll file to inject", "C:\", "DLL File (*.dll)|*.dll;*.dll", 0)
Delay(10)
InjectLibA(val_pid, File_dll$)
Créé le 14 novembre 2009  par Nico
 
Sélectionnez

; Original Code in XProfan by frank abbing
; http://www.paules-pc-forum.de/forum/dlls-includes-units-prozeduren/134802-windows-product-key-auslesen.html

; rewritten to work with purebasic by ts-soft

; Plattform: windows only
; Supports 32 and 64 bit OS
; Supports Ascii and Unicode
; Requires PureBasic 4.40 and higher

EnableExplicit

#KEY_WOW64_64KEY = $100

Procedure.s GetWindowsProductKey()
  Protected hKey, Res, size = 280
  Protected i, j, x, Result.s
  Protected *mem = AllocateMemory(size)
  Protected *newmem = AllocateMemory(size)
  Protected *digits = AllocateMemory(25)
 
  PokeS(*digits, "BCDFGHJKMPQRTVWXY2346789", -1, #PB_Ascii)
  If OSVersion() <= #PB_OS_Windows_2000
    Res = RegOpenKeyEx_(#HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows NT\CurrentVersion", 0, #KEY_READ, @hKey)
  Else
    Res = RegOpenKeyEx_(#HKEY_LOCAL_MACHINE, "Software\Microsoft\Windows NT\CurrentVersion", 0, #KEY_READ | #KEY_WOW64_64KEY, @hKey)
  EndIf
  If Res = #ERROR_SUCCESS
    RegQueryValueEx_(hKey, "DigitalProductID", 0, 0, *mem, @size)
    RegCloseKey_(hKey)
    If size <> 280
      For i = 24 To 0 Step -1
        x = 0
        For j = 66 To 52 Step -1
          x = (x << 8) + PeekA(*mem + j)
          PokeA(*mem + j, x / 24)
          x % 24
        Next
        PokeA(*newmem + i, PeekA(*digits + x))
      Next
      For i = 0 To 15 Step 5
        Result + PeekS(*newmem + i, 5, #PB_Ascii) + "-"
      Next
      Result + PeekS(*newmem + 20, 5, #PB_Ascii)
    EndIf
  EndIf
  FreeMemory(*mem) : FreeMemory(*newmem) : FreeMemory(*digits)
  ProcedureReturn Result
EndProcedure

Debug GetWindowsProductKey()
Créé le 5 décembre 2010  par ts-soft
Image non disponible

Tout d'abord la routine qui va bien, et ensuite quelques exemples d'utilisation.

 
Sélectionnez

;The routine is for Windows only as it requires that you select a gdi pen into 
;the drawing DC before invoking the routine. 
;This pen is used to render the line (not the arrowheads) and is how any style 
;line is supported since you can use geometric pens etc.

CompilerIf Defined(INCLUDE_ARROWEDLINES, #PB_Constant)=0
#INCLUDE_ARROWEDLINES=1
;/////////////////////////////////////////////////////////////////////////////////
;***Arrowed Lines***
;
;©nxSoftWare 2010.
;=================
;   Stephen Rodriguez (srod)
;   Created with Purebasic 4.51 for Windows.
;
;   Platforms:  Windows.
;
;   Fully Unicode compliant and threadsafe.
;/////////////////////////////////////////////////////////////////////////////////

;-CONSTANTS.

;/////////////////////////////////////////////////////////////////////////////////
  ;The following constants are used for the arrowType parameter in the ArrowedLineXY function.
    #ARROWEDLINES_FROMEND         = 1
    #ARROWEDLINES_TOEND           = 2
    #ARROWEDLINES_BOTHENDS        = #ARROWEDLINES_FROMEND | #ARROWEDLINES_TOEND
;/////////////////////////////////////////////////////////////////////////////////


;-PUBLIC FUNCTIONS.

;/////////////////////////////////////////////////////////////////////////////////
;The following function draws an arrowed line. The line itself is drawn using the pen currently selected into the hdc.
;The arrowheads are drawn and filled with the specified color (they do not use the currently selected pen because for a filled arrow
;you really only get good results with a pen of thickness at most 1).
Procedure ArrowedLineXY(hdc, x1, y1, x2, y2, arrowLength, baseWidth, arrowType = #ARROWEDLINES_BOTHENDS, arrowColor = #Black)
  Protected lineLength.d, ratio.d, left, top, right, bottom, blnSwitchedPts, aLeft, aTop, aRight, aBottom
  Protected lambda.d, Dim vertices.POINT(2), i, brush, oldBrush, oldPen, t1
  ;Now check the parameters
    If arrowLength > 0 And baseWidth > 0 And arrowType = arrowType & #ARROWEDLINES_BOTHENDS
      lineLength = Sqr((x2 - x1)*(x2 - x1) + (y2 - y1)*(y2 - y1))
      If lineLength
        t1 = lineLength
        If arrowType & #ARROWEDLINES_FROMEND
          t1 - arrowLength
        EndIf
        If arrowType & #ARROWEDLINES_TOEND
          t1 - arrowLength
        EndIf
        If t1 >= 0
          lambda = baseWidth / lineLength / 2
          ;Calculate the adjusted end-points.
            ratio = arrowLength / lineLength
            If x1 < x2 Or (x1 = x2 And y1 < y2)
              left = x1 : top = y1 : right = x2 : bottom = y2
            Else
              left = x2 : top = y2 : right = x1 : bottom = y1
              blnSwitchedPts = #True
            EndIf
            aLeft = left : aTop = top : aRight = right : aBottom = bottom
            brush = CreateSolidBrush_(arrowColor)
            If brush
              oldBrush = SelectObject_(hdc, brush)
              oldPen = SelectObject_(hdc, GetStockObject_(#NULL_PEN))
              For i = #ARROWEDLINES_FROMEND To #ARROWEDLINES_TOEND
                If arrowType & i
                  If (i = #ARROWEDLINES_FROMEND And blnSwitchedPts = #False) Or (i = #ARROWEDLINES_TOEND And blnSwitchedPts = #True)
                    aLeft = (1 - ratio) * left + ratio * right
                    aTop = (1 - ratio) * top + ratio * bottom
                    vertices(0)\x = left : vertices(0)\y = top
                    vertices(1)\x = aLeft - lambda * (bottom - top) : vertices(1)\y = aTop + lambda * (right - left)
                    vertices(2)\x = aLeft<<1 - vertices(1)\x : vertices(2)\y = aTop<<1 - vertices(1)\y
                  Else
                    aRight = (1 - ratio) * right + ratio * left
                    aBottom = (1 - ratio) * bottom + ratio * top
                    vertices(0)\x = right : vertices(0)\y = bottom
                    vertices(1)\x = aRight - lambda * (bottom - top) : vertices(1)\y = aBottom + lambda * (right - left)
                    vertices(2)\x = aRight<<1 - vertices(1)\x : vertices(2)\y = aBottom<<1 - vertices(1)\y
                  EndIf
                  Polygon_(hdc, vertices(), 3)
                EndIf     
              Next
              SelectObject_(hdc, oldBrush)
              SelectObject_(hdc, oldPen)
              DeleteObject_(brush)
            EndIf
          ;Draw the main (truncated) line.
            MoveToEx_(hdc, aLeft, aTop, 0)
            LineTo_(hdc, aRight, aBottom)
        Else
          MoveToEx_(hdc, x1, y1, 0)
          LineTo_(hdc, x2, y2)
        EndIf
      EndIf
    Else ;Just draw the complete line.
      MoveToEx_(hdc, x1, y1, 0)
      LineTo_(hdc, x2, y2)
    EndIf
EndProcedure
;/////////////////////////////////////////////////////////////////////////////////

CompilerEndIf

Le premier exemple :

 
Sélectionnez

If OpenWindow(0, 0, 0, 300, 300, "Arrowed Lines demo", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
  If CreateImage(0, 300, 300)
    hdc = StartDrawing(ImageOutput(0))
    If hdc
      Box(0, 0, 300, 300, #White)
      oldPen = SelectObject_(hdc, GetStockObject_(#BLACK_PEN))
      ArrowedLineXY(hdc, 10, 20, 290, 20, 10, 10, #ARROWEDLINES_BOTHENDS)
      ArrowedLineXY(hdc, 290, 60, 10, 60, 10, 10, #ARROWEDLINES_BOTHENDS)
      ArrowedLineXY(hdc, 50, 100, 50, 200, 10, 10, #ARROWEDLINES_BOTHENDS)
      ArrowedLineXY(hdc, 100, 200, 100, 100, 10, 10, #ARROWEDLINES_BOTHENDS)
      SelectObject_(hdc, oldPen)
      StopDrawing()
      ImageGadget(0, 0, 0, 200, 200, ImageID(0))
    EndIf
  EndIf   
  Repeat
    Event = WaitWindowEvent()
  Until Event = #PB_Event_CloseWindow
EndIf

Et pour finir l'exemple qui a permis de réaliser l'image en tête de cette source :

 
Sélectionnez

;Create some pens.
  Dim arrowColor(100)
  Dim pen(100)
  arrowColor(0) = #Black
  pen(0) = CreatePen_(#PS_SOLID, 1, #Black)
  For i = 1 To 100
    arrowColor(i) = Random(#White)
    pen(i) = CreatePen_(#PS_DASH, 2 * Random(6) + 1, arrowColor(i))
  Next

;Draw 40 random lines each using a pen at random and with a random combination of arrow heads.
If OpenWindow(0, 0, 0, 500, 500, "Arrowed Lines demo", #PB_Window_SystemMenu | #PB_Window_ScreenCentered)
  If CreateImage(0, 500, 500)
    hdc = StartDrawing(ImageOutput(0))
    If hdc
      Box(0, 0, 500, 500, #White)
      For i = 1 To 40
        penIndex = Random(100)
        oldPen = SelectObject_(hdc, pen(penIndex))
        arrowHead = Random(2) + 1
        ArrowedLineXY(hdc, Random(500), Random(500), Random(500), Random(500), 20, 30, arrowHead, arrowColor(penIndex))
        SelectObject_(hdc, oldPen)
      Next
      StopDrawing()
      ImageGadget(0, 0, 0, 200, 200, ImageID(0))
    EndIf
  EndIf   
  Repeat
    Event = WaitWindowEvent()
  Until Event = #PB_Event_CloseWindow
EndIf

;Tidy up.
  For i = 0 To 100
    DeleteObject_(pen(i))
  Next
Créé le 8 mars 2011  par srod
  

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2008 Developpez Developpez LLC. Tous droits réservés Developpez LLC. Aucune reproduction, même partielle, ne peut être faite de ce site ni de l'ensemble de son contenu : textes, documents et images sans l'autorisation expresse de Developpez LLC. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.