Publié : ven. 04/nov./2005 15:45
Tiens Droopy pour te remercier pour ta super lib:
Vous pouvez faire ce que vous voulez de ce code , comme d'habitude
Bon, il est pas en couleur mais ça ne saurait tarder, une petite erreur sur mon pc
Il y a encore plein d'améliorations à apporter sur toutes ces fonctions, je vous laisse le faire
Vous pouvez faire ce que vous voulez de ce code , comme d'habitude
Bon, il est pas en couleur mais ça ne saurait tarder, une petite erreur sur mon pc
Il y a encore plein d'améliorations à apporter sur toutes ces fonctions, je vous laisse le faire
Code : Tout sélectionner
; Gillou
; PureBasic 3.94
; Dernière mise à jour : 31/10/05
;- DESKTOP
; DIMENSION ECRAN LARGEUR, HAUTEUR, PROFONDEUR
; #ENUM_CURRENT_SETTINGS = -1
; #ENUM_REGISTRY_SETTINGS = -2
; DefType.DEVMODE dm
; EnumDisplaySettings_ (#Null, #ENUM_CURRENT_SETTINGS, @dm)
; xs = dm\dmPelsWidth
; ys = dm\dmPelsHeight
; ps = dm\dmBitsPerPel
DeclareDLL.s GetExePath()
ProcedureDLL GetDesktopHeight() ; Retourne la hauteur du bureau
SystemParametersInfo_(#SPI_GETWORKAREA, 0, @desktop.RECT, 0)
ProcedureReturn desktop\bottom-desktop\top
EndProcedure
ProcedureDLL GetDesktopWidth() ; Retourne la largeur du bureau
SystemParametersInfo_(#SPI_GETWORKAREA, 0, @desktop.RECT, 0)
ProcedureReturn desktop\right-desktop\left
EndProcedure
ProcedureDLL GetDesktopX() ; Retourne la position du bureau suivant l'horizontal
SystemParametersInfo_(#SPI_GETWORKAREA, 0, @desktop.RECT, 0)
ProcedureReturn desktop\left
EndProcedure
ProcedureDLL GetDesktopY() ; Retourne la position du bureau suivant la vertical
SystemParametersInfo_(#SPI_GETWORKAREA, 0, @desktop.RECT, 0)
ProcedureReturn desktop\Top
EndProcedure
Procedure.l UpdateWindowsProc(hWnd.l, *desktop.RECT)
If IsZoomed_(hWnd)
MoveWindow_(hWnd, *desktop\left, *desktop\top, *desktop\right-*desktop\left, *desktop\bottom-*desktop\top, #True)
EndIf
ProcedureReturn #True
EndProcedure
ProcedureDLL SetDesktopArea(x, y, width, height) ; Modifie les dimensions et la position du bureau
desktop.RECT
desktop\left=x
desktop\Top=y
desktop\Right=x+width
desktop\bottom=y+height
v=SystemParametersInfo_(#SPI_SETWORKAREA, 0, @desktop, #SPIF_SENDWININICHANGE)
EnumWindows_(@UpdateWindowsProc(), @desktop)
ProcedureReturn v
EndProcedure
;- FILE
ProcedureDLL.s GetFilePartWithoutExtension(File.s) ; Retourne le nom du fichier sans l'extension
File.s = GetFilePart(File.s)
If Len(GetExtensionPart(File.s)) <> 0
ProcedureReturn Left(File.s, Len(File.s) - Len(GetExtensionPart(File.s)) - 1)
EndIf
ProcedureReturn File.s
EndProcedure
ProcedureDLL.s ReadStringN(Number,Separator.s) ; Lit N ligne du fichier actuellement ouvert et place entre chaque ligne lue un separateur
For a=0 To number-1
If a=0
txt$=ReadString()
Else
txt$=txt$+separator+ReadString()
EndIf
Next
ProcedureReturn txt$
EndProcedure
ProcedureDLL.s GetShortPathName(path$) ; Retourne l'adresse courte de path$
ShortPath$ = Space(#MAX_PATH)
GetShortPathName_(Path$,@ShortPath$,#MAX_PATH)
ProcedureReturn shortpath$
EndProcedure
ProcedureDLL.s GetLongPathName(path$) ; Retourne l'adresse longue de path$
Global *POINTER_GetLongPathName
lib=OpenLibrary(#PB_Any,"kernel32.dll")
*POINTER_GetLongPathName=IsFunction(lib,"GetLongPathNameA")
temp=AllocateMemory(#MAX_PATH)
If CallFunctionFast(*POINTER_GetLongPathName,path$,temp,#MAX_PATH)
ProcedureReturn PeekS(temp)
EndIf
EndProcedure
ProcedureDLL ExistFile(File$) ; Retourne 1 si le fichier existe
If GetPathPart(file$)=""
file$=GetExePath()+file$
EndIf
If ExamineDirectory(0,GetPathPart(file$),"")
Repeat
fi=NextDirectoryEntry()
If fi=1
If GetFilePart(file$)=DirectoryEntryName()
ProcedureReturn 1
EndIf
EndIf
Until fi=0
EndIf
ProcedureReturn 0
EndProcedure
;- FILESYSTEM
Procedure LASDE(Directory.l, DirectoryName.s)
Global filel , filed , dirtemp , dirt$ , lista , listb , listc
If dirtemp=0
dirtemp=1
If Right(DirectoryName,1)<>"\" : DirectoryName=DirectoryName+"\" : EndIf
dirt$=DirectoryName
If filel=0 : NewList FileList.s() : filel=1 : Else : ClearList(FileList()) : EndIf
If filed=0 : NewList DirList.s() : filed=1 : Else : ClearList(DirList()) : EndIf
EndIf
Typ=ExamineDirectory(Directory, DirectoryName, "")
Typ = NextDirectoryEntry()
Repeat
Name$ = DirectoryEntryName()
If Typ = 1
AddElement(FileList()) : filelist()=DirectoryName+name$
ElseIf Typ = 2 And Left(Name$,1) <> "."
AddElement(dirList()) : dirlist()=DirectoryName+name$+"\"
LASDE(Directory+1,DirectoryName + Name$ + "\")
UseDirectory(Directory)
EndIf
Typ = NextDirectoryEntry()
Until Typ = 0
If dirt$=DirectoryName
lista=0
listb=0
ProcedureReturn CountList(filelist())+CountList(DirList())
EndIf
EndProcedure
ProcedureDLL ListAllSubDirectoryEntry(DirectoryName.s) ; Retourne le nombre d'objets contenus (Met en mémoire la liste des sous-objets)
Global Dir
Dir=0
If Right(DirectoryName,1)<>"\" : DirectoryName=DirectoryName+"\" : EndIf
ProcedureReturn LASDE(Dir,DirectoryName.s)
EndProcedure
ProcedureDLL.s NextSubDirectory() ; Retourne le nom du prochain sous-dossier
If dirtemp=1
If CountList(DirList())-1>=ListA
SelectElement(DirList(),ListA)
ListA=ListA+1
ProcedureReturn DirList()
Else
ListA=0
ProcedureReturn ""
EndIf
EndIf
EndProcedure
ProcedureDLL.s NextSubFile(Pattern.s) ; Retourne le nom du prochain sous-fichier
If dirtemp=1
If pattern="" Or pattern="*.*"
If CountList(FileList())-1>=ListB
SelectElement(FileList(),ListB)
ListB=ListB+1
ProcedureReturn FileList()
Else
ProcedureReturn ""
EndIf
Else
ext$=UCase(GetExtensionPart(pattern))
For a=0 To CountList(FileList())-1
SelectElement(FileList(),a)
If UCase(GetExtensionPart(FileList()))=ext$
c=c+1
If c=ListC
ListC=ListC+1
ProcedureReturn FileList()
EndIf
EndIf
Next
ProcedureReturn ""
EndIf
EndIf
EndProcedure
ProcedureDLL.f DirectorySize(Directory.l,DirectoryName.s, Scale.l) ; Retourne la taille du dossier en octet, si scale=0, en ko, si scale=1,...
If Right(DirectoryName, 1)<>"\" : DirectoryName=DirectoryName+"\" : EndIf
If ExamineDirectory(Directory, DirectoryName, "*.*")
Repeat
Entry.l = NextDirectoryEntry()
If Entry = 1
Size.f =size.f+ (DirectoryEntrySize() / Pow(1024,scale))
ElseIf Entry = 2
Name.s = DirectoryEntryName()
If Name <> ".." And Name <> "."
Size.f=size.f + DirectorySize(Directory+1,DirectoryName + Name + "\",scale)
UseDirectory(Directory)
EndIf
EndIf
Until Entry = 0
EndIf
ProcedureReturn Size.f
EndProcedure
ProcedureDLL GetDiskFreeSpace(Drive.s) ; Retourne l'espace disque restant en Mo
; this prevents the 'please insert drive' requester.
; GetDiskFreeSpaceEx_() will just return 0 if the drive is not available,
; without a prompt to the user:
SetErrorMode_(#SEM_FAILCRITICALERRORS)
If GetDiskFreeSpaceEx_( @drive.s, BytesFreeToCaller.int64, TotalBytes.int64, TotalFreeBytes.int64) = 0
MessageRequester("", "Drive not ready!")
End
EndIf
; reset the error behaviour
SetErrorMode_(0)
; calculate sizes in mb.
FreeMB = ((TotalFreeBytes\Long1 >> 20) & $FFF) | (TotalFreeBytes\Long2 << 12)
ProcedureReturn FreeMB
EndProcedure
ProcedureDLL GetDiskTotalSpace(Drive.s) ; Retourne l'espace disque total en Mo
; this prevents the 'please insert drive' requester.
; GetDiskFreeSpaceEx_() will just return 0 if the drive is not available,
; without a prompt to the user:
SetErrorMode_(#SEM_FAILCRITICALERRORS)
If GetDiskFreeSpaceEx_( @drive.s, BytesFreeToCaller.int64, TotalBytes.int64, TotalFreeBytes.int64) = 0
MessageRequester("", "Drive not ready!")
End
EndIf
; reset the error behaviour
SetErrorMode_(0)
; calculate sizes in mb.
TotalMB = ((TotalBytes\Long1 >> 20) & $FFF) | (TotalBytes\Long2 << 12)
ProcedureReturn TotalMB
EndProcedure
ProcedureDLL GetDrives() ; Retourne le nombre de lecteur présent sur l'ordinateur
Global listdriv
;#DRIVE_UNKNOWN
;#DRIVE_NO_ROOT_DIR
;#DRIVE_REMOVABLE
;#DRIVE_FIXED
;#DRIVE_REMOTE
;#DRIVE_CDROM
;#DRIVE_RAMDISK
If listdriv=0 : listdriv=1 : NewList Drive.s() : AddElement(drive()) : Else : ClearList(drive()) : EndIf
bitmask.l = GetLogicalDrives_() ; not a PB Function, its Windows API (becourse of the '_' )
; each bit represents one drive.
one.l = 1
For i = 0 To 31 ; go from bit 0 to 31.
If bitmask & one<<i ; the 'one<<i' thingy is a bit tricky, what it does is something like 2^i
AddElement(drive()) ; '&' is bitwise AND operator, so if the bit i is one, the whole thing returns true.
typ=GetDriveType_(Chr(65+i)+":\")
drive()=Chr(65+i)+"|"+Str(typ) ; add the driveletter to the string.
EndIf
Next i
ProcedureReturn CountList(drive())-1
EndProcedure
ProcedureDLL.s SelectDrive(Number) ; Retourne la lettre du nième lecteur (le premier lecteur est le numéro 1) (la fonction GetDrives doit être initialisé au paravant)
Global ndriv
If listdriv And number<=CountList(drive())
ndriv=number
SelectElement(drive(),number)
ProcedureReturn StringField(drive(),1,"|")
EndIf
EndProcedure
ProcedureDLL DriveType() ; Retourne le type du lecteur choisi avec la fonction SelectDrive
If listdriv=1 And ndriv>0
ProcedureReturn Val(StringField(drive(),2,"|"))
EndIf
EndProcedure
;- GADGET
ProcedureDLL SetGadgetReadOnly(GadgetID.l, State.l) ; Active ou désactive le mode lecture seule du gadget choisi
ProcedureReturn SendMessage_(GadgetID, #EM_SETREADONLY, State, 0)
EndProcedure
ProcedureDLL SpinEvent(idgadget, Min,Max,texte) ; Gere automatiquement les actions faites sur le spingadget choisi (si texte=1 les textes sont autorisés)
Global boucler , DimMax
NID=Abs(idgadget)
If DimMax=0 : Dim mem(#MAXLONG) : DimMax=1 : EndIf
If GetAsyncKeyState_(48) & 1 Or GetAsyncKeyState_(49) & 1 Or GetAsyncKeyState_(50) & 1 Or GetAsyncKeyState_(51) & 1 Or GetAsyncKeyState_(52) & 1 Or GetAsyncKeyState_(53) & 1 Or GetAsyncKeyState_(54) & 1 Or GetAsyncKeyState_(55) & 1 Or GetAsyncKeyState_(56) & 1 Or GetAsyncKeyState_(57) & 1
BOUCLER = 1
If texte=0
If Val(GetGadgetText(idgadget))>Max : SetGadgetState(idgadget, max) : SetGadgetText(idgadget, Str(max)) : EndIf
EndIf
Else
If BOUCLER = 0
If Str(Val(GetGadgetText(idgadget))) = GetGadgetText(idgadget)
If Val(GetGadgetText(idgadget)) = mem(Nid)
SetGadgetText(idgadget, Str(GetGadgetState(idgadget)))
mem(Nid) = GetGadgetState(idgadget)
Else
mem(Nid) = Val(GetGadgetText(idgadget))
SetGadgetState(idgadget, mem(Nid))
EndIf
EndIf
If texte = 0
SetGadgetText(idgadget, Str(GetGadgetState(idgadget)))
EndIf
Else
BOUCLER = 0
EndIf
EndIf
ProcedureReturn IsGadget(idgadget)
EndProcedure
ProcedureDLL GetGadgetTextSize(Gadget.l,Type.l,String.s) ; Retourne la dimension du texte (Type = #TEXTLENGTH ou Type=#TEXTHEIGHT)
#TEXTLENGTH = 0
#TEXTHEIGHT = 1
hGadget = GadgetID(GadgetNr)
If hGadget
hFont = SendMessage_(hGadget,#WM_GETFONT,0,0)
hDC = GetDC_(hGadget)
If hFont
SelectObject_(hDC,hFont)
EndIf
If GetTextExtentPoint32_(hDC,String,Len(String),@TextSize.SIZE)
If Type = #TEXTLENGTH ; Text-Length
RetVal = TextSize\cx
ElseIf Type = #TEXTHEIGHT ; Text-Height
RetVal = TextSize\cy
EndIf
EndIf
ReleaseDC_(hGadget,hDC)
EndIf
ProcedureReturn RetVal
EndProcedure
ProcedureDLL EditorGadget_CursorX(Gadget) ; Renvoie la position du curseur sur la ligne en cours
; returns X-Pos of Cursor
REG = GadgetID(Gadget)
SendMessage_(REG,#EM_EXGETSEL,0,Range.CHARRANGE)
ProcedureReturn (Range\cpMax-(SendMessage_(REG,#EM_LINEINDEX,SendMessage_(REG,#EM_EXLINEFROMCHAR,0,Range\cpMin),0))+1)
EndProcedure
ProcedureDLL EditorGadget_CursorY(Gadget) ; Renvoie le numéro de la ligne en cours d'ecriture
; returns Y-Pos of Cursor
REG = GadgetID(Gadget)
SendMessage_(REG,#EM_EXGETSEL,0,Range.CHARRANGE)
ProcedureReturn SendMessage_(REG,#EM_EXLINEFROMCHAR,0,Range\cpMin)+1
EndProcedure
ProcedureDLL EditorGadget_CursorPos(Gadget) ; Renvoie la position du curseur
; returns relative Position of Cursor
SendMessage_(GadgetID(Gadget),#EM_EXGETSEL,0,Range.CHARRANGE)
ProcedureReturn Range\cpMax
EndProcedure
ProcedureDLL EditorGadget_Locate(Gadget,colonne,ligne) ; Positionne le curseur à la position choisie
; Set cursor position
REG = GadgetID(Gadget)
CharIdx = SendMessage_(REG,#EM_LINEINDEX,y-1,0)
LLength = SendMessage_(REG,#EM_LINELENGTH,CharIdx,0)
If LLength >= x-1
CharIdx + x-1
EndIf
Range.CHARRANGE
Range\cpMin = CharIdx
Range\cpMax = CharIdx
SendMessage_(REG,#EM_EXSETSEL,0,Range)
EndProcedure
ProcedureDLL EditorGadget_SelectedTextStart(Editor) ; Renvoie la position de début du texte sélectionné
SendMessage_(GadgetID(Editor),#EM_GETSEL,@CSP, @CEP)
ProcedureReturn CSP
EndProcedure
ProcedureDLL EditorGadget_SelectedTextStop(Editor) ; Renvoie la position de fin du texte sélectionné
SendMessage_(GadgetID(Editor),#EM_GETSEL,@CSP, @CEP)
ProcedureReturn CEP
EndProcedure
ProcedureDLL EditorGadget_Select(Editor, SelectStart, SelectEnd) ; Sélectionne le texte positionné entre SelectStart et SelectEnd
ProcedureReturn SendMessage_(GadgetID(Editor), #EM_SETSEL, Selectstart,Selectend)
EndProcedure
ProcedureDLL EditorGadget_Select_2(Gadget, LineStart.l, CharStart.l, LineEnd.l, CharEnd.l) ; Sélectionne le texte positionné entre LineStart, CharStart et LineEnd, CharEnd
sel.CHARRANGE
sel\cpMin = SendMessage_(GadgetID(Gadget), #EM_LINEINDEX, LineStart, 0) + CharStart - 1
If LineEnd = -1
LineEnd = SendMessage_(GadgetID(Gadget), #EM_GETLINECOUNT, 0, 0)-1
EndIf
sel\cpMax = SendMessage_(GadgetID(Gadget), #EM_LINEINDEX, LineEnd, 0)
If CharEnd = -1
sel\cpMax + SendMessage_(GadgetID(Gadget), #EM_LINELENGTH, sel\cpMax, 0)
Else
sel\cpMax + CharEnd - 1
EndIf
SendMessage_(GadgetID(Gadget), #EM_EXSETSEL, 0, @sel)
EndProcedure
ProcedureDLL.s EditorGadget_SelectedText(Editor) ; Renvoie le texte sélectionné
ProcedureReturn Mid(GetGadgetText(Editor),EditorGadget_SelectedTextStart(Editor)+1,EditorGadget_SelectedTextStop(Editor)-EditorGadget_SelectedTextStart(Editor))
EndProcedure
ProcedureDLL.l EditorGadget_ReplaceText(Editor, KeyStart$, KeyStop$,Text$) ; Permet d'encadrer le texte sélectionné par KeyStart$ et KeyStop$ (si Text$ est précisé le texte sélectionné sera remplacé par Text$)
TextSelect$=EditorGadget_SelectedText(Editor)
Editor$=GetGadgetText(Editor)
If TextSelect$
TextAvant$=Left(Editor$, EditorGadget_SelectedTextStart(Editor))
TextApres$=Right(Editor$, Len(Editor$)-EditorGadget_SelectedTextStop(Editor))
If text$<>""
TextSelect$=text$
EndIf
Else
ns=CountString(Editor$,Chr(13))*2
TextAvant$=Left(Editor$, Editor_CursorPos(Editor)+ns)
TextApres$=Right(Editor$,Len(Editor$)-EditorGadget_CursorPos(Editor)-ns)
TextSelect$=text$
EndIf
ProcedureReturn SetGadgetText(Editor, Textavant$+keyStart$+TextSelect$+keyStop$+TextApres$)
EndProcedure
ProcedureDLL EditorGadget_InsertText(Editor,Text$) ; Insére le texte à la position
ProcedureReturn SendMessage_(GadgetID(gadget),#EM_REPLACESEL,0,Text$)
EndProcedure
ProcedureDLL EditorGadget_BackgroundColor(Gadget, Color.l) ; Change la couleur de fond de l'éditeur
format.CHARFORMAT2
format\cbSize = SizeOf(CHARFORMAT2)
format\dwMask = $4000000 ; = #CFM_BACKCOLOR
format\crBackColor = Color
SendMessage_(GadgetID(Gadget), #EM_SETCHARFORMAT, #SCF_SELECTION, @format)
EndProcedure
ProcedureDLL EditorGadget_Color(Gadget, Color.l) ; Change la couleur du texte sélectionné
format.CHARFORMAT
format\cbSize = SizeOf(CHARFORMAT)
format\dwMask = #CFM_COLOR
format\crTextColor = Color
SendMessage_(GadgetID(Gadget), #EM_SETCHARFORMAT, #SCF_SELECTION, @format)
EndProcedure
ProcedureDLL EditorGadget_FontSize(Gadget, Fontsize.l) ; Change la taille de la police du texte sélectionné
format.CHARFORMAT
format\cbSize = SizeOf(CHARFORMAT)
format\dwMask = #CFM_SIZE
format\yHeight = FontSize*20
SendMessage_(GadgetID(Gadget), #EM_SETCHARFORMAT, #SCF_SELECTION, @format)
EndProcedure
ProcedureDLL EditorGadget_Font(Gadget, FontName.s) ; Change la police du texte sélectionné
format.CHARFORMAT
format\cbSize = SizeOf(CHARFORMAT)
format\dwMask = #CFM_FACE
PokeS(@format\szFaceName, FontName)
SendMessage_(GadgetID(Gadget), #EM_SETCHARFORMAT, #SCF_SELECTION, @format)
EndProcedure
ProcedureDLL EditorGadget_Format(Gadget, Flags.l) ; Change le format du texte sélectionné (#CFM_BOLD, #CFM_ITALIC, #CFM_UNDERLINE, #CFM_STRIKEOUT)
format.CHARFORMAT
format\cbSize = SizeOf(CHARFORMAT)
format\dwMask = #CFM_ITALIC|#CFM_BOLD|#CFM_STRIKEOUT|#CFM_UNDERLINE
format\dwEffects = Flags
SendMessage_(GadgetID(Gadget), #EM_SETCHARFORMAT, #SCF_SELECTION, @format)
EndProcedure
;- IMAGE
ProcedureDLL ImageToTable(Image, Table) ; Retourne 1 si l'image a été chargée dans le tableau ImageID=#Image : Table=@Tableau(), ex : Dim Tableau(ImageWidth(),ImageHeight()) -> @Tableau()
If Image>=0 And Table
UseImage(Image)
ImageID=ImageID()
Hdc = CreateCompatibleDC_(GetDC_(ImageID))
If HDC
bmi.BITMAPINFO
bm.BITMAP
GetObject_(ImageID, SizeOf(BITMAP), @bm.BITMAP)
bmi\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
bmi\bmiheader\biWidth = bm\bmWidth
bmi\bmiheader\biHeight = bm\bmHeight
bmi\bmiheader\biPlanes = 1
bmi\bmiheader\biBitCount = 32
bmi\bmiheader\biCompression = #BI_RGB
HList = AllocateMemory(bm\bmWidth*bm\bmHeight*4)
GetDIBits_(hDC,ImageID,0,bm\bmHeight,HList,bmi,#DIB_RGB_COLORS)
For nn = 0 To bm\bmWidth - 1
For n = 0 To bm\bmHeight - 1
s = HList + nn * 4 + (bm\bmHeight - 1 - n) * bm\bmWidth * 4
d = Table + n * 4 + nn * bm\bmHeight * 4
CopyMemory(s + 2, d, 1)
CopyMemory(s + 1, d + 1, 1)
CopyMemory(s, d + 2, 1)
Next n
Table+4
Next nn
Else
ProcedureReturn 0
EndIf
ProcedureReturn 1
Else
ProcedureReturn 0
EndIf
EndProcedure
ProcedureDLL TableToImage(Image, Table) ; Crée une image à partir du tableau Image=#Image, Table=@Tableau(), ex : Dim Tableau(ImageWidth(),ImageHeight()) -> @Tableau()
If Image>=0 And Table
UseImage(Image)
ImageID=ImageID()
bm.BITMAP
GetObject_(ImageID, SizeOf(BITMAP), @bm.BITMAP)
bmi.BITMAPINFO
bmi\bmiHeader\biSize = SizeOf(BITMAPINFOHEADER)
bmi\bmiheader\biWidth = bm\bmWidth
bmi\bmiheader\biHeight = bm\bmHeight
bmi\bmiheader\biPlanes = 1
bmi\bmiheader\biBitCount = 32
bmi\bmiheader\biCompression = #BI_RGB
pixel=AllocateMemory(bm\bmHeight*bm\bmWidth*4)
For nn = 0 To bm\bmwidth - 1
For n = 0 To bm\bmheight - 1
s = Table + n * 4 + nn * bm\bmHeight * 4
d = pixel + nn * 4 + (bm\bmHeight - 1 - n) * bm\bmWidth * 4
CopyMemory(s, d + 2, 1)
CopyMemory(s + 1, d + 1, 1)
CopyMemory(s + 2, d, 1)
Next
table + 4
Next
HDC=StartDrawing(ImageOutput())
SetDIBits_(HDC,ImageID,0,ImageHeight(), pixel, bmi, #DIB_RGB_COLORS)
StopDrawing()
FreeMemory(pixel)
ProcedureReturn 1
Else
ProcedureReturn 0
EndIf
EndProcedure
ProcedureDLL.s OpenImageRequester(Title.s, DefaultPath.s) ; Retourne le fichier sélectionné
UseJPEGImageDecoder()
UsePNGImageDecoder()
UseTGAImageDecoder()
UseTIFFImageDecoder()
UseEC_OLEImageDecoder()
ProcedureReturn OpenFileRequester(Title.s,DefaultPath.S,"Images (JPG, BMP, PNG, TGA, TIFF, ICO, CUR, WMF, EMF)|*.jpg;*.jpeg;*.bmp;*.tga;*.tiff*.png;*.ico;*.cur;*.wmf;*.emf",0)
EndProcedure
ProcedureDLL.s OpenImageRequester2(Title.s, DefaultPath.s, Flags) ; Retourne le fichier sélectionné
UseJPEGImageDecoder()
UsePNGImageDecoder()
UseTGAImageDecoder()
UseTIFFImageDecoder()
UseEC_OLEImageDecoder()
ProcedureReturn OpenFileRequester(Title.s,DefaultPath.S,"Images (JPG, BMP, PNG, TGA, TIFF, ICO, CUR, WMF, EMF)|*.jpg;*.jpeg;*.bmp;*.tga;*.tiff*.png;*.ico;*.cur;*.wmf;*.emf",0,Flags)
EndProcedure
;- MATH
ProcedureDLL IsInteger(Number.f) ; Retourne 1 si le nombre est entier
If Round(number, 1) = number And Round(number, 0) = number
ProcedureReturn 1
EndIf
EndProcedure
ProcedureDLL IsOddNumber(Number.l) ; Retourne 1 si le nombre est impair
ProcedureReturn Number & 1
EndProcedure
ProcedureDLL IsPrimeNumber(Number.l) ; Retourne 1 si le nombre est premier
; algorithme de Knuth
Global list
If list = 0 : NewList listNP() : list = 1 : Else : ClearList(listNP()) : EndIf
AddElement(listNP()) : listNP() = 2
If IsOddNumber(number)
If number > 2
For a = 3 To Int(Round(Sqr(number), 1)) Step 2
v = 0
nbl = CountList(listNP())
For b = 0 To nbl - 1
SelectElement(listNP(), b)
If IsInteger(a / listNP()) = 0
v = v + 1
EndIf
Next
If v = nbl
AddElement(listNP())
listNP() = a
EndIf
Next
ElseIf number<2
ProcedureReturn 0
EndIf
v = 0
For a = 0 To CountList(listNP()) - 1
SelectElement(listNP(), a)
If IsInteger(number / listNP())
v = 1
EndIf
Next
If v = 0
ProcedureReturn 1
EndIf
Else
If number = 2
ProcedureReturn 1
EndIf
EndIf
EndProcedure
ProcedureDLL PrimeNumberList(Number.l) ; Retourne le nième nombre premier
;num = 2147483647
; algorithme de Knuth
;Global list2
;If list2 = 0 : NewList listNP2() : list2 = 1 : Else : ClearList(listNP2()) : EndIf
;AddElement(listNP2()) : listNP2() = 2
;If Number = < 0
; ProcedureReturn 0
;ElseIf Number = 1
; ProcedureReturn 2
;Else
; For a = 3 To num Step 2
; v = 0
; nbl = CountList(listNP2())
; For b = 0 To nbl - 1
; SelectElement(listNP2(), b)
; If Integer(a / listNP2()) = 0
; v = v + 1
; EndIf
; Next
; If v = nbl
; AddElement(listNP2())
; listNP2() = a
; If CountList(listNP2()) = Number
; SelectElement(listNP2(), Number - 1)
; ProcedureReturn listNP2()
; EndIf
; EndIf
; Next
;EndIf
If number = 1
ProcedureReturn 2
ElseIf number > 1
For a=3 To 2147483647 Step 2
If IsPrimeNumber(a)
b=b+1
If b=number
ProcedureReturn a
EndIf
EndIf
Next
EndIf
EndProcedure
Procedure.s nb2txt(Number)
num.s=Str(number)
Dim nb.s(100)
nb(1)="un"
nb(2)="deux"
nb(3)="trois"
nb(4)="quatre"
nb(5)="cinq"
nb(6)="six"
nb(7)="sept"
nb(8)="huit"
nb(9)="neuf"
nb(10)="dix"
nb(11)="onze"
nb(12)="douze"
nb(13)="treize"
nb(14)="quatorze"
nb(15)="quinze"
nb(16)="seize"
nb(17)="dix-sept"
nb(18)="dix-huit"
nb(19)="dix-neuf"
nb(20)="vingt"
nb(30)="trente"
nb(40)="quarante"
nb(50)="cinquante"
nb(60)="soixante"
nb(70)="soixante-dix"
nb(80)="quatre-vingt"
nb(90)="quatre-vingt-dix"
nb(28)="cent"
nb(29)="cents"
nb(31)="mille"
nb(32)="million"
nb(33)="millions"
nb(34)="milliard"
nb(35)="milliards"
If Len(num)=3
If Val(Left(num,1))>1 And Val(Right(num,2))=0
numb.s=nb(Val(Left(num,1)))+" "+nb(29)
ElseIf Val(Left(num,1))>1 And Val(Right(num,2))<>0
numb.s=nb(Val(Left(num,1)))+" "+nb(28)
Else
numb=nb(28)
EndIf
If Val(Right(num,2))>10 And Val(Right(num,2))<20
numb=numb+" "+nb(Val(Right(num,2)))
ElseIf Val(Right(num,2))>70 And Val(Right(num,2))<80
If Val(Right(num,2))=71
numb=numb+" "+nb(60)+"-et-"+nb(10+Val(Right(num,1)))
Else
numb=numb+" "+nb(60)+"-"+nb(10+Val(Right(num,1)))
EndIf
ElseIf Val(Right(num,2))>90 And Val(Right(num,2))<100
numb=numb+" "+nb(80)+"-"+nb(10+Val(Right(num,1)))
ElseIf Val(Right(num,2))=21 Or Val(Right(num,2))=31 Or Val(Right(num,2))=41 Or Val(Right(num,2))=51 Or Val(Right(num,2))=61
numb=numb+" "+nb(10*Val(Mid(num,2,1)))+"-et-"+nb(Val(Right(num,1)))
Else
If Val(Mid(num,2,1))<>0
numb=numb+" "+nb(Val(Mid(num,2,1))*10)
b=1
EndIf
If Val(Right(num,1))<>0
If b=1 : int.s="-" : Else : int.s=" " : EndIf
numb=numb+int+nb(Val(Right(num,1)))
EndIf
EndIf
ElseIf Len(num)=2
If Val(num)>10 And Val(num)<20
numb=nb(Val(num))
ElseIf Val(num)>70 And Val(num)<80
If Val(num)=71
numb=nb(60)+"-et-"+nb(10+Val(Right(num,1)))
Else
numb=nb(60)+"-"+nb(10+Val(Right(num,1)))
EndIf
ElseIf Val(num)>90 And Val(num)<100
numb=nb(80)+"-"+nb(10+Val(Right(num,1)))
ElseIf Val(num)=21 Or Val(num)=31 Or Val(num)=41 Or Val(num)=51 Or Val(num)=61
numb=nb(10*Val(Left(num,1)))+"-et-"+nb(Val(Right(num,1)))
Else
If Val(Left(num,1))<>0
numb=nb(Val(Left(num,1))*10)
b=1
EndIf
If Val(Right(num,1))<>0
If b=1 : int.s="-" : Else : int.s=" " : EndIf
numb=numb+int+nb(Val(Right(num,1)))
EndIf
EndIf
Else
If Val(Right(num,1))<>0
numb=nb(Val(Right(num,1)))
EndIf
EndIf
ProcedureReturn numb
EndProcedure
ProcedureDLL.s NbToTxt(Number.l) ; Retourne sous forme texte le nombre choisie entre -2147483648 et +2147483647
If number<0
num.s="moins "
number=Abs(number)
Else
num.s=""
EndIf
lon=Len(Str(number))
If number=0
ProcedureReturn "zéro"
EndIf
If lon<4
num.s=num+nb2txt(number)
ElseIf lon>3 And lon<7
If Val(Right(Str(number),3))=0
num.s=num+nb2txt(Val(Left(Str(number),lon-3)))+" "+nb(31)
Else
num.s=num+nb2txt(Val(Left(Str(number),lon-3)))+" "+nb(31)+" "+nb2txt(Val(Right(Str(number),3)))
EndIf
ElseIf lon>6 And lon<10
If Val(Left(Str(number),lon-6))>1
num.s=num+nb2txt(Val(Left(Str(number),lon-6)))+" "+nb(33)
Else
num.s=num+nb2txt(Val(Left(Str(number),lon-6)))+" "+nb(32)
EndIf
If Val(Right(Str(number),6))>0
num.s=num.s+" "+NbToTxt(Val(Right(Str(number),6)))
EndIf
ElseIf lon>9 And lon<13
If Val(Left(Str(number),lon-9))>1
num.s=num+nb2txt(Val(Left(Str(number),lon-9)))+" "+nb(35)
Else
num.s=num+nb2txt(Val(Left(Str(number),lon-9)))+" "+nb(34)
EndIf
If Val(Right(Str(number),9))>0
num.s=num.s+" "+NbToTxt(Val(Right(Str(number),9)))
EndIf
EndIf
ProcedureReturn num
EndProcedure
ProcedureDLL.f Cosd( Angle.f ) ; Retourne le cos d'un angle en degré
ProcedureReturn Cos( Angle * 0.0174533 )
EndProcedure
ProcedureDLL.f Sind( Angle.f ) ; Retourne le sin d'un angle en degré
ProcedureReturn Sin( Angle * 0.0174533 )
EndProcedure
;- MOUSE
ProcedureDLL ScreenMouseX() ; Retourne la position en x de la souris
GetCursorPos_(CursorPos.POINT)
ProcedureReturn CursorPos\x
EndProcedure
ProcedureDLL ScreenMouseY() ; Retourne la position en y de la souris
GetCursorPos_(CursorPos.POINT)
ProcedureReturn CursorPos\y
EndProcedure
ProcedureDLL SetMousePos(x,y) ; Modifie la position de la souris
ProcedureReturn SetCursorPos_(x,y)
EndProcedure
ProcedureDLL MouseClick(Parameter) ; Simule une action sur les boutons de la souris (EX : MouseClick(#MOUSEEVENTF_RIGHTDOWN) : mouseclick(#MOUSEEVENTF_RIGHTUP))
Mem.l=GlobalAlloc_(0,8)
GetCursorPos_(Mem)
re=mouse_event_(Parameter|#MOUSEEVENTF_ABSOLUTE,PeekL(Mem)*($FFFF/GetSystemMetrics_(0)),PeekL(Mem+4)*($FFFF/GetSystemMetrics_(1)),0,GetMessageExtraInfo_())
GlobalFree_(Mem)
ProcedureReturn re
EndProcedure
ProcedureDLL IsMouseOver(GadgetID) ; Retourne 1 si la souris est au dessus du gadget
GetWindowRect_(GadgetID,re.RECT)
re\Left = re\left
re\top = re\top
re\right = re\right
re\bottom = re\bottom
GetCursorPos_(pt.POINT)
Result = PtInRect_(re,pt\x,pt\y)
ProcedureReturn Result
EndProcedure
;- PUREBASIC
ProcedureDLL.s GetPureBasicPath() ; Retourne le dossier d'installation de PureBasic
path.s = "Applications\PureBasic.exe\shell\open\command"
If RegOpenKeyEx_(#HKEY_CLASSES_ROOT, path, 0, #KEY_ALL_ACCESS, @Key) = #ERROR_SUCCESS
indir.s = Space(500)
insize = 500
If RegQueryValueEx_(Key, "", 0, 0, @indir.s, @insize) = #ERROR_SUCCESS
RegCloseKey_(Key)
indir = RemoveString(indir, "%1", 1)
indir = RemoveString(indir, Chr(34), 1)
indir = RTrim(indir)
path = GetPathPart(indir)
Else
RegCloseKey_(Key)
ProcedureReturn ""
EndIf
EndIf
If Path
ProcedureReturn Path
EndIf
EndProcedure
ProcedureDLL.s GetPureBasicVersion() ; Retourne la version de PureBasic
; environ 330 ms
path.s = "Applications\PureBasic.exe\shell\open\command"
If RegOpenKeyEx_(#HKEY_CLASSES_ROOT, path, 0, #KEY_ALL_ACCESS, @Key) = #ERROR_SUCCESS
indir.s = Space(500)
insize = 500
If RegQueryValueEx_(Key, "", 0, 0, @indir.s, @insize) = #ERROR_SUCCESS
RegCloseKey_(Key)
indir = RemoveString(indir, "%1", 1)
indir = RemoveString(indir, Chr(34), 1)
indir = RTrim(indir)
path = GetPathPart(indir)
Else
MessageRequester("Erreur!", "Hum... Je ne trouve pas Purebasic" + Chr(13) + filename.s, #MB_ICONERROR)
RegCloseKey_(Key)
path = PathRequester("Indiquer le repertoire du compilateur de PureBasic", "C:\program files\PureBasic\compilers\")
If path
file = ReadFile(#PB_Any, path + "pbcompiler.exe")
If file
path = Left(path, Len(path) - 1)
CloseFile(file)
Else
MessageRequester("Information", "Impossible de trouver le compilateur de PureBasic", #MB_ICONERROR)
End
EndIf
Else
MessageRequester("Information", "Vous n'avez pas spécifié de repertoire", #MB_ICONERROR)
End
EndIf
EndIf
EndIf
file = ReadFile(#PB_Any, path + "\compilers\PBcompiler.exe")
If file
Repeat
ligne$ = ReadString()
pos = FindString(ligne$, "PureBasic v", 0)
If pos <> 0
po = pos
CIPureBasic$ = ligne$
EndIf
Until Eof(file) Or pos <> 0
CloseFile(file)
CIPureBasic$ = StringField(Right(CIPureBasic$, Len(CIPureBasic$) - (po + 10)), 1, "*")
EndIf
ProcedureReturn CIPureBasic$
EndProcedure
;- REQUESTER
ProcedureDLL MSGP(Titre.s, Msg.s, Type.l, Icone.l) ; Affiche une boîte de dialogue avancée
; Type | Boutons qui apparaissent avec résultat
; 0 OK = 1
; 1 OK = 1, Annuler = 2
; 2 Abandon = 3, Reessayer = 4, Ignorer = 5
; 3 Oui = 6, Non = 7, Annuler = 2
; 4 Oui = 6, Non = 7
; 5 Reessayer = 4, Annuler = 2
; Icone | Description de l'icône
; 0 Rien : pas d'icône
; 1 Interdit : rond rouge avec une croix blanche
; 2 Aide : bulle avec un ?
; 3 Danger : triangle jaune avec un !
; 4 Information : bulle avec un I
If Type >= 0 And Type <= 5 And Icone >= 0 And Icone <= 4
ProcedureReturn MessageRequester(Titre, Msg, Type + 16 * Icone)
Else
ProcedureReturn 0
EndIf
EndProcedure
ProcedureDLL MSG(Text.s) ; Affiche une boîte de dialogue
MessageRequester("Information", text.s)
EndProcedure
;- SPECIAL DIRECTORY
ProcedureDLL.s GetUserDirectory(Flag.l) ; Retourne l'adresse d'un répertoire système
; Certaines des options ci-dessous ne fonctionnent que sous Windows XP
hKey.l = 0
keyvalue.s = Space(255)
datasize.l = 255
If Flag < 24 Or Flag = 36
OpenKey.l = #HKEY_CURRENT_USER
Else
OpenKey.l = #HKEY_LOCAL_MACHINE
EndIf
SubKey.s = "Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders"
Select Flag
Case 1 ; Dossier où se trouve les outils d'administration
ValueName.s = "Administrative Tools"
Case 2 ; Application Data
ValueName.s = "AppData"
Case 3 ; Repertoire temporaire pour les fichiers internet
ValueName.s = "Cache"
Case 4 ; Repertoire temporaire pour les fichiers à graver
ValueName.s = "CD Burning"
Case 5 ; Dossier des cookies
ValueName.s = "Cookies"
Case 6 ; Bureau de l'utilisateur
ValueName.s = "Desktop"
Case 7 ; Dossier des favoris
ValueName.s = "Favorites"
Case 8 ; Dossier contenant les polices de Windows
ValueName.s = "Fonts"
Case 9 ; Historique de Windows
ValueName.s = "History"
Case 10 ; Application Data dans paramètres locaux
ValueName.s = "Local AppData"
Case 11 ; Paramètres locaux
ValueName.s = "Local Settings"
Case 12 ; Dossier contenant vos musiques dans Mes Documents
ValueName.s = "My Music"
Case 13 ; Dossier contenant vos images dans Mes Documents
ValueName.s = "My Pictures"
Case 14 ; Dossier contenant vos vidéos dans Mes Documents
ValueName.s = "My Video"
Case 15 ; Voisinage réseau
ValueName.s = "NetHood"
Case 16 ; Mes Documents
ValueName.s = "Personal"
Case 17 ; Voisinage d'impression
ValueName.s = "PrintHood"
Case 18 ; Menu Démarrer\Progammes
ValueName.s = "Programs"
Case 19 ; Fichiers récemments ouverts (contient des raccourcis)
ValueName.s = "Recent"
Case 20 ; Dossier envoyer vers
ValueName.s = "SendTo"
Case 21 ; Menu Démarrer
ValueName.s = "Start Menu"
Case 22 ; Menu Démarrer\Progammes\Démarrage
ValueName.s = "Startup"
Case 23 ; Modèles
ValueName.s = "Templates"
Case 36 ; Microsoft\Internet Explorer\Quick Launch
ValueName.s = "AppData"
; Même chose mais pour 'Tous les utlisateurs'
Case 24
ValueName.s = "Common Administrative Tools"
Case 25
ValueName.s = "Common AppData"
Case 26
ValueName.s = "Common Desktop"
Case 27 ; Documents de tous les utilisateurs , il est aussi le dossier nommé 'Documents partagés'
ValueName.s = "Common Documents"
Case 28
ValueName.s = "Common Favorites"
Case 29
ValueName.s = "Common Programs"
Case 30
ValueName.s = "Common Start Menu"
Case 31
ValueName.s = "Common Startup"
Case 32
ValueName.s = "Common Templates"
Case 33
ValueName.s = "CommonMusic"
Case 34
ValueName.s = "CommonPictures"
Case 35
ValueName.s = "CommonVideo"
EndSelect
If RegOpenKeyEx_(OpenKey, SubKey, 0, #KEY_READ, @hKey)
MessageBeep_(#MB_ICONEXCLAMATION) ; alerte la clé n'éxiste pas !!!
keyvalue = "PAS DE CLE"
Else
If RegQueryValueEx_(hKey, ValueName, 0, 0, @keyvalue, @datasize)
keyvalue = "" ; si la sous-clé n'éxiste pas renvoi un texte vide
Else
keyvalue = Left(keyvalue, datasize - 1) ; si la sous clé existe renvoi l'adresse du repertorie demandé
EndIf
RegCloseKey_(hKey)
EndIf
If Flag = 36
keyvalue = keyvalue + "\Microsoft\Internet Explorer\Quick Launch"
EndIf
If Right(keyvalue,1)<>"\" : keyvalue=keyvalue+"\" : EndIf
ProcedureReturn keyvalue
EndProcedure
ProcedureDLL.s GetApplicationDirectory() ; Retourne l'adresse du programme
appdir$ = Space(255)
If Right(appdir$, 1) = "\"
Else
appdir$ = appdir$ + "\"
EndIf
GetCurrentDirectory_(255, @appdir$)
If Right(appdir$, 1) <> "\" ; si l'adresse ne finit pas par "\"
appdir$ = appdir$ + "\" ; on rajoute le "\"
EndIf
ProcedureReturn appdir$
EndProcedure
ProcedureDLL.s GetUserProfileDirectory() ; Retourne l'adresse du répertoire utilisateur
OpenProcessToken_(GetCurrentProcess_(), $08, @token)
Length.l = 512
directory$ = Space(Length)
GetUserProfileDirectory_(token, directory$, @Length)
ProcedureReturn Left(directory$, Length) + "\"
EndProcedure
ProcedureDLL.s GetWindowsDirectory() ; Retourne l'adresse de Windows
windir$ = Space(255) : GetWindowsDirectory_( @windir$, 255) : If Right(windir$, 1) <> "\" : windir$ + "\" : EndIf
ProcedureReturn windir$
EndProcedure
ProcedureDLL.s GetSystemDirectory() ; Retourne l'adresse du répertoire système
sysdir$ = Space(255) : GetSystemDirectory_( @sysdir$, 255) : If Right(sysdir$, 1) <> "\" : sysdir$ + "\" : EndIf
ProcedureReturn sysdir$
EndProcedure
ProcedureDLL.s GetTempDirectory() ; Retourne l'adresse du répertoire temporaire
Protected WinTemp.s
WinTemp = Space(255)
GetTempPath_(255, WinTemp)
If Right(WinTemp, 1) <> "\" : WinTemp = WinTemp + "\" : EndIf
ProcedureReturn WinTemp
EndProcedure
;- SPECIAL COMMAND
ProcedureDLL AutoDeleteProg() ; Supprime le programme
ExeName.s = Space(255) : GetModuleFileName_(0, @ExeName, 255) ; Recherche l'adresse du programme
cmd$ = Space(255) : GetEnvironmentVariable_("comspec", @cmd$, 255) ; Recherche le programme de commande (command.exe ou cmd.exe)
RunProgram(cmd$, "/c del.exe /F " + Chr(34) + ExeName + Chr(34), GetPathPart(ExeName), 2) : End ; Lance la suppression en mode forcé et caché
EndProcedure
ProcedureDLL.s GetCommandPath() ; Retourne l'adresse du programme 'ligne de commandes' (command.exe ou cmd.exe)
cmd$ = Space(255) : GetEnvironmentVariable_("comspec", @cmd$, 255)
ProcedureReturn cmd$
EndProcedure
ProcedureDLL CreateShortcut(Target$, Shortcut$, Arguments$, Comments$, WorkDirectory$, WindowSize.l, IconShortcut$, IconNumber.l ) ; Crée un raccourci
CoInitialize_(0)
If WindowSize = 1
TFen.l = #SW_SHOWNORMAL
ElseIf WindowSize = 2
TFen.l = #SW_SHOWMAXIMIZED
ElseIf WindowSize = 3
TFen.l = #SW_SHOWMINIMIZED
EndIf
If CoCreateInstance_(?CLSID_ShellLink, 0, 1, ?IID_IShellLink, @psl.IShellLinkA) = 0
Set_ShellLink_preferences :
psl\SetPath( @Target$)
psl\SetArguments( @Arguments$)
psl\SetWorkingDirectory( @WorkDirectory$)
psl\SetDescription( @Comments$)
psl\SetShowCmd(TFen)
psl\SetHotkey(0) ; Touche raccourci
psl\SetIconLocation( @IconShortcut$, IconNumber.l)
ShellLink_SAVE :
If psl\QueryInterface(?IID_IPersistFile, @ppf.IPersistFile) = 0
mem.s = Space(1000)
MultiByteToWideChar_(#CP_ACP, 0, Shortcut$, -1, mem, 1000)
hres = ppf\Save( @mem, #True)
result = 1
ppf\Release()
EndIf
psl\Release()
EndIf
CoUninitialize_()
ProcedureReturn result
DataSection
CLSID_ShellLink :
Data.l $00021401
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
IID_IShellLink :
Data.l $000214EE
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
IID_IPersistFile :
Data.l $0000010B
Data.w $0000, $0000
Data.b $C0, $00, $00, $00, $00, $00, $00, $46
EndDataSection
EndProcedure
ProcedureDLL ComputerShutDown(Flags.l) ; 1 : fermer la session, 2 : éteindre, 3 : redémarrer, 4 : mettre en veille prolongée, 5 : mettre en veille
; POUR LA MISE EN VEILLE PROLONGEE : LE PROGRAMME NE VERIFIE PAS SI LA FONCTION EST ACTIVE SUR VOTRE ORDINATEUR (si elle ne l'est pas veille prologée sera équivalente à une veille normale)
; Param = paramètre d'instinction de l'ordinateur
; 1 : quitter session
; 2 : arrêter
; 3 : redémarrer
; 4 : veille prolongée
; 5 : veille
#TOKEN_ADJUST_PRIVILEGES = 32
#TOKEN_QUERY = 8
#SE_PRIVILEGE_ENABLED = 2
#EWX_LOGOFF = 0
#EWX_SHUTDOWN = 1
#EWX_REBOOT = 2
#EWX_FORCE = 4
#EWX_POWEROFF = 8
Structure MyLUID
LowPart.l
HighPart.l
Attributes.l
EndStructure
Structure MyTOKEN
PrivilegeCount.l
LowPart.l
HighPart.l
Attributes.l
EndStructure
Protected hdlTokenHandle.l, tmpLuid.MyLUID, tkp.MyTOKEN, tkpNewButIgnored.MyTOKEN, lBufferNeeded.l
OpenProcessToken_(GetCurrentProcess_(), #TOKEN_ADJUST_PRIVILEGES | #TOKEN_QUERY, @hdlTokenHandle) ; On demande à Windows l'autorisation de le quitter (c'est n'importe quoi, demander à son ordi si il veut bien aller dormir, on va où là?)
SysName.s = "" + Chr(0)
Name.s = "SeShutdownPrivilege" + Chr(0)
LookupPrivilegeValue_(SysName, Name, @tmpLuid)
tmpLuid\Attributes = #SE_PRIVILEGE_ENABLED
tkp\PrivilegeCount = 1
tkp\LowPart = tmpLuid\LowPart
tkp\HighPart = tmpLuid\HighPart
tkp\Attributes = tmpLuid\Attributes
AdjustTokenPrivileges_(hdlTokenHandle, 0, @tkp, SizeOf(MyTOKEN), @tkpNewButIgnored, @lBufferNeeded)
Select Flags
Case 1 : ExitWindowsEx_(#EWX_LOGOFF | #EWX_FORCE, 0) ; On quitte la session en cours en forçant l'arrêt des programmes
Case 2 : ExitWindowsEx_(#EWX_SHUTDOWN | #EWX_FORCE, 0) ; On éteint l'ordinateur en forçant l'arrêt des programmes
Case 3 : ExitWindowsEx_(#EWX_REBOOT | #EWX_FORCE, 0) ; On redémarre l'ordinateur en forçant l'arrêt des programmes
Case 4 : SetSystemPowerState_(#False, #False) ; On passe en mode hibernation sans forcer l'arrêt des programmes
Case 5 : SetSystemPowerState_(#True, #False) ; On passe en mode veille sans forcer l'arrêt des programmes
EndSelect
EndProcedure
ProcedureDLL.s GetExeName() ; Retourne le nom du programme
ExeName.s = Space(255) : GetModuleFileName_(0, @ExeName, 255)
ProcedureReturn GetFilePart(ExeName)
EndProcedure
ProcedureDLL.s GetExePath() ; Retourne l'adresse du programme
ExeName.s = Space(255) : GetModuleFileName_(0, @ExeName, 255)
ProcedureReturn GetPathPart(ExeName)
EndProcedure
ProcedureDLL GetBatteryACLineStatus() ; Retourne 3 si l'ordinateur est branché mais sans batterie ; 4 si branché et batterie présente ; sinon retourne une valeur différente
powerstatus = GetSystemPowerStatus_( @LPSYSTEM_POWER_STATUS.STATUS)
If powerstatus
If LPSYSTEM_POWER_STATUS\ACLineStatus = 1 And LPSYSTEM_POWER_STATUS\BatteryFlag = 128
ProcedureReturn 3
ElseIf LPSYSTEM_POWER_STATUS\ACLineStatus = 1 And LPSYSTEM_POWER_STATUS\BatteryFlag >= 8 And LPSYSTEM_POWER_STATUS\BatteryFlag = < 9
ProcedureReturn 4
Else
ProcedureReturn LPSYSTEM_POWER_STATUS\ACLineStatus
EndIf
EndIf
EndProcedure
ProcedureDLL GetBatteryLifePercent() ; Retourne en pourcentage la capacité restante de la batterie
powerstatus = GetSystemPowerStatus_( @LPSYSTEM_POWER_STATUS.STATUS)
If powerstatus
ProcedureReturn LPSYSTEM_POWER_STATUS\BatteryLifePercent
EndIf
EndProcedure
ProcedureDLL DownloadFile(URL.s, FileToSave.s, GadgetText.l, SetGadgetTextFileFind.s, SetGadgetTextFileNotFind.s, GadgetProgress.l) ; Permet de télécharger un fichier
; SetGadgetTextFileFind.s="Avancement du téléchargement : |BytesDownloaded|/|SizeFile| ko : |Progress|
isLoop.b = 1
Bytes.l = 0
fBytes.l = 0
Buffer.l = 4096
res.s = ""
tmp.s = ""
OpenType.b = 1
INTERNET_FLAG_RELOAD.l = $80000000
INTERNET_DEFAULT_HTTP_PORT.l = 80
INTERNET_SERVICE_HTTP.l = 3
HTTP_QUERY_STATUS_CODE.l = 19
HTTP_QUERY_STATUS_TEXT.l = 20
HTTP_QUERY_RAW_HEADERS.l = 21
HTTP_QUERY_RAW_HEADERS_CRLF.l = 22
MemoryID = AllocateMemory(Buffer)
Result = CreateFile(1, FileToSave)
If Result
hInet = InternetOpen_("", OpenType, #Null, #Null, 0)
hURL = InternetOpenUrl_(hInet, URL, #Null, 0, INTERNET_FLAG_RELOAD, 0)
If hInet <> 0 And hURL <> 0
domain.s = ReplaceString(Left(URL, (FindString(URL, "/", 8) - 1)), "http://", "")
hInetCon = InternetConnect_(hInet, domain, INTERNET_DEFAULT_HTTP_PORT, #Null, #Null, INTERNET_SERVICE_HTTP, 0, 0)
If hInetCon > 0
hHttpOpenRequest = HttpOpenRequest_(hInetCon, "HEAD", ReplaceString(URL, "http://" + domain + "/", ""), "http/1.1", #Null, 0, INTERNET_FLAG_RELOAD, 0)
If hHttpOpenRequest > 0
iretval = HttpSendRequest_(hHttpOpenRequest, #Null, 0, 0, 0)
If iretval > 0
lBufferLength.l = 0
lBufferLength = 1024
sBuffer.s = Space(lBufferLength)
HttpQueryInfo_(hHttpOpenRequest, HTTP_QUERY_STATUS_CODE, sBuffer, @lBufferLength, 0)
tmp = Left(sBuffer, lBufferLength)
If Trim(tmp) = "200"
lBufferLength.l = 0
lBufferLength = 1024
sBuffer.s = Space(lBufferLength)
HttpQueryInfo_(hHttpOpenRequest, HTTP_QUERY_RAW_HEADERS_CRLF, sBuffer, @lBufferLength, 0)
tmp = Left(sBuffer, lBufferLength)
If FindString(tmp, "Content-Length:", 1) > 0
ii.l = FindString(tmp, "Content-Length:", 1) + Len("Content-Length:")
tmp = Mid(tmp, ii, Len(tmp) - ii)
myMax = Val(Trim(tmp))
EndIf
Repeat
InternetReadFile_(hURL, MemoryID, Buffer, @Bytes)
If Bytes = 0
isLoop = 0
Else
fBytes = fBytes + Bytes
If mymax > 0
If GadgetText > 0
SetGadgetText(GadgetText, ReplaceString(ReplaceString(ReplaceString(SetGadgetTextFileFind,"|BytesDownloaded|",Str(fbytes / 1024)),"|SizeFile|",Str(mymax / 1024)),"|Progress|",Str(fbytes * 100 / myMax)))
EndIf
If GadgetProgress > 0
SetGadgetState(GadgetProgress, fbytes * 100 / myMax)
EndIf
Else
If GadgetText > 0
SetGadgetText(GadgetText, ReplaceString(ReplaceString(ReplaceString(SetGadgetTextFileNotFind,"|BytesDownloaded|",Str(fbytes / 1024)),"|SizeFile|",Str(mymax / 1024)),"|Progress|",Str(fbytes * 100 / myMax)))
EndIf
EndIf
UseFile(1)
WriteData(MemoryID, Bytes)
EndIf
Until isLoop = 0
InternetCloseHandle_(hURL)
InternetCloseHandle_(hInet)
CloseFile(1)
FreeMemory(MemoryID)
EndIf
EndIf
EndIf
EndIf
If down = 1
ProcedureReturn 0
EndIf
Else
CloseFile(1)
DeleteFile(FileToSave)
If down = 0
ProcedureReturn 0
EndIf
EndIf
Else
If ReadFile(2, FileToSave) <> 0
CloseFile(2)
ProcedureReturn 1
Else
ProcedureReturn 0
EndIf
EndIf
EndProcedure
ProcedureDLL OpenMailProgram(MailAddress.s, Subject.s, Message.s) ; Ouvre le programme par défaut pour envoyer un email (si MailAddressInCopy="", il ne sera pas pris en compte) (pour passer une ligne utiliser #CRLF$)
ProcedureReturn RunProgram("mailto:"+mailaddress+"?Subject="+Subject+m$+"&Body="+ReplaceString(message,#CRLF$," Body="))
EndProcedure
ProcedureDLL OpenMailProgram2(MailAddress.s, Subject.s, Message.s, MailAddressInCopy.s) ; Ouvre le programme par défaut pour envoyer un email (si MailAddressInCopy="", il ne sera pas pris en compte) (pour passer une ligne utiliser #CRLF$)
If MailAddressInCopy<>""
m$="&cc="+MailAddressInCopy
EndIf
ProcedureReturn RunProgram("mailto:"+mailaddress+"?Subject="+Subject+m$+"&Body="+ReplaceString(message,#CRLF$," Body="))
EndProcedure
