Sources PureBasic
Sources PureBasicConsultez toutes les sources
Nombre d'auteurs : 41, nombre de sources : 88, dernière mise à jour : 13 août 2011
Sommaire→Windows- Connexion automatique sur un forum
- Fenêtre non cliquable (API Windows)
- 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
- Sélection d'une couleur dans un popup menu
- Résoudre les liens dans le système de fichiers Windows Vista
- Modification du texte des boutons dans les boîtes de dialogue.
- Comment mettre en place un hook clavier global ?
- Injection d'une DLL dans un exécutable et API hooking.
- Récupérer la clé produit de Windows (Windows product key)
- Comment tracer des lignes fléchées (Windows) ?
- 12.1. GDI+
(3)
- 12.2. RichEdit
(1)
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
<formEt 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
EndDataSectionCréé 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
EndMis à 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
EndDataSectionCréé 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
EndProcedureCréé le 23 juin 2008 par netmaestro
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
EndProcedureUn 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
EndIfCréé 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
EndCréé 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
EndDataSectionCréé le 10 août 2008 par Denis
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.")
EndIfCréé le 27 février 2009 par srod
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
EndIfla 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
EndProcedureCréé 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
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
;/////////////////////////////////////////////////////////////////////////////////
CompilerEndIfLe 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
EndIfEt 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))
NextCréé le 8 mars 2011 par srod