# Sources PureBasicConsultez toutes les sources

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

Sommaire→Applications

- Gestion des langues dans une application
- Boîte de dialogues personnalisée
- image compressée dans la DataSection (intégrée dans le code)
- Gestion bibliothèques avec sqlite
- Le compte (bancaire) est bon !
- Calcul et affichage d'engrenages
- Création d'une jauge entièrement paramétrable
- Tiny visual designer (TVD)

Version hors-ligne
Gestion des langues dans une application

Pour tester un fichier langue, vous pouvez créer un fichier texte que vous nommerez'german.prefs'. Ce fichier contiendra les lignes suivantes:
[MenuTitle]
File = Datei
Edit = Bearbeiten
[MenuItem]
New = Neu
Open = Öffnen
Save = Speichern
Pour un programme dans le mode unicode, le fichier doit être enregistré en UTF8 avec le BOM (byte order mark) valant UTF8 (voir WriteStringFormat()) , afin que la bibliothèque Preference charge correctement les chaînes en unicode.

Sélectionnez

    ;Vous pouvez consulter les fichiers langues de l'EDI dans le répertoire catalogs de PureBasic

    ; -----------------------------------------------------------------
    ;  Exemple d'une gestion simple des langues pour une application
    ; -----------------------------------------------------------------
    ;
    ; Avantage de cette solution :
    ;  - Les chaînes de caractères sont identifiées par un groupe et un nom clé, ce qui permet
    ;    de mieux les organiser avec leurs propres descriptions et de développer plus facilement.
    ;
    ;  - Les chaînes de caractères sont indexées et triées lors de leur chargement,
    ;    ce qui permet un accès rapide malgré qu'elles soient appelées par leur nom.
    ;
    ;  - Une langue par défaut est définie dans le code (DataSection), aussi même
    ;     si un fichier externe de langue est manquant ou périmé, il y a toujours la langue
    ;     par défaut présente.
    ;
    ;  - La liste de mots est facile à élargir. Il suffit d'ajouter une nouvelle entrée
    ;     dans la DataSection ainsi que le fichier de langue et d'utiliser le nouveau groupe et nom clé.
    ;
    ;  - Les fichiers de langues additionnels sont dans le format "PB preference" qui
    ;    permet de les maintenir facilement.
    ;
    ; Utilisation:
    ;  - définissez le langage par défaut dans la DataSection comme montré plus bas
    ;  - Utilisez LoadLanguage() au départ pour charger le langage par défaut ou le fichier externe.
    ;  - Utilisez Language(Group$, Name$) pour accéder aux mots des langages.
    ;
    ; -----------------------------------------------------------------

    ; Divers
    ;
    Global NbLanguageGroups, NbLanguageStrings

    Structure LanguageGroup
      Name$
      GroupStart.l
      GroupEnd.l
      IndexTable.l[256]
    EndStructure

    ; Cette procédure charge la langue depuis un fichier, ou le langage par défaut.
    ; Elle doit être appelée au moins une fois avant d'utiliser n'importe quel mot.
    ;
    ; Cette procédure permet de :
    ; - charger et trier le langage par défaut fourni
    ; - charger n'importe quel langage depuis un fichier
    ;
    ; Cette méthode vous permet d'obtenir un mot d'une langue, même si le fichier n'est pas
    ; trouvé, ou qu'un mot référencé par un index est introuvable dans le fichier.
    ; Vous récupererez la langue par défaut en utilisant la commande Language().
    ;
    ; Cette fonction peut être appelée plusieurs fois pour changer la langue utilisée durant l'exécution.
    ;
    Procedure LoadLanguage(FileName$ = "")

      ; Fait d'abord un rapide compte de la DataSection
      ;
      NbLanguageGroups = 0
      NbLanguageStrings = 0

      Restore Language
      Repeat

        Read Name$
        Read String$

        Name$ = UCase(Name$)

        If Name$ = "_GROUP_"
          NbLanguageGroups + 1
        ElseIf Name$ = "_END_"
          Break
        Else
          NbLanguageStrings + 1
        EndIf

      ForEver

      Global Dim LanguageGroups.LanguageGroup(NbLanguageGroups)  ; ils sont tous là
      Global Dim LanguageStrings.s(NbLanguageStrings)
      Global Dim LanguageNames.s(NbLanguageStrings)

      ; On charge la langue standard (par défaut)
      ;
      Group = 0
      StringIndex = 0

      Restore Language
      Repeat

        Read Name$
        Read String$

        Name$ = UCase(Name$)

        If Name$ = "_GROUP_"
          LanguageGroups(Group)\GroupEnd   = StringIndex ; Mémorise le dernier index de chaînes associées à ce groupe
          Group + 1

          LanguageGroups(Group)\Name$      = UCase(String$)  ; Mémorise le nom du groupe
          LanguageGroups(Group)\GroupStart = StringIndex + 1 ; Mémorise le premier index de chaînes associées à ce groupe
          For i = 0 To 255
            LanguageGroups(Group)\IndexTable[i] = 0
          Next i

        ElseIf Name$ = "_END_"
          Break

        Else
          StringIndex + 1 ; Incrémente l'index sur les chaînes
          LanguageNames(StringIndex)   = Name$ + Chr(1) + String$  ; Garde le nom de l'index et la valeur ensemble pour trier plus facilement

        EndIf

      ForEver

      LanguageGroups(Group)\GroupEnd   = StringIndex ; Configure le dernier index pour le dernier groupe !

      ; On effectue le tri et l'indexation pour chaque groupe
      ;
      For Group = 1 To NbLanguageGroups
        If LanguageGroups(Group)\GroupStart <= LanguageGroups(Group)\GroupEnd

          SortArray(LanguageNames(), 0, LanguageGroups(Group)\GroupStart, LanguageGroups(Group)\GroupEnd)

          char = 0
          For StringIndex = LanguageGroups(Group)\GroupStart To LanguageGroups(Group)\GroupEnd
            LanguageStrings(StringIndex) = StringField(LanguageNames(StringIndex), 2, Chr(1)) ; Sépare la valeur de l'index
            LanguageNames(StringIndex)   = StringField(LanguageNames(StringIndex), 1, Chr(1))

            If Asc(Left(LanguageNames(StringIndex), 1)) <> char
              char = Asc(Left(LanguageNames(StringIndex), 1))
              LanguageGroups(Group)\IndexTable[char] = StringIndex
            EndIf
          Next StringIndex

        EndIf
      Next Group

      ; On essaye de chargé un fichier de langue externe.
      ;
      If FileName$ <> ""

        If OpenPreferences(FileName$)
          For Group = 1 To NbLanguageGroups
            If LanguageGroups(Group)\GroupStart <= LanguageGroups(Group)\GroupEnd
              PreferenceGroup(LanguageGroups(Group)\Name$)

              For StringIndex = LanguageGroups(Group)\GroupStart To LanguageGroups(Group)\GroupEnd
                LanguageStrings(StringIndex) = ReadPreferenceString(LanguageNames(StringIndex), LanguageStrings(StringIndex))
              Next StringIndex
            EndIf
          Next Group
          ClosePreferences()

          ProcedureReturn #True
        EndIf

      EndIf

      ProcedureReturn #True
    EndProcedure

    ; Cette fonction retourne un mot pour la langue en cours d'utilisation.
    ; Chaque mot est identifié par un groupe et un nom (les deux sont insensibles à la casse)
    ;
    ; Si le mot n'est pas trouvé (ou non inclus dans la langue par défaut) le
    ; retour sera "##### String not found! #####". Cela aide à trouver les erreurs dans le code de la langue facilement
    ;
    Procedure.s Language(Group$, Name$)
      Static Group.l  ; Pour un accès plus rapide quand on utilise le meme nom de groupe plusieurs fois
      Protected String$, StringIndex, Result

      Group$  = UCase(Group$)
      Name$   = UCase(Name$)
      String$ = "##### String not found! #####"  ; Pour aider à trouver les erreurs

      If LanguageGroups(Group)\Name$ <> Group$  ; Contrôle si c'est le même groupe à chaque fois
        For Group = 1 To NbLanguageGroups
          If Group$ = LanguageGroups(Group)\Name$
            Break
          EndIf
        Next Group

        If Group > NbLanguageGroups  ; Le groupe demandé n'est pas trouvé
          Group = 0
        EndIf
      EndIf

      If Group <> 0
        StringIndex = LanguageGroups(Group)\IndexTable[ Asc(Left(Name$, 1)) ]
        If StringIndex <> 0

          Repeat
            Result = CompareMemoryString(@Name$, @LanguageNames(StringIndex))

            If Result = #PB_String_Equal
              String$ = LanguageStrings(StringIndex)
              Break

            ElseIf Result = -1 ; Mot non trouvé
              Break

            EndIf

            StringIndex + 1
          Until StringIndex > LanguageGroups(Group)\GroupEnd

        EndIf

      EndIf

      ProcedureReturn String$
    EndProcedure

    DataSection

      ; C'es ici que la langue par défaut est définie.C'est une liste de Groupe,
      ; Name avec quelques mot clefs spéciaux pour un groupe
      ;
      ; "_GROUP_" indique un nouveau gorupe dans la DataSection, la seconde valeur est le nom du groupe
      ; "_END_" indique la fin de la liste de la langue (comme il n'y a pas de nombre de mots prédéfinis)
      ;
      ; Note: Les index de mot sont insensibles à la casse pour se faciliter la vie.

      Language:

        ; ===================================================
        Data$ "_GROUP_",            "MenuTitle"
        ; ===================================================

          Data$ "File",             "File"
          Data$ "Edit",             "Edit"

        ; ===================================================
        Data$ "_GROUP_",            "MenuItem"
        ; ===================================================

          Data$ "New",              "New"
          Data$ "Open",             "Open..."
          Data$ "Save",             "Save"

        ; ===================================================
        Data$ "_END_",              ""
        ; ===================================================

    EndDataSection

    ; -----------------------------------------------------------------
    ; Exemple:
    ; -----------------------------------------------------------------

    LoadLanguage()                ; charge la langue par défaut
    ;LoadLanguage("german.prefs") ; décommentez pour charger le fichier de langue allemand

    ; Récupère quelques mot de la langue
    ;
    Debug Language("MenuTitle", "Edit")
    Debug Language("MenuItem", "Save")

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

Créé le 22 juin 2008 par Freak
Boîte de dialogues personnalisée

Voila un code qui affiche une boite de dialogue que j'ai personnalisée pour afficher un aperçu de l'image du fichier sélectionné.
Avec les fonctions PB des images, c'est assez limité mais personnellement j'utilise la dll Freeimage (wrapper de Progi1984) et c'est tellement mieux...
Le code est extrait de mon projet qui fait environ 10000 lignes, donc une procédure est écrite avec un peu d'assembleur pour correspondre à mes besoins.
Après réduction de l'image png, la transparence n'est pas conservé avec PB (mais avec Freeimage et un peu d'imagination on y arrive). Chez moi les tiff ne s'affichent pas (mais c'est parfait avec Freeimage qui est capable d'ouvrir de très grandes images).

Exemple avec un fichier librairie d'icônes icl

Exemple avec un fichier png réduit avec conservation de la transparence pour l'affichage

Sélectionnez

    EnableExplicit
    EnableASM

    ;- Declarations
    Declare Free_ScrollArea_From_Images()

    ;-Constantes Fenêtres
    Enumeration
         #MainWindow
    EndEnumeration

    ;-Constantes Gadgets
    Enumeration 0
         #Texte_ScrollAreaGadget_Icone
         #HmainCombo
         #ScrollAreaGadget_Icone   ; scrollarea fenêtre principale
         #ScrollAreaGadget_OpenFileRequesterIcone   ; scrollarea fenêtre d'ouverture fichier ico etc
         #ContainerGadget_OpenFileRequesterIcone   ; ListViewGadget d'ouverture fichier png, jpg etc
         #TextGadget_ScrollAreaGadget_OpenFileRequesterIcone
    EndEnumeration

    Enumeration 0;
         ; Read-Write
         #FileFormat_Unknown
         #ICO
         #CUR
         #ANI
         #ICL
         #DLL
         #BMP
         #PNG
         #JPG
         #TIF
         ; Read-Only
         #EXE
         #OCX
         #CPL
         #SRC
    EndEnumeration

    #Option_Fenetre = #PB_Window_Invisible | #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget
    #CRLF = Chr(13) + Chr(10)
    #CRLF_2 = #CRLF + #CRLF
    #Format_16 = 16
    #Format_32 = 32
    #Format_48 = 48
    #Format_96 = 96
    #Format_128 = 128
    #Offset_X_Icone_Apercu = 3
    #Offset_Y_Icone_Apercu = 3
    #Intervale_X_Icone_Apercu = 3
    #Intervale_Y_Icone_Apercu = 3
    #Taille_Icone_Apercu = #Format_48
    #largeurScrollAreaOpenfile = ((#Taille_Icone_Apercu + #Intervale_X_Icone_Apercu)*5) + (#Offset_X_Icone_Apercu*2) + 25

    ; valeur retournée en cas d'erreur
    #Return_Error = 0

    ; couleur fond scrollarea de Getopenfilename
    #CoulerFondScrollarea_Getopenfilename = #White

    ; constante des messages de la boîte de dialogue
    ; #CDN_FIRST = -601
    #CDN_FOLDERCHANGE = (#CDN_FIRST-2)
    #CDN_HELP = #CDN_FIRST-4
    #CDN_INITDONE = #CDN_FIRST
    #CDN_FILEOK = #CDN_FIRST-5

    #CDN_SELCHANGE = #CDN_FIRST-1
    #CDN_SHAREVIOLATION = #CDN_FIRST-3
    #CDN_TYPECHANGE = #CDN_FIRST-6
    #OFN_FORCESHOWHIDDEN = $10000000
    #OFN_ENABLESIZING = $800000

    #Maxi_File_Buffer_31_Ko = 31*1024  ; taille du buffer de texte de la boîte de dialogue

    ; les deux constantes suivantes pour l'extension des fichiers lnk
    #Link_extensionFile = ".lnk"
    #Link_extensionFile_Length = 4

    #HeapCompatibilityInformation = 0

    Structure AfficheMiniature
         Reduction.l   ; True l'image est réduite sinon false
         X_Position.l  ; position X sur le gadget d'affichage
         Y_Position.l  ; position Y sur le gadget d'affichage
         Width.l       ; Largeur d'origine de l'image
         Height.l      ; hauteur d'origine de l'image
    EndStructure

    Structure AfficheImg
         ; mémorise l'id statique de l'image gadget pour l'icone
         StaticImageGadgetId.l
         ; mémorise l'id statique de l'image créée
         StaticImageId.l
    EndStructure

    CompilerIf Defined(Chaine, #PB_Structure) = #False
         Structure Chaine
              pt.c[260]
         EndStructure
    CompilerEndIf

    CompilerIf Defined(EnumChidlDatas, #PB_Structure) = #False
         Structure EnumChidlDatas
              rc.RECT
              Dialog.l
         EndStructure
    CompilerEndIf

    CompilerIf Defined(AffichageMiniature, #PB_Structure) = #False
         Structure AffichageMiniature
              Reduction.l ; rue l'image est réduite sinon false
              X_Position.l ; position X sur le gadget d'affichage
              Y_Position.l ; position Y sur le gadget d'affichage
              Width.l ; Largeur d'origine de l'image
              Height.l ; hauteur d'origine de l'image
         EndStructure
    CompilerEndIf

    CompilerIf Defined(OFNOTIFY, #PB_Structure) = #False
         Structure OFNOTIFY
              hdr.NMHDR
              *lpOFN.OPENFILENAME
              pszFile.l
         EndStructure
    CompilerEndIf

    CompilerIf Defined(OPENFILENAMEXP, #PB_Structure) = #False
         Structure OPENFILENAMEXP Extends OPENFILENAME
         pvReserved.l
         dwReserved.l
         FlagsEx.l
    EndStructure
    CompilerEndIf

    Global hMainWindow    ; Handle de la fenêtre principale
    Global Largeur_Ecran  ; mémorise la largeur de l'écran
    Global Hauteur_Ecran  ; mémorise la hauteur de l'écran
    Global Ecran.RECT     ; pour retrouver la taille de l'écran
    Global Old_Dialogue_Proc   ; mémorise la procédure d'origine de la fenetre parent du dialog
    Global hListIcon_Apercu.l   ; mémorise le handle de la listicon des aperçus
    Global Font_Textegadget_Nb_Format_Icones
    Global BrushBkgWindow   ; mémorise la solidbrush couleur fond fenêtre
    Global Old_ScrollGadget_Proc.l  ; mémorise l'adresse de la callback Windows du scrollAreaGadget
    Global _WIN32_WINNT.w  ; version de window par l'API
    Global _WIN32_IE.w     ; version d'Internet explorer
    Global Nb_Button_ToolBarGetOpenFileName.b; mémorise le nombre de boutons de la Toolbar Getopenfilerequester
    Global Quitter_Application.b   ; = #true on ferme l'application
    Global FileNumber.l   ; retourne le nombre de fichiers sélectionés après la fermeture d dialogue
    Global HeapFragValue.l
    Global NewList Infos.AfficheImg() ; utilisé pour mémoriser les images

    ; Macro
    Macro FreeGadgetEx(StaticGadget3)
         If IsGadget(StaticGadget3)
              FreeGadget(StaticGadget3)
         EndIf
    EndMacro

    Macro FreeFontEX(StaticFont)
         If IsFont(StaticFont)
              FreeFont(StaticFont)
         EndIf
    EndMacro

    Macro SetGadgetColorEX(StaticGadget12, type, color)
         If IsGadget(StaticGadget12)
              SetGadgetColor(StaticGadget12, type, color)
         EndIf
    EndMacro

    Macro ShowScrollBarEx(StaticGadget88, Mode, affichage)
         If IsGadget(StaticGadget88)
              ShowScrollBar_(GadgetID(StaticGadget88), Mode, affichage)
         EndIf
    EndMacro

    Macro SetGadgetFontEx(StaticGadget11, StaticFontId)
         If IsFont(StaticFontId) And IsGadget(StaticGadget11)
              SetGadgetFont(StaticGadget11, FontID(StaticFontId))
         EndIf
    EndMacro

    Macro ResizeGadgetEx(Gadget, x, y, Largeur, Hauteur)
         If IsGadget(Gadget)
              ResizeGadget(Gadget, x, y, Largeur, Hauteur)
         EndIf
    EndMacro

    Macro SetGadgetTextEx(StaticGadget4, ch)
         If IsGadget(StaticGadget4)
              SetGadgetText(StaticGadget4, ch)
         EndIf
    EndMacro

    Macro FreeImageEx(StaticImage3)
         If IsImage(StaticImage3)
              FreeImage(StaticImage3)
         EndIf
    EndMacro

    Macro InvalidateRectEX(Staticgadget, lpRect, bErase)
         If IsGadget(Staticgadget)
              InvalidateRect_(GadgetID(Staticgadget), lpRect, bErase)
              UpdateWindow_(GadgetID(Staticgadget))
         EndIf
    EndMacro

    ; - Procedures
    Procedure _UPeekB(valeur.l)
         ; identique à PeekB() sauf que la valeur retournée est un long non signé (pas d'extension de signe)
         MOV edx, valeur
         MOVZX eax, byte[edx]
         ProcedureReturn
    EndProcedure

    Procedure.s IE_Version()
         ; retourne une chaine donnant la version de IE au format défini ici http://support.microsoft.com/kb/164539
         Protected Hkey.l, Version$ = ""
         Protected lpType.l, lpcbData.l, resultat.l

         If RegOpenKeyEx_(#HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer\", 0, #KEY_QUERY_VALUE, @Hkey)<>#ERROR_SUCCESS
              ProcedureReturn ""
         EndIf

         ;1er appel pour déterminer la taille du buffer
         resultat = RegQueryValueEx_(Hkey, "Version", 0, @lpType, @Version$, @lpcbData)
         If resultat<>#ERROR_MORE_DATA
              RegCloseKey_(Hkey)
              ProcedureReturn ""
         EndIf

         Version$ = Space(lpcbData + 2) ; alloue 2 caractères 0 de fin de chaine
         ; lpcbData contient la taille du buffer à allouer pour la fonction
         ; 2ème appel de la fonction

         resultat = RegQueryValueEx_(Hkey, "Version", 0, @lpType, @Version$, @lpcbData)
         RegCloseKey_(Hkey)
         If resultat<>#ERROR_SUCCESS
              ProcedureReturn ""
         EndIf

         ProcedureReturn Version$
    EndProcedure

    Procedure Init_Main()
         Protected lib.l, *HeapSetInformation

         SystemParametersInfo_(#SPI_GETWORKAREA, 0, @Ecran.RECT, 0)
         Largeur_Ecran = Ecran\right-Ecran\Left
         Hauteur_Ecran = Ecran\bottom-Ecran\top-20

         ; WinVersion
         If OSVersion()<#PB_OS_Windows_2000
              MessageRequester("Error/Erreur", "Windows version is to old (Windows 2000 minimum)" + Chr(13) + Chr(13) + "La version de Windows est trop ancienne (Windows 2000 minimum)", #MB_ICONERROR)
              End
         EndIf

         Select OSVersion()

              Case #PB_OS_Windows_Vista, #PB_OS_Windows_Server_2008, #PB_OS_Windows_Future
                   _WIN32_WINNT = $0600

              Case #PB_OS_Windows_Server_2003
                   _WIN32_WINNT = $0502

              Case #PB_OS_Windows_XP
                   _WIN32_WINNT = $0501

              Case #PB_OS_Windows_2000
                   _WIN32_WINNT = $0500

         EndSelect

         If _WIN32_WINNT< = $0400
              MessageRequester("Error/Erreur", "Windows version is to old" + Chr(13) + Chr(13) + "La version de Windows est trop ancienne", 16)
              End
         EndIf

         _WIN32_IE = Val(StringField(IE_Version(), 1, "."))

         BrushBkgWindow = CreateSolidBrush_(GetSysColor_(#COLOR_BTNFACE))

         ; tente d'utiliser la défragmentation de la mémoire (Low-fragmentation Heap)

         lib = OpenLibrary(#PB_Any, "Kernel32.dll")

         If lib
              *HeapSetInformation = GetFunction(lib, "HeapSetInformation")
              HeapFragValue = 2

              If CallFunctionFast(*HeapSetInformation, GetProcessHeap_(), #HeapCompatibilityInformation, @HeapFragValue, SizeOf(HeapFragValue))
                   Debug("Success!\n")

              Else
                   Debug "Failure " + Str(GetLastError_())
              EndIf
              CloseLibrary(lib)
         EndIf
    EndProcedure

    Procedure UnInit_Main()
         ; destruction de la brush
         If BrushBkgWindow
              DeleteObject_(BrushBkgWindow)
         EndIf
    EndProcedure

    Procedure ScrollAreaGadget_CallBack(Window, Message, wParam, lParam)
         Protected Resultat.l = CallWindowProc_(Old_ScrollGadget_Proc, Window, Message, wParam, lParam)

         Select Message
              Case #WM_PARENTNOTIFY
                   Select wParam & $FFFF
                        Case #WM_LBUTTONDOWN, #WM_RBUTTONDOWN, #WM_MBUTTONDOWN
                             SetFocus_(Window)
                             Resultat = 0
                   EndSelect

              Case #WM_LBUTTONDOWN, #WM_RBUTTONDOWN, #WM_MBUTTONDOWN
                   SetFocus_(Window)
                   Resultat = 0
         EndSelect
         ProcedureReturn Resultat
    EndProcedure

    Procedure DialogueCallBack(Window, Message, wParam, lParam)
         Protected ReturnValue = CallWindowProc_(Old_Dialogue_Proc, Window, Message, wParam, lParam)

         Select Message
              Case #WM_DESTROY
                   FreegadgetEX(#ScrollAreaGadget_OpenFileRequesterIcone)
                   FreegadgetEX(#ContainerGadget_OpenFileRequesterIcone)
                   FreegadgetEX(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone)
                   FreeFontEX(Font_Textegadget_Nb_Format_Icones)
                   Font_Textegadget_Nb_Format_Icones = 0
                   Free_ScrollArea_From_Images()
                   ReturnValue = 0

              Case #WM_CTLCOLORSTATIC
                   If IsGadget(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone) And lParam = GadgetID(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone)
                        ; on colorise le texte en blue
                        If BrushBkgWindow
                             SetBkMode_(wParam, #TRANSPARENT)
                             SetTextColor_(wParam, #Blue)
                             ReturnValue = BrushBkgWindow
                        EndIf
                   EndIf

         EndSelect

         ProcedureReturn ReturnValue
    EndProcedure

    Procedure.l enumChildren(hwnd.l, *Var.EnumChidlDatas)
         Protected parentText.Chaine
         Protected childText.Chaine
         Protected classText.Chaine
         Protected rc1.RECT

         If hwnd = 0
              ProcedureReturn #Return_Error
         EndIf

         If GetDlgCtrlID_(hwnd) = 0
              ProcedureReturn #Return_Error
         EndIf

         If GetClassName_(hwnd, @classText, 256) = 0
              ProcedureReturn #Return_Error
         EndIf

         SendMessage_(hwnd, #WM_GETTEXT, 256, @childText)

         If PeekS(classText) = "SysListView32"
              hListIcon_Apercu = hwnd
         EndIf

         If PeekS(classText) = "ToolbarWindow32"
              If GetWindowRect_(hwnd, @rc1) = 0
                   ProcedureReturn #Return_Error
              EndIf

              If ScreenToClient_(GetParent_(hwnd), @rc1) = 0
                   ProcedureReturn #Return_Error
              EndIf

              If ScreenToClient_(GetParent_(hwnd), @rc1 + 8) = 0
                   ProcedureReturn #Return_Error
              EndIf
              ; on compare avec les tailles de contenue par *rc.rect, si supérieur *rc.rect prend les valeurs
              ; on ne compare que la position en x car la Toolbar voulue est la plus proche du bord gauche
              If rc1\left<*Var\rc\left
                   CopyMemory(@rc1, *Var\rc, SizeOf(RECT))
                   *Var\Dialog = hwnd ; handle de la toolbar
              EndIf

         EndIf
         ProcedureReturn #True
    EndProcedure

    Procedure LoadImageEx(chaine$, *rc.AffichageMiniature)
         ; mémorise l'identifiant statique de l'image crée
         Protected Img
         ; Mémorise la largeur du ScrollAreaGadget
         Protected WidthGadgetMax.l
         ; Mémorise la hauteur du ScrollAreaGadget
         Protected HeightGadgetMax.l
         ; mémorise le ratio image origine
         Protected ratio_origine.f
         ; mémorise le ratio du gadget d(affichage
         Protected ratio_gadget.f
         ; mémorise le ratio de l'image affichée
         Protected ratio_dest.f
         ; mémorise un ratio temporaire
         Protected ratio_Temp.f
         ; mémorise la largeur de l'image redimensionnée
         Protected NewWidth
         ; mémorise la largeur de l'image redimensionnée
         Protected Newheight

         UseJPEGImageDecoder()
         UseJPEG2000ImageDecoder()
         UsePNGImageDecoder()
         UseTIFFImageDecoder()

         Img = LoadImage(#PB_Any, chaine$)
         If Img
              WidthGadgetMax = #largeurScrollAreaOpenfile-25-(#Offset_X_Icone_Apercu*2)
              HeightGadgetMax = GadgetHeight(#ScrollAreaGadget_OpenFileRequesterIcone)-(#Offset_Y_Icone_Apercu*2)-25

              ; récupération des tailles de l'image d'origine
              *Rc\Width = ImageWidth(Img)
              *Rc\Height = ImageHeight(Img)

              ; calcul du ratio image d'origine largeur/hauteur
              ratio_origine = *Rc\Width/*Rc\Height

              ; calcul du ratio gadget d'affichage largeur/hauteur
              ratio_gadget = WidthGadgetMax/HeightGadgetMax

              ; on redimensionne si un des côtés au moins est > au côté correspondant du gadget
              If (HeightGadgetMax> = *Rc\Height) And (WidthGadgetMax> = *Rc\Width)
                   ; on ne redimensionne pas
                   NewWidth = *Rc\Width
                   Newheight = *Rc\Height
                   *Rc\Reduction = #False
              Else ; (HeightGadgetMax < *Rc\Height) And (WidthGadgetMax < *Rc\Width)

                   ratio_Temp = WidthGadgetMax/*Rc\Width
                   ratio_dest = HeightGadgetMax/*Rc\Height

                   ; on utilise le ratio le plus petit pour réduire l'image d'origine
                   If ratio_Temp<ratio_dest
                        ratio_dest = ratio_Temp
                   EndIf

                   *Rc\Reduction = #True
                   ; on redimensionne
                   NewWidth = Round((*Rc\Width*ratio_dest), 0)
                   Newheight = Round((*Rc\Height*ratio_dest), 0)
                   ResizeImage(img, NewWidth, Newheight)
              EndIf

              ; fixe la valeur des éléments *Rc\X_Position et *Rc\Y_Position
              *Rc\X_Position = (#largeurScrollAreaOpenfile-NewWidth)/2
              If (#largeurScrollAreaOpenfile-NewWidth) & 1 ; impaire
                   *Rc\X_Position-1
              EndIf

              *Rc\Y_Position = (HeightGadgetMax + 25 + (#Offset_Y_Icone_Apercu*2)-Newheight)/2
              If (HeightGadgetMax + 25 + (#Offset_Y_Icone_Apercu*2)-Newheight) & 1 ; impaire
                   *Rc\Y_Position-1
              EndIf

              ProcedureReturn img
         Else
              ProcedureReturn #Return_Error
         EndIf

    EndProcedure

    Procedure Free_ScrollArea_From_Images()
         ; la procedure retire tous les gadgets du scrollarea du Dialogue GetOpenFileName_()
         If ListSize(Infos())
              ; on efface les éléments correspondants
              ForEach Infos()
                   FreeImageEx(Infos()\StaticImageId) ; image
                   If IsGadget(Infos()\StaticImageGadgetId)
                        SetGadgetState(Infos()\StaticImageGadgetId, 0)
                        FreeGadget(Infos()\StaticImageGadgetId) ; gadget utilisé pour afficher l'image
                   EndIf
              Next
              ClearList(Infos())
         EndIf
         InvalidateRectEX(#ScrollAreaGadget_OpenFileRequesterIcone, #Null, #True)
    EndProcedure

    Procedure Affiche_Image(chaine$)
         ; mémorise le texte d'énumération de l'icône
         Protected Texte$
         ; mémorise le type de fichier
         Protected FileType.l
         ; mémorise l'identifiant des images bmp etc
         Protected Img.l
         ; mémorise la position de l'image réduite qui sera affichée (format BMP, PNG etc)
         Protected Rc.AffichageMiniature

         Free_ScrollArea_From_Images()
         If FileSize(chaine$)>0 And IsGadget(#ScrollAreaGadget_OpenFileRequesterIcone) And IsGadget(#ContainerGadget_OpenFileRequesterIcone)
              Free_ScrollArea_From_Images()

              Select LCase(Right(chaine$, 4))

                   Case ".bmp"
                        FileType = #BMP
                        Img = LoadImageEx(chaine$, @rc)

                   Case ".jpg"
                        FileType = #JPG
                        Img = LoadImageEx(chaine$, @rc)

                   Case ".png"
                        FileType = #PNG
                        Img = LoadImageEx(chaine$, @rc)

                   Case ".tif"
                        FileType = #TIF
                        Img = LoadImageEx(chaine$, @rc)

              EndSelect

              Select FileType
                        ;-#BMP, #JPG
                   Case #BMP, #JPG, #PNG
                        ; on masque le scrollaragadget
                        HideGadget(#ScrollAreaGadget_OpenFileRequesterIcone, 1)
                        ; on affiche la listviewgadget
                        HideGadget(#ContainerGadget_OpenFileRequesterIcone, 0)
                        If Img<>#Return_Error
                             If AddElement(Infos())
                                  Infos()\StaticImageId = Img
                                  Infos()\StaticImageGadgetId = ImageGadget(#PB_Any, Rc\X_Position, Rc\Y_Position, 0, 0, ImageID(Img))

                                  If Infos()\StaticImageGadgetId
                                       If Rc\reduction
                                            Texte$ = "Image réduite - "
                                       Else
                                            Texte$ = "Image non réduite - "
                                       EndIf
                                       Texte$ + Str(rc\Width) + " x " + Str(rc\height) + " pixels"
                                       SetGadgetTextEx(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone, Texte$)
                                  EndIf
                             EndIf
                        EndIf

              EndSelect

         EndIf
    EndProcedure

    Procedure.l OFHookProc(hdlg, Message, wParam, *lParam.OFNOTIFY)
         ; ; mémorise l'identifiant système du dialogue
         Protected hDialog.l
         ; résultat de la fonction
         Protected Resultat = #False
         ; retrouve les coordonnées du bureau et de la boite de dialogue
         Protected wr.RECT, wr1.RECT, rcc.RECT
         ; mémorise le handle du parent de la boite de dialogue
         Protected Parent_hdlg.l
         ; mémorise l'adresse du buffer mémoire de 31 Ko
         Protected *FileBuffer.long
         ; mémorise le chemin du fichier
         Protected Path$
         ; mémorise la longuer du chemin
         Protected Path_Lenght.l
         ; mémorise les coordonnées de la Toolbar de gauche qui ne s'affiche pas bien avec les thèmes XP
         Protected rc.RECT
         ; mémorise les coordonnées de la zone client de la boite de dialogue
         Protected clientRect.rect
         ; mémorise les coordonnées de la boite de dialogue
         Protected windowrect.rect
         ; mémorise les coordonnées de de la boite de dialogue lors de l'énumération et son handle
         Protected ToolBarGauche.EnumChidlDatas
         ; mémorise les coordonnées du bouton Annuler
         Protected Cancel.RECT
         ; mémorise la hauteur calculée de la toobar pour redimensionnement eventuel
         Protected HauteurToolBar.l
         ; mémorise les écarts entre la zone client de la boite dialogue et ses coordonnée entières de la fenêtre
         ; est utilisé pour déterminer s'il faut ou non redimensionner, cette variable est aussi utilisée pour
         ; calculer l'offset à appliquer aux bouton Annuler et Ok
         Protected ecartWindow.l
         ; mémorise le texte de plusieurs fichiers sélectionnés
         Protected Texte$
         ; mémorise l'identifiant de la zone propre du scrollareagadget
         Protected hWnd_ScrollArea
         ; mémorise si la fenêtre Getopenfilename a déjà été modifiée
         Protected GetOpenfilename_modifer

         Select Message
              Case #WM_INITDIALOG
                   Parent_hdlg.l = GetParent_(hdlg)
                   If Parent_hdlg = 0
                        Resultat = #True
                   Else
                        Old_Dialogue_Proc = SetWindowLong_(Parent_hdlg, #GWL_WNDPROC, @DialogueCallBack())
                   EndIf
                   If GetWindowRect_(Parent_hdlg, wr.RECT) And GetWindowRect_(GetDesktopWindow_(), wr1.RECT)
                        If ((wr1\right/2)-((wr\right + #largeurScrollAreaOpenfile + 10)/2)>20) And (((wr1\bottom/2)-((wr\bottom)/2))>20)
                             MoveWindow_(Parent_hdlg, (wr1\right/2)-((wr\right + #largeurScrollAreaOpenfile + 10)/2), ((wr1\bottom/2)-((wr\bottom)/2)), wr\right + #largeurScrollAreaOpenfile + 30, wr\bottom-wr\top, #True)
                        EndIf
                   EndIf
                   If UseGadgetList(Parent_hdlg)
                        hDialog = GetDlgItem_(Parent_hdlg, #lst1)
                        If hDialog
                             If GetWindowRect_(hDialog, wr.RECT) And ScreenToClient_(hdlg, wr.RECT) And ScreenToClient_(hdlg, @wr\right)
                                  wr1\left = -10
                                  GetWindowRect_(GetDlgItem_(Parent_hdlg, #IDCANCEL), wr1.RECT)
                                  ScreenToClient_(hdlg, wr1.RECT)
                                  ScreenToClient_(hdlg, @wr1\right)
                                  ; création du scrollAreaGadget perso
                                  If ScrollAreaGadget(#ScrollAreaGadget_OpenFileRequesterIcone, wr\right + 20, wr\top + 22, #largeurScrollAreaOpenfile, wr1\bottom-wr\top-20, #largeurScrollAreaOpenfile-25, wr1\bottom-wr\top-40, 55, #PB_ScrollArea_Flat)
                                       hWnd_ScrollArea = FindWindowEx_(GadgetID(#ScrollAreaGadget_OpenFileRequesterIcone), 0, "PureScrollAreaChild", 0)
                                       If hWnd_ScrollArea
                                            Old_ScrollGadget_Proc = SetWindowLong_(hWnd_ScrollArea, #GWL_WNDPROC, @ScrollAreaGadget_CallBack())
                                       EndIf
                                       SetGadgetColorEX(#ScrollAreaGadget_OpenFileRequesterIcone, #PB_Gadget_BackColor, #CoulerFondScrollarea_Getopenfilename)
                                       SetGadgetAttribute(#ScrollAreaGadget_OpenFileRequesterIcone, #PB_ScrollArea_InnerWidth, #largeurScrollAreaOpenfile-25)
                                       ShowScrollBarEx(#ScrollAreaGadget_OpenFileRequesterIcone, #SB_VERT, #True)
                                       CloseGadgetList()
                                       TextGadget(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone, wr\right + 40, GadgetY(#ScrollAreaGadget_OpenFileRequesterIcone)-25, #largeurScrollAreaOpenfile-20, 20, "", #PB_Text_Center)
                                       SetgadgetfontEX(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone, Font_Textegadget_Nb_Format_Icones)
                                  EndIf
                                  ; création de la ListGadget perso
                                  If ContainerGadget(#ContainerGadget_OpenFileRequesterIcone, wr\right + 20, wr\top + 22, #largeurScrollAreaOpenfile, wr1\bottom-wr\top-20, #PB_Container_Flat)
                                       SetGadgetColor(#ContainerGadget_OpenFileRequesterIcone, #PB_Gadget_BackColor, #White)
                                       HideGadget(#ContainerGadget_OpenFileRequesterIcone, 1)
                                       If IsGadget(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone) = 0
                                            TextGadget(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone, wr\right + 40, GadgetY(#ContainerGadget_OpenFileRequesterIcone)-25, #largeurScrollAreaOpenfile-20, 20, "", #PB_Text_Center)
                                            SetgadgetfontEX(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone, Font_Textegadget_Nb_Format_Icones)
                                       EndIf
                                  EndIf
                             EndIf
                        EndIf
                   EndIf
                   Resultat = #True

              Case #WM_NOTIFY
                   *FileBuffer = *lParam\lpOFN\lCustData
                   If (_WIN32_WINNT> = $0501) And (GetOpenfilename_modifer = #False)
                        ; on retrouve les coordonnées de la toolbar et de son handle
                        ; on force ToolBarGauche\rc\left à une grande valeur pour que le teste dans EnumChildWindows_ soit Ok
                        ToolBarGauche\rc\left = 65534
                        EnumChildWindows_(*lParam\hdr\hwndFrom, @enumChildren(), @ToolBarGauche)
                        If Nb_Button_ToolBarGetOpenFileName< = 0
                             Nb_Button_ToolBarGetOpenFileName = SendMessage_(ToolBarGauche\dialog, #TB_BUTTONCOUNT, 0, 0)
                             If Nb_Button_ToolBarGetOpenFileName
                                  ; on réinitialise la fenêtre et le contrôle si besoin
                                  ; on retrouve la taille des boutons
                                  ; retrouve les coordonnées du dernier bouton
                                  If SendMessage_(ToolBarGauche\dialog, #TB_GETITEMRECT, Nb_Button_ToolBarGetOpenFileName-1, @rc)
                                       ; calcul de la hauteur ToolBar
                                       If GetWindowRect_(*lParam\hdr\hwndFrom, windowrect.RECT) And GetClientRect_(*lParam\hdr\hwndFrom, @clientRect)
                                            HauteurToolBar = rc\bottom + (Nb_Button_ToolBarGetOpenFileName*((SendMessage_(ToolBarGauche\dialog, #TB_GETPADDING, 0, 0)>>16) & $FFFF))
                                            ; calcul de la différence entre la zone client de la fenêtre et la fenêtre
                                            ecartWindow.l = (windowrect\bottom-windowrect\top)-(clientRect\bottom-clientRect\top)
                                            ; on vérifie avant de modifier si le point bas de la toolbar \bottom est inférieur au point bas du boutton annuler
                                            ; si c'est le cas on modifie, sinon on laisse
                                            If GetWindowRect_(GetDlgItem_(*lParam\hdr\hwndFrom, #IDCANCEL), Cancel.RECT); And (_WIN32_WINNT >= $0600)
                                                 If ScreenToClient_(*lParam\hdr\hwndFrom, @Cancel\right)
                                                      ; on teste si la hauteur de la toolbar des boutons à gauche dépasse le point bas du bouton "Quitter"
                                                      If HauteurToolBar>Cancel\bottom
                                                           ; cette valeur sera ajoutée à la valeur de la hauteur de la toolbar pour dimensionner la boite de dialogue correctement
                                                           ; on augmente la taille de la fenêtre du dialogue
                                                           MoveWindow_(*lParam\hdr\hwndFrom, windowrect\left, windowrect\top, windowrect\right-windowrect\left, HauteurToolBar + ToolBarGauche\rc\top + ecartWindow, #True)
                                                           ; on rectifie la taille de la toolbar des boutons à gauche pour qu'elle ne soit pas trop grande par rapport aux nombre de boutons
                                                           HauteurToolBar-((Nb_Button_ToolBarGetOpenFileName)*((SendMessage_(ToolBarGauche\dialog, #TB_GETPADDING, 0, 0)>>16) & $FFFF)) + 2

                                                           MoveWindow_(ToolBarGauche\dialog, ToolBarGauche\rc\left, ToolBarGauche\rc\top, ToolBarGauche\rc\right-ToolBarGauche\rc\left, HauteurToolBar, #True)
                                                           ; on décale les 2 boutons OK et Cancel et les 2 texte gadget qui vont avec
                                                           ; on descend le bouton cancel, on retrouve les coordonnées de la fenêtre déplacée
                                                           If GetWindowRect_(GetDlgItem_(*lParam\hdr\hwndFrom, #IDCANCEL), wr1.RECT) And GetWindowRect_(*lParam\hdr\hwndFrom, windowrect.RECT)
                                                                ecartWindow = (windowrect\bottom-wr1\bottom)/2
                                                                If ScreenToClient_(*lParam\hdr\hwndFrom, @wr1) And ScreenToClient_(*lParam\hdr\hwndFrom, @wr1 + 8)
                                                                     ; calcul de l'écart entre la partie basse du bouton et celle de la fenêtre, le tout divisé par 2
                                                                     MoveWindow_(GetDlgItem_(*lParam\hdr\hwndFrom, #IDCANCEL), wr1\left, wr1\top + ecartWindow, wr1\right-wr1\left, wr1\bottom-wr1\top, #True)
                                                                EndIf
                                                           EndIf
                                                           ; on repositionne le scrollarea juste après le déplacement du bouton cancel car on a ses coordonnées avec wr1
                                                           ResizeGadgetEx(#ScrollAreaGadget_OpenFileRequesterIcone, #PB_Ignore, #PB_Ignore, #PB_Ignore, GadgetHeight(#ScrollAreaGadget_OpenFileRequesterIcone) + (ecartWindow))
                                                           ResizeGadgetEx(#ContainerGadget_OpenFileRequesterIcone, #PB_Ignore, #PB_Ignore, #PB_Ignore, GadgetHeight(#ContainerGadget_OpenFileRequesterIcone) + (ecartWindow-2))

                                                           If GetWindowRect_(GetDlgItem_(*lParam\hdr\hwndFrom, #cmb1), wr1.RECT)
                                                                If ScreenToClient_(*lParam\hdr\hwndFrom, @wr1) And ScreenToClient_(*lParam\hdr\hwndFrom, @wr1 + 8)
                                                                     MoveWindow_(GetDlgItem_(*lParam\hdr\hwndFrom, #cmb1), wr1\left, wr1\top + ecartWindow, wr1\right-wr1\left, wr1\bottom-wr1\top, #True)
                                                                EndIf
                                                           EndIf
                                                           If GetWindowRect_(GetDlgItem_(*lParam\hdr\hwndFrom, #stc2), wr1.RECT)
                                                                If ScreenToClient_(*lParam\hdr\hwndFrom, @wr1) And ScreenToClient_(*lParam\hdr\hwndFrom, @wr1 + 8)
                                                                     MoveWindow_(GetDlgItem_(*lParam\hdr\hwndFrom, #stc2), wr1\left, wr1\top + ecartWindow, wr1\right-wr1\left, wr1\bottom-wr1\top, #True)
                                                                EndIf
                                                           EndIf

                                                           ecartWindow*2/3
                                                           If GetWindowRect_(GetDlgItem_(*lParam\hdr\hwndFrom, #IDOK), wr1.RECT)
                                                                If ScreenToClient_(*lParam\hdr\hwndFrom, @wr1) And ScreenToClient_(*lParam\hdr\hwndFrom, @wr1 + 8)
                                                                     MoveWindow_(GetDlgItem_(*lParam\hdr\hwndFrom, #IDOK), wr1\left, wr1\top + ecartWindow, wr1\right-wr1\left, wr1\bottom-wr1\top, #True)
                                                                EndIf
                                                           EndIf
                                                           If GetWindowRect_(GetDlgItem_(*lParam\hdr\hwndFrom, #cmb13), wr1.RECT)
                                                                If ScreenToClient_(*lParam\hdr\hwndFrom, @wr1) And ScreenToClient_(*lParam\hdr\hwndFrom, @wr1 + 8)
                                                                     MoveWindow_(GetDlgItem_(*lParam\hdr\hwndFrom, #cmb13), wr1\left, wr1\top + ecartWindow, wr1\right-wr1\left, wr1\bottom-wr1\top, #True)
                                                                EndIf
                                                           EndIf
                                                           ; texte "Nom du fichier"
                                                           If GetWindowRect_(GetDlgItem_(*lParam\hdr\hwndFrom, #stc3), wr1.RECT)
                                                                If ScreenToClient_(*lParam\hdr\hwndFrom, @wr1) And ScreenToClient_(*lParam\hdr\hwndFrom, @wr1 + 8)
                                                                     MoveWindow_(GetDlgItem_(*lParam\hdr\hwndFrom, #stc3), wr1\left, wr1\top + ecartWindow, wr1\right-wr1\left, wr1\bottom-wr1\top, #True)
                                                                EndIf
                                                           EndIf
                                                      Else
                                                           ; on ne modifie pas car pas besoin et la boite a été centré en WM_InitDialog
                                                      EndIf
                                                 EndIf
                                            EndIf
                                       EndIf
                                  EndIf
                             EndIf
                        EndIf
                   EndIf

                   Select *lParam\hdr\code
                        Case #CDN_INITDONE
                             GetOpenfilename_modifer = #True

                             ;- #CDN_FOLDERCHANGE, #CDN_TYPECHANGE
                        Case #CDN_FOLDERCHANGE, #CDN_TYPECHANGE
                             ShowScrollBarEx(#ScrollAreaGadget_OpenFileRequesterIcone, #SB_HORZ, #False)
                             SetgadgetfontEX(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone, Font_Textegadget_Nb_Format_Icones)
                             SendMessage_(*lParam\hdr\hwndFrom, #CDM_SETCONTROLTEXT, #edt1, @"")
                             If IsGadget(#ScrollAreaGadget_OpenFileRequesterIcone)
                                  SetGadgetTextEx(#TextGadget_ScrollAreaGadget_OpenFileRequesterIcone, "")
                                  Free_ScrollArea_From_Images()
                             EndIf

                             ;- #CDN_SELCHANGE
                        Case #CDN_SELCHANGE
                             If *lParam\hdr\code = #CDN_SELCHANGE
                                  ShowScrollBarEx(#ScrollAreaGadget_OpenFileRequesterIcone, #SB_HORZ, #False)
                                  If IsGadget(#ScrollAreaGadget_OpenFileRequesterIcone)
                                       Free_ScrollArea_From_Images()

                                       ; on vide la liste de ses éléments
                                       PokeL(*FileBuffer, 0) ; on remet la chaine à 0
                                       ; avant d'afficher, on vérifie que le fichier est bien dans la zone d'écriture des noms de fichiers
                                       SendMessage_(*lParam\hdr\hwndFrom, #CDM_GETSPEC, #Maxi_File_Buffer_31_Ko, *FileBuffer)
                                       ; on compte les " contenu dans la chaine
                                       If _UPeekB(*FileBuffer) = '"'
                                            ; remet les scrollbar à 0
                                            SetGadgetAttribute(#ScrollAreaGadget_OpenFileRequesterIcone, #PB_ScrollArea_InnerHeight, GadgetHeight(#ScrollAreaGadget_OpenFileRequesterIcone)-20)
                                            SetGadgetAttribute(#ScrollAreaGadget_OpenFileRequesterIcone, #PB_ScrollArea_InnerWidth, #largeurScrollAreaOpenfile-25)
                                            Texte$ = "Plusieurs éléments sont sélectionnés"
                                       ElseIf _UPeekB(*FileBuffer)
                                            ; on teste que c'est un fichier et pas un dossier
                                            Path_Lenght = 1
                                            Path$ = Space(Path_Lenght)
                                            Path_Lenght = SendMessage_(*lParam\hdr\hwndFrom, #CDM_GETFILEPATH, Path_Lenght, @Path$)
                                            If Path_Lenght>0
                                                 Path$ = Space(Path_Lenght-1)
                                                 If Len(Path$) = Path_Lenght-1
                                                      ; Path_Lenght = SendMessage_(*lParam\hdr\hwndFrom, #CDM_GETFOLDERPATH, Path_Lenght, @Path$)
                                                      Path_Lenght = SendMessage_(*lParam\hdr\hwndFrom, #CDM_GETFILEPATH, Path_Lenght, @Path$)
                                                      ; on teste si c'est un lien, fichier lnk
                                                      ; si oui, on ne fait rien, sinon, c'est un fichier à afficher
                                                      If LCase(Right(PeekS(*FileBuffer), #Link_extensionFile_Length))<>#Link_extensionFile
                                                           Path$ = GetPathPart(Path$)
                                                           If Len(Path$)
                                                                If Right(Path$, 1)<>"\"
                                                                     Path$ + "\"
                                                                EndIf
                                                                If FileSize(Path$ + PeekS(*FileBuffer))> = 0

                                                                     ; *********************************************
                                                                     ; c'est ici que l'on affiche l'image sélectionnée

                                                                     Affiche_Image(Path$ + PeekS(*FileBuffer))

                                                                     ; *********************************************

                                                                EndIf
                                                           EndIf
                                                      EndIf
                                                 EndIf
                                            EndIf
                                       EndIf
                                  EndIf
                             EndIf
                   EndSelect
                   Resultat = #True
         EndSelect

         ProcedureReturn Resultat
    EndProcedure

    Procedure.l Open_FileRequester(InitialDir$, Pattern.l, PatternPosition.l, buffer.l)
    Protected Resultat.l
    Protected lpofn.OPENFILENAMEXP

    lpofn\lStructSize = SizeOf(OPENFILENAMEXP)
    lpofn\hwndOwner = hMainWindow
    lpofn\hInstance = #Null
    lpofn\lpstrFilter = pattern
    lpofn\lpstrCustomFilter = #Null
    lpofn\nMaxCustFilter = #Null
    lpofn\nFilterIndex = PatternPosition
    lpofn\lpstrFile = buffer
    lpofn\nMaxFile = #Maxi_File_Buffer_31_Ko
    lpofn\lpstrFileTitle = #Null
    lpofn\nMaxFileTitle = #Null
    lpofn\lpstrInitialDir = @InitialDir$ ; Windows 2000/XP et > sinon voir la définition
    lpofn\lpstrTitle = @"Ouvrir les fichiers"
    lpofn\flags = #OFN_HIDEREADONLY | #OFN_EXPLORER | #OFN_ENABLEHOOK | #OFN_ALLOWMULTISELECT | #OFN_FILEMUSTEXIST | #OFN_FORCESHOWHIDDEN | #OFN_SHAREAWARE | #OFN_PATHMUSTEXIST
    lpofn\nFileOffset = 0
    lpofn\nFileExtension = 0
    lpofn\lpstrDefExt = 0
    lpofn\lCustData = buffer
    lpofn\lpfnHook = @OFHookProc()
    lpofn\lpTemplateName = 0
    lpofn\pvReserved = 0
    lpofn\FlagsEx = 0

    Font_Textegadget_Nb_Format_Icones = LoadFont(#PB_Any, "TAHOMA", 9, #PB_Font_Italic | #PB_Font_HighQuality)

    EnableWindow_(WindowID(#MainWindow), #False)

    Nb_Button_ToolBarGetOpenFileName = #False
    If GetOpenFileName_(@lpofn)
         Resultat = #True
    Else
         Resultat = -CommDlgExtendedError_()
    EndIf
    EnableWindow_(WindowID(#MainWindow), #True)

    ProcedureReturn Resultat
    EndProcedure

    Procedure.s Open_FileRequesterEx(InitialDir$, Pattern, PatternPosition, *ReturnedFilesNumber)
    Protected *FileBuffer
    Protected nb_files
    Protected getFile$ = ""
    Protected No_Error

    *FileBuffer = AllocateMemory(#Maxi_File_Buffer_31_Ko) ; 31 Ko alloué pour la chaîne
    If *FileBuffer = 0
         ProcedureReturn getFile$
    EndIf

    No_Error = Open_FileRequester(InitialDir$, Pattern, PatternPosition, *FileBuffer)
    If Len(PeekS(*FileBuffer))
         If No_Error = #True
              If FileSize(GetFilePart(PeekS(*FileBuffer)))<0
                   ; on met une virgule à la place des 0 pour séparer les fichiers et le chemin également
                   ; si il y a un double 0, c'est la fin de chaine, on termine sans mettre de virgule
                   ; le nombre de fichiers est le nobre de virgule
                   ! xor ecx, ecx ; ecx mémorise le nombre de virgules
                   ! mov eax, [p.p_FileBuffer] ; eax = adresse zone mémoire
                   ! boucle :
                   ! inc eax ; eax pointe le 1er élément
                   ! cmp word [eax], 0 ; teste si c'est un double 0, si oui on quite
                   ! je quit
                   ! cmp byte [eax], 0 ; il n'y a pas de double 0, on teste le 0 simple
                   ! je virgule ; si = 0 on met une virgule
                   ! jmp boucle
                   ! virgule :
                   ! mov byte [eax], ","
                   ! inc ecx
                   ! jmp boucle
                   ! quit :
                   ! mov eax, [p.p_ReturnedFilesNumber] ; i vaut le nombre de fichier contenu dans la chaine
                   ! mov [eax], ecx ; i vaut le nombre de fichiers contenu dans la chaine
              Else
                   ; un seul fichier de sélectionné
                   ! mov ecx, 1
              EndIf
              ! mov eax, [p.p_ReturnedFilesNumber] ; i vaut le nombre de fichier contenu dans la chaine
              ! mov [eax], ecx
              getFile$ = PeekS(*FileBuffer)
         Else
              ; GetOpenFileName_ retourne nonzero si c'est OK
              ; sinon retourne 0 et il faut tester CommDlgExtendedError_()
              ; ici GetOpenFileName a retourné 0
              ;
              ; GetOpenFileName_() retourne 0
              ; si CommDlgExtendedError_() = 0 --> le bouton cancel a été activé, on ne fait rien
              ;
              ; on met le compteur de fichier à 0
              ! mov eax, [p.p_ReturnedFilesNumber] ; i vaut le nombre de fichier contenu dans la chaine
              ! sub ecx, ecx ; ecx vaut le nombre de fichiers contenu dans la chaine soit 0 ici
              ! mov [eax], ecx

              ; on traite les erreurs
              ; si CommDlgExtendedError_() = 0 --> le bouton cancel a été activé, on ne fait rien
              If No_Error
                   MessageRequester("Error/Erreur", "An error system has occur, no file names returned" + Chr(13) + Chr(13) + "Une erreur système est arrivéee, aucun nom de fichier renvoyé")
              EndIf
         EndIf
    EndIf
    FreeMemory(*FileBuffer)
    ProcedureReturn getFile$
    EndProcedure

    ;- Code principal
    hMainWindow = OpenWindow(#MainWindow, Ecran\left, Ecran\top, Largeur_Ecran, Hauteur_Ecran, "Openfilerequester et miniatures", #Option_Fenetre)
    If hMainWindow = 0
         MessageRequester("Erreur système", "La création de la fenêtre principale a échouée." + #CRLF + "L'application va se terminer.", 16)
         End
    EndIf
    Init_Main()

    ;ShowWindow_(hMainWindow, #SW_SHOWMAXIMIZED)

    Open_FileRequesterEx("C:\" + "\JPG", ?Patern_Ico, 1, @FileNumber)

    ; ShowWindow_(hMainWindow, #SW_SHOWMAXIMIZED)

    ; ;- Boucle
    ; Repeat
         ; Select WaitWindowEvent()
                   ;
              ; Case #PB_Event_CloseWindow
                   ; Quitter_Application = #True
                   ;
         ; EndSelect
    ; Until Quitter_Application

    ; restauration de la mémoire etc
    UnInit_Main()
    DisableASM
    End

    DataSection
         Patern_Ico : ; filtre pour les fichiers au format ico, dll, exe, icl etc
         Data.s "Tous formats"
         Data.s "*.ani;*.cur;*.icl;*.ico;*.dll;*.exe;*.bmp;*.jpg;*.png;*.tif;*.tiff"
         Data.s "icones (*.icl;*.ico;*.dll;*.exe)"
         Data.s "*.icl;*.ico;*.dll;*.exe"
         Data.s "Bibliothèques d'icône (*.icl)"
         Data.s "*.icl"
         Data.s "Curseurs (*.ani, *.cur)"
         Data.s "*.ani;*.cur"
         Data.s "Images (*.bmp, *.jpg, *.png, *.tif, *.tiff)"
         Data.s "*.bmp;*.jpg;*.png;*.tif;*.tiff"
         ; Data.s "Curseurs animés(*.ani)"
         ; Data.s "*.ani"
         ; Data.s "Curseurs simples(*.cur)"
         ; Data.s "*.cur"
         Data.w 0 ; double 0 de fin de chaine signalant la fin des filtres de la boîte
    EndDataSection

Créé le 27 novembre 2008 par Denis
image compressée dans la DataSection (intégrée dans le code)

Cet utilitaire permet d'intégrer une image dans le code source. Les données de l'image sont compressées pour réduire la taille dans le programme.
Lancez ce code, une fenêtre apparait avec une cible, faites glisser une image sur cette cible (drag and drop) et suivez les instructions.
Un fichier sera généré, vous n'avez plus qu'à l'intégrer dans votre programme.

Sélectionnez

    ;**************************************************************
    ; Program:           PicPak
    ; Author:            netmaestro
    ; Date:              April 15, 2006
    ; Target OS:         Microsoft Windows All
    ; Target Compiler:   PureBasic 4.xx
    ; License:           Free, unrestricted, credit appreciated
    ;                    but not required
    ;**************************************************************

    Declare CreateDataSection(picin.s)

    Procedure.s GetDroppedFile()
      buf.s=Space(DragQueryFile_(EventwParam(),0,0,0))
      DragQueryFile_(EventwParam(), 0, buf, Len(buf)+1)
      DragFinish_(EventwParam())
      ProcedureReturn buf
    EndProcedure

    line$=Chr(10)
    line$+ "          Written in PureBasic by netmaestro, April 2006"+Chr(10)+Chr(10)
    line$+ "          100% free to use, distribute, reverse-engineer,"+Chr(10)
    line$+ "          repackage and say you wrote it, anything you want"+Chr(10)
    line$+ "          to do with it is A-OK with me"+Chr(10)

    use$=""+Chr(10)
    use$ + Space(3) + "1. Drop an image file on the window"+Chr(13)+Chr(10)+Chr(10)
    use$ + Space(3) + "2. Select a label name"+Chr(13)+Chr(10)+Chr(10)
    use$ + Space(3) + "3. Look for Temp.pbi in this folder"+Chr(13)+Chr(10)+Chr(10)
    use$ + Space(3) + "4. The #image img0 will be ready to use!"+Chr(13)+Chr(10)+Chr(10)

    CreateImage(0, 512,512,32)
    StartDrawing(ImageOutput(0))
      Box(0,0,512,512,GetSysColor_(#COLOR_BTNFACE))
      Circle(256,256,256,#Red)
      Circle(256,256,200,#White)
      Circle(256,256,145,#Red)
      Circle(256,256,80,#White)
      Circle(256,256,40,#Red)
    StopDrawing()
    ResizeImage(0,120,120)

    OpenWindow(0,0,0,150,170,"PicPak",#PB_Window_SystemMenu|#PB_Window_ScreenCentered)
    CreateGadgetList(WindowID(0))
    ImageGadget(0,15,15,0,0,ImageID(0))
    DisableGadget(0,1)
    DragAcceptFiles_ (WindowID(0), #True)
    StickyWindow(0,#True)

    If CreateMenu(0, WindowID(0))
       MenuTitle("Menu")
       MenuItem( 1, "Usage")
       MenuItem( 2, "About...")
    EndIf

    source.s = ProgramParameter()
    If source
      CreateDataSection(source)
    EndIf

    Repeat
      ev=WaitWindowEvent()
      Select ev
        Case #WM_DROPFILES
          Source.s = GetDroppedFile()
          ext.s = GetExtensionPart(source)
          If FindString("BMP JPG JPEG TIF PNG", UCase(ext),1)
            CreateDataSection(source)
          Else
            StickyWindow(0,#False)
            MessageRequester("Problem","File must be:  BMP, JPG, PNG or TIF",#MB_ICONERROR)
            StickyWindow(0,#True)
          EndIf
        Case #PB_Event_Menu
          Select EventMenu()
            Case 1
              StickyWindow(0,#False)
              MessageRequester("How to use PicPak",use$,$C0)
              StickyWindow(0,#True)
            Case 2
              StickyWindow(0,#False)
              MessageRequester("About PicPak",line$, $C0)
              StickyWindow(0,#True)
          EndSelect
      EndSelect
    Until ev=#WM_CLOSE

    Procedure CreateDataSection(picin.s)
      Pattern$ = "BMP (*.bmp)|*.bmp|JPEG (*.jpg)|*.jpg|PNG (*.png)|*.png|TIFF (*.tif)|*.tif"
      If picin = " "
        picin.s = OpenFileRequester("Choose an image file", "", pattern$, 0)
      EndIf
      ext.s = GetExtensionPart(picin)
      If ReadFile(0,picin)
        FileLength = Lof(0)
        *Source = AllocateMemory(FileLength)
        *Target = AllocateMemory(FileLength+8)
        If FileLength And *Source And *Target
          ReadData(0, *Source, FileLength)
          CompressedLength = PackMemory(*Source, *Target, FileLength, 9)
          If CompressedLength
            DecompressedLength = UnpackMemory(*Target, *Source)
            If DecompressedLength = FileLength
              StickyWindow(0,#False)
              MessageRequester("Info", "Compression succeeded:"+Chr(10)+Chr(10)+"Old size: "+Str(FileLength)+Chr(10)+"New size: "+Str(CompressedLength), #MB_ICONINFORMATION)
              StickyWindow(0,#True)
              FreeMemory(*source)
              *Source = AllocateMemory(compressedLength)
              CopyMemory(*target,*source,compressedlength)
            EndIf
          Else
            compressedlength=filelength
            StickyWindow(0,#False)
            MessageRequester("Info", "Compression not needed", #MB_ICONINFORMATION)
            StickyWindow(0,#True)
          EndIf
          StickyWindow(0,#False)
          label.s = InputRequester("Label Input","Enter a label For the DataSection: ","PicPak:")
          If Trim(label)=""
            label="picpak"
          EndIf
          label="  "+label
          StickyWindow(0,#True)
          label=RemoveString(label,":")
          endlabel.s = label+"end:"
          label+":"
          If CreateFile(1,GetHomeDirectory()+"temp.pbi")
            WriteStringN(1,""):clip$=Chr(10)
            Select ext
              Case "jpg"
                WriteStringN(1,"UseJPEGImageDecoder()"):clip$+"UseJPEGImageDecoder()"+Chr(10)
              Case "png"
                WriteStringN(1,"UsePNGImageDecoder()"):clip$+"UsePNGImageDecoder()"+Chr(10)
              Case "tif"
                WriteStringN(1,"UseTIFFImageDecoder()"):clip$+"UseTIFFImageDecoder()"+Chr(10)
            EndSelect
            If compressedlength<>filelength
              WriteStringN(1,"*unpacked = AllocateMemory("+Str(Filelength)+")")
              WriteStringN(1,"UnpackMemory(?"+Trim(RemoveString(label,":"))+", *unpacked)")
              WriteStringN(1,"img0 = CatchImage(#PB_Any, *unpacked, "+Str(Filelength)+")")
              clip$+"*unpacked = AllocateMemory("+Str(Filelength)+")"+Chr(10)
              clip$+"UnpackMemory(?"+Trim(RemoveString(label,":"))+", *unpacked)"+Chr(10)
              clip$+"img0 = CatchImage(#PB_Any, *unpacked, "+Str(Filelength)+")"+Chr(10)
            Else
              WriteStringN(1,"img0 = CatchImage(#PB_Any, ?" + Trim(RemoveString(label,":")) + ", "+Str(Filelength)+")")
              clip$+"img0 = CatchImage(#PB_Any, ?" + Trim(RemoveString(label,":")) + ", "+Str(Filelength)+")"+Chr(10)
            EndIf
            clip$+Chr(10)
            SetClipboardText(clip$)
            WriteStringN(1,"")
            WriteStringN(1,"Datasection")
            WriteStringN(1,label)
            WriteString(1,"  Data.b ")
            c=0
            For i = 0 To compressedlength-1
              If i=compressedlength-1
                lastbyte=#True
              Else
                lastbyte=#False
              EndIf
              c+1
              If c >= 20 Or lastbyte
                c = 0
                WriteStringN(1, "$"+RSet(Hex(PeekC(*source+i)),2,"0"))
                If Not lastbyte
                  WriteString(1,"  Data.b ")
                EndIf
              Else
                WriteString(1, "$"+RSet(Hex(PeekC(*source+i)),2,"0")+",")
              EndIf
            Next
            WriteStringN(1,endlabel)
            WriteStringN(1,"EndDatasection")
            CloseFile(1)
            FreeMemory(*Source)
            FreeMemory(*Target)
            CloseFile(0)
            MessageRequester("Success!","Temp.pbi successfully created: "+GetHomeDirectory()+"temp.pbi")
          Else
            MessageRequester("Problem","Could not open the output file")
          EndIf
        Else
          MessageRequester("Problem","Could not allocate the memory... file too large?")
        EndIf
      Else
        MessageRequester("Problem","Could not open input file")
      EndIf
    EndProcedure

Exemple de fichier généré :

Sélectionnez

    *unpacked = AllocateMemory(1142)
    UnpackMemory(?Poubelle, *unpacked)
    img0 = CatchImage(#PB_Any, *unpacked, 1142)

    DataSection
      Poubelle:
      Data.b $4A,$43,$76,$04,$00,$00,$77,$4D,$F0,$08,$14,$6A,$E2,$20,$15,$36,$3C,$EA,$03,$45
      Data.b $26,$1A,$12,$45,$9A,$14,$80,$27,$04,$A4,$81,$08,$33,$46,$8F,$60,$CC,$80,$96,$A0
      Data.b $11,$38,$98,$34,$0D,$7A,$F0,$71,$6C,$0E,$0A,$86,$E5,$BF,$50,$D1,$00,$04,$BF,$28
      Data.b $55,$A6,$EC,$D7,$04,$F0,$1F,$F8,$60,$89,$FD,$AF,$17,$6E,$C6,$13,$DA,$43,$8F,$3E
      Data.b $BF,$71,$2A,$F0,$AE,$D9,$36,$25,$BC,$6D,$5F,$BE,$AF,$FD,$74,$C4,$FD,$97,$D7,$9D
      Data.b $57,$32,$6D,$02,$E0,$CC,$37,$EF,$BC,$79,$D9,$23,$9F,$A0,$C9,$5D,$BA,$CF,$F8,$04
      Data.b $75,$49,$EB,$0B,$66,$08,$FE,$4F,$9D,$34,$99,$53,$B8,$BB,$C5,$89,$29,$F1,$23,$99
      Data.b $23,$92,$81,$30,$43,$6A,$BF,$2E,$5F,$F2,$F3,$BC,$FF,$EB,$3D,$25,$FB,$F4,$AB,$A9
      Data.b $1F,$5D,$C4,$01,$33,$F7,$21,$FC,$18,$EF,$E7,$1D,$F9,$DA,$DD,$56,$3F,$79,$B3,$BF
      Data.b $BC,$A7,$F6,$EB,$BD,$CD,$02,$20,$8D,$0F,$FB,$FA,$FB,$E9,$F4,$96,$08,$FE,$F9,$D7
      Data.b $BF,$FF,$E1,$42,$FB,$29,$CF,$10,$25,$72,$F3,$65,$C4,$93,$FC,$BF,$8E,$3A,$69,$FD
      Data.b $47,$CF,$3D,$F5,$DA,$E1,$CD,$F7,$BE,$0F,$BF,$FB,$F0,$BF,$33,$96,$B6,$5F,$6B,$EE
      Data.b $3E,$BC,$F4,$E7,$A7,$B1,$F4,$27,$15,$09,$35,$FF,$75,$D2,$2C,$22,$09,$FB,$48,$EF
      Data.b $AF,$02,$10,$28,$7D,$6A,$52,$4C,$40,$0C,$A4,$1A,$94,$68,$A5,$56,$EE,$A0,$26,$61
      Data.b $C5,$C1,$0E,$6D,$CD,$10,$ED,$85,$A1,$9F,$D4,$5E,$DC,$A5,$F8,$72,$C9,$CA,$2A,$25
      Data.b $28,$7A,$2F,$7C,$96,$47,$3F,$49,$5C,$FB,$7B,$77,$C2,$1E,$27,$28,$41,$EC,$F5,$2E
      Data.b $56,$BE,$A7,$FA,$2B,$2F,$B6,$26,$3C,$C8,$34,$0F,$EE,$D3,$C6,$F9,$F3,$8D,$38,$EF
      Data.b $7C,$98,$E1,$FF,$E5,$6C,$64,$6B,$E6,$90,$D3,$64,$5D,$D4,$5E,$82,$82,$85,$26,$DF
      Data.b $D8,$73,$D8,$2C,$03,$9E,$79,$55,$B2,$EC,$30,$8F,$24,$45,$F2,$51,$3F,$8D,$98,$6F
      Data.b $56,$AC,$AE,$3C,$7E,$A9,$84,$FA,$B1,$57,$6D,$DA,$A1,$E6,$99,$B9,$9F,$D4,$9D,$AB
      Data.b $D0,$BA,$C1,$A3,$17,$5D,$37,$63,$A3,$B4,$43,$96,$28,$3B,$61,$C1,$59,$5F,$DD,$AD
      Data.b $B5,$28,$88,$39,$AF,$4E,$F9,$5E,$BB,$DC,$C7,$C9,$B3,$0D,$59,$CF,$42,$31,$D5,$2B
      Data.b $70,$E0,$AC,$9A,$A9,$62,$F0,$5C,$B6,$9A,$18,$8C,$59,$73,$6F,$BF,$FF,$C7,$FC,$2C
      Data.b $F4,$FD,$05,$BE,$84,$F3,$BF,$AB,$74,$F8,$BE,$C2,$39,$9F,$4E,$67,$8E,$E9,$02,$37
      Data.b $BB,$40,$8A,$BE,$1D,$97,$DF,$BC,$47,$ED,$64,$BF,$54,$37,$97,$88,$9F,$3E,$3C,$BC
      Data.b $2D,$41,$25,$29,$C7,$07,$1F,$E8,$D9,$8E,$65,$62,$4D,$6A,$DA,$1F,$C5,$BB,$8B,$77
      Data.b $F2,$C4,$FE,$ED,$EB,$F1,$CC,$BD,$03,$D9,$A7,$7E,$B1,$7E,$6D,$F9,$43,$8F,$EB,$AF
      Data.b $CB,$73,$2E,$32,$61,$DB,$69,$23,$13,$57,$E1,$7D,$66,$2A,$1D,$71,$69,$97,$69,$8F
      Data.b $87,$F8,$CF,$93,$96,$B6,$BA,$9A,$6E,$6A,$CA,$D9,$B7,$ED,$39,$F4,$D6,$CD,$A3,$BB
      Data.b $FF,$69,$FB,$F5,$27,$35,$E9,$1C,$6C,$43,$6B,$95,$E0,$3D,$FE,$59,$93,$53,$D4,$69
      Data.b $D1,$A4,$C1,$0A,$75,$4D,$00,$00,$00,$82
      Poubelleend:
    EndDataSection

Vous pouvez désormais utiliser l'image 'img0' dans votre code.
Pensez à utiliser le décodeur correspondant au format de l'image initiale. Par exemple UsePngImageDecoder() si l'image initiale était dans le format PNG.

Créé le 27 novembre 2008 par netmaestro
Gestion bibliothèques avec sqlite

Jusqu'à présent, je ne faisais que de la 2D ou de la 3D avec PureBasic.
Avec l'arrivée de Sqlite dans PureBasic, j'avais envie de tester cette bibliothèque et de créer une petite application pour me faire la main.
J'ai choisi un sujet classique, la gestion de mes livres. Pour commencer en douceur, il y a seulement 3 fiches :

- Les livres
- Les auteurs
- Les éditeurs

Sur la fiche 'Livres' figure la liste des livres, mais aussi la liste des auteurs et la liste des éditeurs du livre sélectionné (cliquez sur un livre pour le sélectionner).
Sur la fiche 'Auteurs' figure la liste des auteurs, mais aussi la liste des livres de l'auteur sélectionné (cliquez sur un auteur pour le sélectionner).
Sur la fiche 'Editeurs' figure la liste des éditeurs, mais aussi la liste des livres de l'éditeur sélectionné (cliquez sur un éditeur pour le sélectionner).
L'application utilise le 'glisser et déposer' (drag and drop).
Sur chaque fiche, il y a une poubelle dans laquelle il est possible de glisser (et donc supprimer) les éléments de la fiche.
Vous pouvez aussi utiliser le glisser et déposer pour affecter un livre à un auteur ou un éditeur, ou glisser un auteur ou un éditeur dans la fiche livre.
Pour modifier un enregistrement double cliquez sur l'élément à modifier.
L'archive contient un exécutable pour tester sans PureBasic, ainsi qu'une base de données de tests 'MaBibliotheque.sqlite'. Les sources se trouvent également dans l'archive.
Je ne connaissais pas Sqlite avant ce projet, aussi soyez indulgents, et surtout n'hésitez pas à me contacter pour me corriger ou proposer une meilleure utilisation de Sqlite.
Une version pour Linux est disponible ici.

Créé le 29 novembre 2008 par Comtois

Téléchargez le zip

Le compte (bancaire) est bon !

Débutant en PB je me suis dis que le plus simple (!!) serait peut être d'adapter un petit programme de ceux que j'ai déjà en PHP.
Voici donc ma toute première réalisation qui sert uniquement à vérifier les comptes bancaires entrés dans les formulaires divers.

Sélectionnez

    Enumeration
    #WindowMain

    #GAD_TEXT_code_banque
    #GAD_TEXT_code_guichet
    #GAD_TEXT_compte
    #GAD_TEXT_rib
    #GAD_TEXT_message

    #GAD_STR_code_banque
    #GAD_STR_code_guichet
    #GAD_STR_compte
    #GAD_STR_rib

    #GAD_BOUT_validation
    #GAD_BOUT_abandon

    EndEnumeration

    Declare controlerib()

    OpenWindow(#WindowMain, 0, 0, 550, 160, "Contrôle des comptes bancaires", #PB_Window_ScreenCentered )
    CreateGadgetList(WindowID(#WindowMain))

    ButtonGadget(#GAD_BOUT_validation, 20,20, 150, 20, "controle du compte")
    ButtonGadget(#GAD_BOUT_abandon, 20, 110, 150, 20, "Abandon")

    TextGadget(#GAD_TEXT_code_banque, 200, 20, 120, 20, "Code banque")
    TextGadget(#GAD_TEXT_code_guichet, 200, 50, 120, 20, "Code guichet")
    TextGadget(#GAD_TEXT_compte, 200, 80, 120, 20, "Numéro de compte")
    TextGadget(#GAD_TEXT_rib, 200, 110, 120, 20, "Clé RIB")

    TextGadget(#GAD_TEXT_message, 200, 140, 330, 15, "", #PB_Text_Center)
    SetGadgetColor(#GAD_TEXT_message, #PB_Gadget_BackColor, $BAFEFC )
    SetGadgetColor(#GAD_TEXT_message, #PB_Gadget_FrontColor, $0000FD )
    HideGadget(#GAD_TEXT_message, 1)

    StringGadget(#GAD_STR_code_banque, 350, 20, 50, 20, "",#PB_String_Numeric)
    StringGadget(#GAD_STR_code_guichet, 350, 50, 50, 20, "",#PB_String_Numeric)
    StringGadget(#GAD_STR_compte, 350, 80, 180, 20, "", #PB_String_UpperCase)
    StringGadget(#GAD_STR_rib, 350, 110, 50, 20, "",#PB_String_Numeric)

    Repeat
       event = WaitWindowEvent()
          If event = #PB_Event_Gadget
             Select EventGadget()
                Case #GAD_BOUT_validation
                   ;déclenche le controle du compte bancaire
                   controlerib()
             EndSelect
          EndIf
    Until EventGadget() = #GAD_BOUT_abandon

    Procedure controlerib()
       ;Réinitialise l'affichage préalablement au contrôle
       SetGadgetColor(#GAD_STR_code_banque, #PB_Gadget_BackColor, $FFFFFF )
       SetGadgetColor(#GAD_STR_code_banque, #PB_Gadget_FrontColor, $000000 )
       SetGadgetColor(#GAD_STR_code_guichet, #PB_Gadget_BackColor, $FFFFFF )
       SetGadgetColor(#GAD_STR_code_guichet, #PB_Gadget_FrontColor, $000000 )
       SetGadgetColor(#GAD_STR_compte, #PB_Gadget_BackColor, $FFFFFF )
       SetGadgetColor(#GAD_STR_compte, #PB_Gadget_FrontColor, $000000 )
       SetGadgetColor(#GAD_STR_rib, #PB_Gadget_BackColor, $FFFFFF )
       SetGadgetColor(#GAD_STR_rib, #PB_Gadget_FrontColor, $000000 )
        HideGadget(#GAD_TEXT_message, 1)

       ;Certain comptes comme ceux de la Poste comporte des lettres dans le numéro de compte
       ;Il est nécéssaire de remplacer ces lettres par un caractère numérique selon l'algorithme suivant
         compte.s = ""
         For compteur = 1 To 11 ;Les 11 caractères du compte sont lus les un après les autres
            caractere.s = Mid(GetGadgetText(#GAD_STR_compte), compteur, 1) ; on extrait le caractère
            ascode.b = Asc(caractere) ; et on lit son code ASCII

            If ascode > 82 ;soit [S-Z]                           ;
                compte + Str((Asc(caractere) -81)%10)         ;
            ElseIf ascode >73 ; soit [J-R]                     ;
                compte + Str((Asc(caractere)-73)%10)         ; si le code ASCII représente une lettre il est transformé selon son rang
            ElseIf ascode >57 ; soit [A-I]                     ; et ajouté en fin de chaine "compte"
                compte + Str((Asc(caractere)-64)%10)         ;
            Else
                compte + caractere                              ; si c'est un chiffre il est conservé tel quel et ajouté à la chaine
            EndIf
         Next

         ;par exemple, le compte 00915078A24 sera remplacé par 00915078124
         ;code ASCII de A = 65 soit 65-64=1     1%10=1
         ;ou encore le compte Z0915078A24 sera remplacé par 90915078124
         ;code ASCII de Z = 90 soit 90-81=9   9%10=9

        ; ensuite le calcul de la clé est le suivant que je vous laisse découvrir. Un petit conseil, surlignez bien les parenthèses pour suivre les calculs
         cle.s = Str(Val(GetGadgetText(#GAD_STR_code_banque))%97)
         cle = Str((Val(cle) * 100000 + (Val(GetGadgetText(#GAD_STR_code_guichet))))%97)
         cle = Str((Val(cle) * 1000000 + (Val(Left(compte , 6))))%97)
         cle = Str((Val(cle) * 100000 + (Val(Right(compte , 5))))%97)
         cle = Str(((97 - Val(cle)) * 100)%97)
         If Len(cle) < 2 : cle = "0" + cle : EndIf

         ;et une simple comparaison permet de modifier l'affichage pour attirer l'attention en cas d'erreur
         If cle <> GetGadgetText(#GAD_STR_rib)
                SetGadgetColor(#GAD_STR_code_banque, #PB_Gadget_BackColor, $BAFEFC )
                SetGadgetColor(#GAD_STR_code_banque, #PB_Gadget_FrontColor, $0000FD )
                SetGadgetColor(#GAD_STR_code_guichet, #PB_Gadget_BackColor, $BAFEFC )
                SetGadgetColor(#GAD_STR_code_guichet, #PB_Gadget_FrontColor, $0000FD )
                SetGadgetColor(#GAD_STR_compte, #PB_Gadget_BackColor, $BAFEFC )
                SetGadgetColor(#GAD_STR_compte, #PB_Gadget_FrontColor, $0000FD )
                SetGadgetColor(#GAD_STR_rib, #PB_Gadget_BackColor, $BAFEFC )
                SetGadgetColor(#GAD_STR_rib, #PB_Gadget_FrontColor, $0000FD )
                SetGadgetText(#GAD_TEXT_message, "Pour ce compte la clé RIB devrait être: " + cle + ". A vous de voir  !!!")
                HideGadget(#GAD_TEXT_message, 0)
         EndIf

    EndProcedure

Créé le 3 décembre 2008 par Claude-OI
Calcul et affichage d'engrenages

Ce code calcule et affiche un engrenage pour lequel vous pouvez définir différents paramètres comme :

- Module
- Nombre de dents
- Angle de pression
- Déport (*module)
- H tête (*module)
- H pied (*module)
- R chanfrein (*module)

Sélectionnez

    ; Auteur : Le Soldat Inconnu
    ; Version de PB : 4.40
    ;
    ; Explication du programme :
    ; Dessiner un engrenage

    ; Le filtre permet d'émuler de l'antialiasing sur le dessin de l'engrenage, ne pas mettre au dessus de 8
    Global FiltreAA = 4, Dessin_Angle.d, Dessin_Zoom.d, Dessin.i

    Enumeration
      ; Paramètres
      #G_Module
      #G_Z
      #G_Angle_Pression
      #G_D_primitif
      #G_D_pied
      #G_D_tete
      #G_H_dent
      #G_Pas
      #G_Deport
      ; Norme
      #G_H_pied
      #G_H_tete
      #G_R_chanfrein

      ; Autres
      #G_Onglet
      #G_Zoom
      #G_Dessin
      #G_Angle

    EndEnumeration

    #Engrenage_ResolutionDent = 314
    #Equation_Degree = 1
    #Cremaillere_NbEquation = 7
    #Engrenage_Couleur = $FF00FFFF
    #Engrenage_Diametre = $200000FF
    #Engrenage2_Couleur = $FF0000FF
    #Cremaillere_Couleur = $40FFFFFF
    #Cremaillere_Hauteur = $400000FF
    Structure Structure_Cercle
      x.d
      y.d
      R.d
      Interieur.b
      Exterieur.b
    EndStructure
    Structure Structure_Equation
      x1.d
      x2.d
      v.d[#Equation_Degree + 1]
      c.Structure_Cercle
    EndStructure
    Structure Structure_Rayon
      R.d
      Angle.d
      Zone.b
    EndStructure
    Structure Structure_Engrenage
      Module.d
      Z.d
      D_primitif.d
      D_tete.d
      D_pied.d
      H_dent.d
      Angle_pression.d
      Pas.d
      Deport.d
      H_tete.d
      H_pied.d
      R_chanfrein.d
      Contour.Structure_Rayon[#Engrenage_ResolutionDent]
      Cremaillere.Structure_Equation[#Cremaillere_NbEquation]
      Outil.Structure_Equation[#Cremaillere_NbEquation]
    EndStructure

    Global Engrenage.Structure_Engrenage

    Procedure.s AfficheValeur(Valeur.d)
      ProcedureReturn RTrim(RTrim(RTrim(StrD(Valeur), "0"), "."), ",")
    EndProcedure

    Procedure Engrenage_Calcul(*Calcul.Structure_Engrenage)
      With *Calcul
        ;- Paramètres de l'engrenage
        \D_primitif = \Z * \Module
        \D_tete = \D_primitif + 2 * \H_tete * \Module
        \D_pied = \D_primitif - 2 * \H_pied * \Module
        \Pas = #PI * \Module
        \H_dent = (\H_tete + \H_pied) * \Module
        ;- Equation de la crémaillère
        Largeur_zone_tete.d = \Pas / 2 - 2 * \H_tete * \Module * Sin(\Angle_pression * #PI / 180)
        Largeur_zone_cercle.d = \R_chanfrein * \Module * Cos(\Angle_pression * #PI / 180)
        Hauteur_zone_cercle.d = \R_chanfrein * \Module * (1-Sin(\Angle_pression * #PI / 180))
        Largeur_zone_inclinee.d = (\H_dent - Hauteur_zone_cercle) * Sin(\Angle_pression * #PI / 180)
        Largeur_zone_pied.d = \Pas - Largeur_zone_tete - 2 * Largeur_zone_cercle - 2 * Largeur_zone_inclinee
        ; Zone 1
        \Cremaillere[0]\x1 = 0
        \Cremaillere[0]\x2 = Largeur_zone_tete / 2
        \Cremaillere[0]\v[0] = \H_dent
        ; zone 2
        \Cremaillere[1]\x1 = \Cremaillere[0]\x2
        \Cremaillere[1]\x2 = \Cremaillere[1]\x1 + Largeur_zone_inclinee
        \Cremaillere[1]\v[1] = -1/Sin(\Angle_pression * #PI / 180)
        \Cremaillere[1]\v[0] = \H_dent - \Cremaillere[1]\v[1] * \Cremaillere[1]\x1
        ; zone 3
        \Cremaillere[2]\x1 = \Cremaillere[1]\x2
        \Cremaillere[2]\x2 = \Cremaillere[2]\x1 + Largeur_zone_cercle
        ; \Cremaillere[2]\v[0] = Hauteur_zone_cercle
        \Cremaillere[2]\c\x = \Cremaillere[2]\x2
        \Cremaillere[2]\c\y = \R_chanfrein * \Module
        \Cremaillere[2]\c\R = \R_chanfrein * \Module
        \Cremaillere[2]\c\Interieur = 1
        ; zone 4
        \Cremaillere[3]\x1 = \Cremaillere[2]\x2
        \Cremaillere[3]\x2 = \Cremaillere[3]\x1 + Largeur_zone_pied
        \Cremaillere[3]\v[0] = 0
        ; zone 5
        \Cremaillere[4]\x1 = \Cremaillere[3]\x2
        \Cremaillere[4]\x2 = \Cremaillere[4]\x1 + Largeur_zone_cercle
        \Cremaillere[4]\c\x = \Cremaillere[4]\x1
        \Cremaillere[4]\c\y = \R_chanfrein * \Module
        \Cremaillere[4]\c\R = \R_chanfrein * \Module
        \Cremaillere[4]\c\Interieur = 1
        ; Zone 6
        \Cremaillere[5]\x1 = \Cremaillere[4]\x2
        \Cremaillere[5]\x2 = \Cremaillere[5]\x1 + Largeur_zone_inclinee
        \Cremaillere[5]\v[1] = 1/Sin(\Angle_pression * #PI / 180)
        \Cremaillere[5]\v[0] = Hauteur_zone_cercle - \Cremaillere[5]\v[1] * \Cremaillere[5]\x1
        ; Zone 7
        \Cremaillere[6]\x1 = \Cremaillere[5]\x2
        \Cremaillere[6]\x2 = \Pas
        \Cremaillere[6]\v[0] = \H_dent

        ;- Equation de l'outil
        Largeur_zone_pied.d = \Pas / 2 - 2 * \H_tete * \Module * Sin(\Angle_pression * #PI / 180)
        Largeur_zone_cercle.d = \R_chanfrein * \Module * Cos(\Angle_pression * #PI / 180)
        Hauteur_zone_cercle.d = \R_chanfrein * \Module * (1-Sin(\Angle_pression * #PI / 180))
        Largeur_zone_inclinee.d = (\H_dent - Hauteur_zone_cercle) * Sin(\Angle_pression * #PI / 180)
        Largeur_zone_tete.d = \Pas - Largeur_zone_pied - 2 * Largeur_zone_cercle - 2 * Largeur_zone_inclinee
        ; Zone 1
        \Outil[0]\x1 = 0
        \Outil[0]\x2 = Largeur_zone_tete / 2
        \Outil[0]\v[0] = \H_dent + (\H_pied - \H_tete) * \Module
        ; Zone 2
        \Outil[1]\x1 = \Outil[0]\x2
        \Outil[1]\x2 = \Outil[1]\x1 + Largeur_zone_cercle
        \Outil[1]\c\x = \Outil[1]\x1
        \Outil[1]\c\y = \H_dent + (\H_pied - \H_tete) * \Module - \R_chanfrein * \Module
        \Outil[1]\c\R = \R_chanfrein * \Module
        \Outil[1]\c\Exterieur = 1
        ; zone 3
        \Outil[2]\x1 = \Outil[1]\x2
        \Outil[2]\x2 = \Outil[2]\x1 + Largeur_zone_inclinee
        \Outil[2]\v[1] = -1/Sin(\Angle_pression * #PI / 180)
        \Outil[2]\v[0] = \H_dent + (\H_pied - \H_tete) * \Module - Hauteur_zone_cercle - \Outil[2]\v[1] * \Outil[2]\x1
        ; zone 4
        \Outil[3]\x1 = \Outil[2]\x2
        \Outil[3]\x2 = \Outil[3]\x1 + Largeur_zone_pied
        \Outil[3]\v[0] = (\H_pied - \H_tete) * \Module
        ; Zone 5
        \Outil[4]\x1 = \Outil[3]\x2
        \Outil[4]\x2 = \Outil[4]\x1 + Largeur_zone_inclinee
        \Outil[4]\v[1] = 1/Sin(\Angle_pression * #PI / 180)
        \Outil[4]\v[0] = (\H_pied - \H_tete) * \Module - \Outil[4]\v[1] * \Outil[4]\x1
        ; Zone 6
        \Outil[5]\x1 = \Outil[4]\x2
        \Outil[5]\x2 = \Outil[5]\x1 + Largeur_zone_cercle
        \Outil[5]\c\x = \Outil[5]\x2
        \Outil[5]\c\y = \H_dent + (\H_pied - \H_tete) * \Module - \R_chanfrein * \Module
        \Outil[5]\c\R = \R_chanfrein * \Module
        \Outil[5]\c\Exterieur = 1
        ; Zone 7
        \Outil[6]\x1 = \Outil[5]\x2
        \Outil[6]\x2 = \Pas
        \Outil[6]\v[0] = \H_dent + (\H_pied - \H_tete) * \Module

        ; CopyMemory(@\Cremaillere, @\Outil, SizeOf(Structure_Equation) * #Cremaillere_NbEquation)

        ; Reset de la taille de l'engrenage
        For x = 0 To #Engrenage_ResolutionDent - 1
          \Contour[x]\R = \D_tete / 2
          \Contour[x]\Angle = x * 2 * #PI / #Engrenage_ResolutionDent / \Z
        Next

      EndWith
    EndProcedure

    Procedure Engrenage_Diametre(*Calcul.Structure_Engrenage)
      With *Calcul
        If \Module > 0 And \Z > 0 And \Angle_pression > 0 And \D_pied > 0

          ;- Calcul des rayons avec l'angle par défaut
          For x = 0 To #Engrenage_ResolutionDent - 1
            \Contour[x]\Angle.d = x * 2 * #PI / #Engrenage_ResolutionDent / \Z
            x_reel.d = \D_primitif * \Contour[x]\Angle / 2

            While x_reel >= \Pas And \Pas > 0
              x_reel - \Pas
            Wend
            If x_reel < 0
              x_reel = 0
            EndIf
            For n = 0 To #Cremaillere_NbEquation - 1
              If x_reel >= \Outil[n]\x1 And x_reel < \Outil[n]\x2
                If \Outil[n]\c\R ; Cercle
                  y_reel.d = \Outil[n]\c\y + \Outil[n]\c\R * (\Outil[n]\c\Exterieur - \Outil[n]\c\Interieur) * Sin(ACos((x_reel - \Outil[n]\c\x) / (\R_chanfrein *\Module)))
                Else ; Courbe
                  CompilerIf #Equation_Degree = 1
                    y_reel.d = \Outil[n]\v[0] + \Outil[n]\v[1] * x_reel
                  CompilerElse
                    y_reel.d = \Outil[n]\v[0]
                    For nn = 1 To #Equation_Degree
                      y_reel.d + \Outil[n]\v[nn] * Pow(x_reel, nn)
                    Next
                  CompilerEndIf
                EndIf
                Break
              EndIf
            Next

            \Contour[x]\R =(\D_primitif / 2 + \H_pied * \Module) + \Deport * \Module - y_reel
            If \Contour[x]\R > \D_tete / 2 + \Deport * \Module
              \Contour[x]\R = \D_tete / 2 + \Deport * \Module
            EndIf
            If \Contour[x]\R < \D_pied / 2 + \Deport * \Module
              \Contour[x]\R = \D_pied / 2 + \Deport * \Module
            EndIf

            If \Contour[x]\Angle < #PI / \Z
              \Contour[x]\Zone = 1
            Else
              \Contour[x]\Zone = 2
            EndIf

          Next

          ;- Correction de l'angle

          ; Centre de l'engrenage
          x_reel.d = 0
          y_reel.d =(\D_primitif / 2 + \H_pied * \Module) + \Deport * \Module

          Correction.d = 1 / #Engrenage_ResolutionDent / \Z

          Rotation.d = #Engrenage_ResolutionDent * \Z / 4
          If Rotation < #Engrenage_ResolutionDent * 2
            Rotation = #Engrenage_ResolutionDent * 2
          EndIf

          For Z = -Rotation To Rotation

            Angle.d = Z * 2 * #PI / #Engrenage_ResolutionDent / \Z
            Avance.d = \D_primitif * Angle / 2

            For x = 0 To #Engrenage_ResolutionDent - 1
              If \Contour[x]\R

                Repeat

                  Angle_reel.d = \Contour[x]\Angle + Angle
                  x1_reel.d = x_reel + \Contour[x]\R * Sin(Angle_reel) - Avance
                  y1_reel.d = y_reel - \Contour[x]\R * Cos(Angle_reel)

                  While x1_reel < 0 And \Pas > 0
                    x1_reel + \Pas
                  Wend
                  While x1_reel >= \Pas And \Pas > 0
                    x1_reel - \Pas
                  Wend
                  For n = 0 To #Cremaillere_NbEquation - 1
                    If x1_reel >= \Outil[n]\x1 And x1_reel < \Outil[n]\x2
                      If \Outil[n]\c\R ; Cercle
                        y2_reel.d = \Outil[n]\c\y + \Outil[n]\c\R * (\Outil[n]\c\Exterieur - \Outil[n]\c\Interieur) * Sin(ACos((x1_reel - \Outil[n]\c\x) / (\R_chanfrein *\Module)))
                      Else ; Courbe
                        CompilerIf #Equation_Degree = 1
                          y2_reel.d = \Outil[n]\v[0] + \Outil[n]\v[1] * x1_reel
                        CompilerElse
                          y2_reel.d = \Outil[n]\v[0]
                          For nn = 1 To #Equation_Degree
                            y2_reel.d + \Outil[n]\v[nn] * Pow(x1_reel, nn)
                          Next
                        CompilerEndIf
                      EndIf
                      Break
                    EndIf
                  Next

                  If y1_reel < y2_reel

                    If \Contour[x]\Zone = 1
                      \Contour[x]\Angle + Correction
                      If \Contour[x]\Angle > #PI / \Z
                        \Contour[x]\R = 0
                      EndIf
                    Else
                      \Contour[x]\Angle - Correction
                      If \Contour[x]\Angle < #PI / \Z
                        \Contour[x]\R = 0
                      EndIf
                    EndIf

                  EndIf

                Until y1_reel >= y2_reel

              EndIf
            Next
          Next
        EndIf
      EndWith
    EndProcedure

    Procedure Engrenage_Dessin(Gadget, Image, *Calcul.Structure_Engrenage, Angle.d, Zoom.d = 0)

      LoadFont(1, "Tahoma", 9 * FiltreAA, #PB_Font_HighQuality)

      With *Calcul
        Largeur = GadgetWidth(Gadget) * FiltreAA
        Hauteur = GadgetHeight(Gadget) * FiltreAA
        Echelle.d =(2 * \Pas *(1 - Zoom) + \D_tete * Zoom) /(Largeur - 32 * FiltreAA)
        x0 = Largeur / 2
        y0 = Hauteur / 3 - \H_pied * \Module / Echelle

        ; De combien la crémaillère se déplace pour l'angle donné
        Avance.d = \D_primitif * Angle / 2

        CreateImage(Image, Largeur, Hauteur, 24)
        StartDrawing(ImageOutput(Image))
          DrawingMode(#PB_2DDrawing_AlphaBlend | #PB_2DDrawing_Transparent)
          Box(0, 0, Largeur, Hauteur, $FF000000)

          If \Module > 0 And \Z > 0 And \Angle_pression > 0 And \D_pied > 0

            If Dessin = 0 Or FiltreAA = 1
              ; Centre de l'engrenage
              x_reel.d = 0
              y_reel.d =(\D_primitif / 2 + \H_pied * \Module) + \Deport * \Module
              ; Dessin de l'engrenage
              Angle_reel.d = \Contour[0]\Angle + Angle
              x1_reel.d = x_reel + \Contour[0]\R * Sin(Angle_reel)
              y1_reel.d = y_reel - \Contour[0]\R * Cos(Angle_reel)
              For nn = 0 To \Z - 1
                For n = 1 To #Engrenage_ResolutionDent - 1
                  If \Contour[n]\R
                    Angle_reel.d = \Contour[n]\Angle + 2 * #PI * nn / \Z + Angle
                    x2_reel.d = x_reel + \Contour[n]\R * Sin(Angle_reel)
                    y2_reel.d = y_reel - \Contour[n]\R * Cos(Angle_reel)
                    ; Debug StrD(x2_reel, 4) + " / " + StrD(y2_reel, 4)
                    LineXY(x0 + x1_reel / Echelle, y0 + y1_reel / Echelle, x0 + x2_reel / Echelle, y0 + y2_reel / Echelle, #Engrenage_Couleur)
                    x1_reel = x2_reel
                    y1_reel = y2_reel
                  EndIf
                Next
              Next
              Angle_reel.d = \Contour[0]\Angle + Angle
              x2_reel.d = x_reel + \Contour[0]\R * Sin(Angle_reel)
              y2_reel.d = y_reel - \Contour[0]\R * Cos(Angle_reel)
              LineXY(x0 + x1_reel / Echelle, y0 + y1_reel / Echelle, x0 + x2_reel / Echelle, y0 + y2_reel / Echelle, #Engrenage_Couleur)
            EndIf

            If Dessin = 0 Or FiltreAA = 1
              ; Remplissage de l'engrenage
              If y0 + y_reel / Echelle > Hauteur
                y = Hauteur - 1
              Else
                y = y0 + y_reel / Echelle
              EndIf
              FillArea(x0, y, #Engrenage_Couleur, #Engrenage_Couleur)
            EndIf

            If Dessin = 0 Or FiltreAA = 1
              ; Dessin de la crémaillère et de l'outil
              For x = 0 To Largeur - 1
                x_reel.d =(x - x0) * Echelle - Avance
                While x_reel < 0 And \Pas > 0
                  x_reel + \Pas
                Wend
                While x_reel >= \Pas And \Pas > 0
                  x_reel - \Pas
                Wend

                ; Dessin de la crémaillère
                For n = 0 To #Cremaillere_NbEquation - 1
                  If x_reel >= \Cremaillere[n]\x1 And x_reel < \Cremaillere[n]\x2
                    If \Cremaillere[n]\c\R ; Cercle
                      y_reel = \Cremaillere[n]\c\y + \Cremaillere[n]\c\R * (\Cremaillere[n]\c\Exterieur - \Cremaillere[n]\c\Interieur) * Sin(ACos((x_reel - \Cremaillere[n]\c\x) / (\R_chanfrein *\Module)))
                    Else ; Courbe
                      CompilerIf #Equation_Degree = 1
                        y_reel.d = \Cremaillere[n]\v[0] + \Cremaillere[n]\v[1] * x_reel
                      CompilerElse
                        y_reel.d = \Cremaillere[n]\v[0]
                        For nn = 1 To #Equation_Degree
                          y_reel.d + \Cremaillere[n]\v[nn] * Pow(x_reel, nn)
                        Next
                      CompilerEndIf
                    EndIf
                    Break
                  EndIf
                Next
                y = y_reel / Echelle + y0
                LineXY(x, y, x, 0, #Cremaillere_Couleur)

                ; Dessin de l'outil d'usinage
                For n = 0 To #Cremaillere_NbEquation - 1
                  If x_reel >= \Outil[n]\x1 And x_reel < \Outil[n]\x2
                    If \Outil[n]\c\R ; Cercle
                      y_reel = \Outil[n]\c\y + \Outil[n]\c\R * (\Outil[n]\c\Exterieur - \Outil[n]\c\Interieur) * Sin(ACos((x_reel - \Outil[n]\c\x) / (\R_chanfrein *\Module)))
                    Else ; Courbe
                      CompilerIf #Equation_Degree = 1
                        y_reel.d = \Outil[n]\v[0] + \Outil[n]\v[1] * x_reel
                      CompilerElse
                        y_reel.d = \Outil[n]\v[0]
                        For nn = 1 To #Equation_Degree
                          y_reel.d + \Outil[n]\v[nn] * Pow(x_reel, nn)
                        Next
                      CompilerEndIf
                    EndIf
                    Break
                  EndIf
                Next
                y = y_reel / Echelle + y0
                LineXY(x, y, x, 0, #Cremaillere_Couleur)

              Next
            EndIf

            If Dessin = 0 Or FiltreAA = 1
              ; Centre de l'engrenage
              x_reel.d = 0
              y_reel.d =(\D_primitif / 2 + \H_pied * \Module) + \Deport * \Module
              ; Dessin du diametre de pied
              Circle(x0, y0 + y_reel / Echelle,(\D_pied / 2 + \Deport * \Module) / Echelle, #Engrenage_Diametre)
              ; Box(0, y0 +(2.5 * \Module) / Echelle - FiltreAA / 2, Largeur, FiltreAA, #Cremaillere_Hauteur)
              ; Dessin du diametre primitif
              Circle(x0, y0 + y_reel / Echelle,(\D_primitif / 2) / Echelle, #Engrenage_Diametre)
              Box(0, y0 +(\H_pied * \Module) / Echelle - FiltreAA / 2, Largeur, FiltreAA, #Cremaillere_Hauteur)
              Box(0, y0 +(\H_pied * \Module + \Deport * \Module) / Echelle - FiltreAA / 2, Largeur, FiltreAA, #Cremaillere_Hauteur)
              ; Dessin du diametre de tête
              Circle(x0, y0 + y_reel / Echelle,(\D_tete / 2 + \Deport * \Module) / Echelle, #Engrenage_Diametre)
              ; Box(0, y0 +(0.25 * \Module) / Echelle - FiltreAA / 2, Largeur, FiltreAA, #Cremaillere_Hauteur)
              ; pied de la crémaillère
              ; Box(0, y0 - FiltreAA / 2, Largeur, FiltreAA, #Cremaillere_Hauteur)
              ; Tête de la crémaillère
              ; Box(0, y0 +(2.25 * \Module) / Echelle - FiltreAA / 2, Largeur, FiltreAA, #Cremaillere_Hauteur)
              ; centre
              Box(x0 - FiltreAA / 2, 0, FiltreAA, Hauteur, #Cremaillere_Hauteur)
            EndIf

            If Dessin = 0 Or FiltreAA = 1
              ; Centre de l'engrenage
              x_reel.d = 0
              y_reel.d =(\H_pied * \Module - \D_primitif / 2) - \Deport * \Module
              ; Dessin de l'engrenage
              Angle_reel.d = -\Contour[0]\Angle + Angle + #PI / \Z
              x1_reel.d = x_reel + \Contour[0]\R * Sin(Angle_reel)
              y1_reel.d = y_reel + \Contour[0]\R * Cos(Angle_reel)
              For nn = 0 To \Z - 1
                For n = 1 To #Engrenage_ResolutionDent - 1
                  Angle_reel.d = \Contour[n]\Angle + 2 * #PI * nn / \Z + Angle + #PI / \Z
                  If \Contour[n]\R
                    x2_reel.d = x_reel + \Contour[n]\R * Sin(Angle_reel)
                    y2_reel.d = y_reel + \Contour[n]\R * Cos(Angle_reel)
                    ; Debug StrD(x2_reel, 4) + " / " + StrD(y2_reel, 4)
                    LineXY(x0 + x1_reel / Echelle, y0 + y1_reel / Echelle, x0 + x2_reel / Echelle, y0 + y2_reel / Echelle, #Engrenage2_Couleur)
                    x1_reel = x2_reel
                    y1_reel = y2_reel
                  EndIf
                Next
              Next
              Angle_reel.d = -\Contour[0]\Angle + Angle + #PI / \Z
              x2_reel.d = x_reel + \Contour[0]\R * Sin(Angle_reel)
              y2_reel.d = y_reel + \Contour[0]\R * Cos(Angle_reel)
              LineXY(x0 + x1_reel / Echelle, y0 + y1_reel / Echelle, x0 + x2_reel / Echelle, y0 + y2_reel / Echelle, #Engrenage2_Couleur)
            EndIf

            If Dessin = 0 Or FiltreAA = 1
              ; Dessin de l'échelle
              DrawingFont(FontID(1))
              Longueur.d = 1 / Echelle
              Texte.s = "1 mm"
              If TextWidth(Texte + "  ") > Longueur
                Longueur.d = 5 / Echelle
                Texte.s = "5 mm"
              EndIf
              If TextWidth(Texte + "  ") > Longueur
                Longueur.d = 10 / Echelle
                Texte.s = "1 cm"
              EndIf
              If TextWidth(Texte + "  ") > Longueur
                Longueur.d = 50 / Echelle
                Texte.s = "5 cm"
              EndIf
              If TextWidth(Texte + "  ") > Longueur
                Longueur.d = 100 / Echelle
                Texte.s = "1 dm"
              EndIf
              If TextWidth(Texte + "  ") > Longueur
                Longueur.d = 500 / Echelle
                Texte.s = "5 dm"
              EndIf
              If TextWidth(Texte + "  ") > Longueur
                Longueur.d = 1000 / Echelle
                Texte.s = "1 m"
              EndIf
              DrawText(x0 +(Longueur - TextWidth(Texte)) / 2, Hauteur - 16 * FiltreAA - TextHeight(Texte), Texte, $FFFFFFFF)
              Box(x0, Hauteur - 16 * FiltreAA, Longueur, FiltreAA, $FFFFFFFF)
              Box(x0, Hauteur - 16 * FiltreAA - Longueur, FiltreAA, Longueur, $FFFFFFFF)
            EndIf

          EndIf
        StopDrawing()
        If Dessin = 0 Or FiltreAA = 1
          If FiltreAA > 1
            ResizeImage(Image, Largeur / FiltreAA, Hauteur / FiltreAA, #PB_Image_Smooth)
          EndIf
          SetGadgetState(#G_Dessin, ImageID(0))
        EndIf

        FreeFont(1)

      EndWith
    EndProcedure

    Procedure Affichage(Parametre.i)

      Repeat

        While Dessin = 0 And Compteur < 50
          Delay(20)
          If FiltreAA = 1
            Compteur + 1
          EndIf
        Wend

        If Dessin > 0
          Dessin = 0
          FiltreAA = 1
          Affichage = 1
        EndIf
        If Compteur >= 50
          FiltreAA = 4
          Compteur = 0
          Affichage = 1
        EndIf

        If Affichage
          Affichage = 0

          Engrenage_Dessin(#G_Dessin, 0, @Engrenage, Dessin_Angle, Dessin_Zoom)

        EndIf

      Until Dessin < 0
      MessageRequester("oups", "fin")
    EndProcedure

    ; Création de la fenêtre et de la GadgetList
    If OpenWindow(0, 0, 0, 800, 600, "Taillage d'engrenage", #PB_Window_SystemMenu | #PB_Window_ScreenCentered | #PB_Window_MinimizeGadget) = 0
      End
    EndIf

    LoadFont(0, "Tahoma", 9, #PB_Font_HighQuality)
    SetGadgetFont(#PB_Default, FontID(0))

    Engrenage\Module = 1
    Engrenage\Z = 15
    Engrenage\Angle_pression = 20
    Engrenage\H_tete = 1
    Engrenage\H_pied = 1.25
    Engrenage\R_chanfrein = 0.38
    Engrenage_Calcul(@Engrenage)

    x = 4
    y = 4
    Largeur = 200 - 8
    PanelGadget(#G_Onglet, 4, 4, Largeur, 600 - 8 - 96 - 8)
    AddGadgetItem(#G_Onglet, -1, "Paramètres")
    Largeur2 = GetGadgetAttribute(#G_Onglet, #PB_Panel_ItemWidth) - 8
    x2 = 4
    y2 = 4
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Module")
    y2 + 16
    StringGadget(#G_Module, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\Module))
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Z (Nombre de dents)")
    y2 + 16
    StringGadget(#G_Z, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\Z))
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Angle de pression (en °)")
    y2 + 16
    StringGadget(#G_Angle_Pression, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\Angle_pression))
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Déport (* module)")
    y2 + 16
    StringGadget(#G_Deport, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\Deport))
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Diamètre primitif")
    y2 + 16
    StringGadget(#G_D_primitif, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\D_primitif), #PB_String_ReadOnly)
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Diamètre de tête")
    y2 + 16
    StringGadget(#G_D_tete, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\D_tete + 2 * Engrenage\Deport * Engrenage\Module), #PB_String_ReadOnly)
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Diamètre de pied")
    y2 + 16
    StringGadget(#G_D_pied, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\D_pied + 2 * Engrenage\Deport * Engrenage\Module), #PB_String_ReadOnly)
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Hauteur de dent")
    y2 + 16
    StringGadget(#G_H_dent, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\H_dent), #PB_String_ReadOnly)
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "Pas")
    y2 + 16
    StringGadget(#G_Pas, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\Pas), #PB_String_ReadOnly)
    y2 + 24
    y2 + 8

    AddGadgetItem(#G_Onglet, -1, "Norme")
    x2 = 4
    y2 = 4
    TextGadget(#PB_Any, x2, y2, Largeur2, 32, "Les paramètres suivants sont définis par la norme.")
    y2 + 32
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "H tête (* Module)")
    y2 + 16
    StringGadget(#G_H_tete, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\H_tete))
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "H pied (* Module)")
    y2 + 16
    StringGadget(#G_H_pied, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\H_pied))
    y2 + 24
    y2 + 8
    TextGadget(#PB_Any, x2, y2, Largeur2, 16, "R chanfrein (* Module)")
    y2 + 16
    StringGadget(#G_R_chanfrein, x2, y2, Largeur2, 24, AfficheValeur(Engrenage\R_chanfrein))
    y2 + 24
    y2 + 8

    CloseGadgetList()
    y + GadgetHeight(#G_Onglet)
    y + 8

    TextGadget(#PB_Any, x, y, Largeur, 16, "Zoom d'affichage")
    y + 16
    TrackBarGadget(#G_Zoom, x, y, Largeur, 32, 0, 10, #PB_TrackBar_Ticks)
    Dessin_Zoom.d = 0
    y + 32
    TextGadget(#PB_Any, x, y, Largeur, 16, "Rotation de l'engrenage")
    y + 16
    TrackBarGadget(#G_Angle, x, y, Largeur, 32, 0, 72)
    Dessin_Angle.d = 0
    y + 32

    CreateImage(0, 600 - 8, 600 - 8, 24)
    ImageGadget(#G_Dessin, 204, 4, ImageWidth(0), ImageHeight(0), ImageID(0))

    Engrenage_Diametre(@Engrenage)
    Engrenage_Dessin(#G_Dessin, 0, @Engrenage, 0)

    Dessin = 1
    Thread = CreateThread(@Affichage(), 0)

    Repeat
      Event = WaitWindowEvent()

      Select Event
        Case #PB_Event_Gadget
          Select EventGadget() ; Gadgets
            Case #G_Module, #G_Z, #G_Angle_Pression, #G_Deport, #G_H_tete, #G_H_pied, #G_R_chanfrein
              If EventType() = #PB_EventType_Change
                ; ^paramètres
                Engrenage\Module = ValD(GetGadgetText(#G_Module))
                Engrenage\Z = ValD(GetGadgetText(#G_Z))
                Engrenage\Angle_pression = ValD(GetGadgetText(#G_Angle_Pression))
                Engrenage\Deport = ValD(GetGadgetText(#G_Deport))
                ; Norme
                Engrenage\H_tete = ValD(GetGadgetText(#G_H_tete))
                Engrenage\H_pied = ValD(GetGadgetText(#G_H_pied))
                Engrenage\R_chanfrein = ValD(GetGadgetText(#G_R_chanfrein))

                Engrenage_Calcul(@Engrenage)
                Engrenage_Diametre(@Engrenage)
                Dessin + 1
                ; Affichage des résultats
                SetGadgetText(#G_D_primitif, AfficheValeur(Engrenage\D_primitif))
                SetGadgetText(#G_D_tete, AfficheValeur(Engrenage\D_tete + 2 * Engrenage\Deport * Engrenage\Module))
                SetGadgetText(#G_D_pied, AfficheValeur(Engrenage\D_pied + 2 * Engrenage\Deport * Engrenage\Module))
                SetGadgetText(#G_H_dent, AfficheValeur(Engrenage\H_dent))
                SetGadgetText(#G_Pas, AfficheValeur(Engrenage\Pas))
              EndIf
            Case #G_Zoom
              Dessin_Zoom = GetGadgetState(#G_Zoom) / 10
              Dessin + 1
            Case #G_Angle
              Dessin_Angle.d = GetGadgetState(#G_Angle) * 2 * #PI /(36 * Engrenage\Z)
              Dessin + 1
          EndSelect
      EndSelect

    Until Event = #PB_Event_CloseWindow

Mis à jour le 7 novembre 2010 par Le Soldat Inconnu
Création d'une jauge entièrement paramétrable

Un aperçu du résultat, le programme permet de faire varier la forme de la jauge, la position de l'aiguille, etc.

Sélectionnez

    Procedure.d MaxD(A.d, B.d)
      If A > B
        ProcedureReturn A
      EndIf
      ProcedureReturn B
    EndProcedure

    Procedure MinI(A, B)
      If A < B
        ProcedureReturn A
      EndIf
      ProcedureReturn B
    EndProcedure

    Procedure DrawTextCentered(x, y, T.s, FrontColor, BackColor)
      x = x - TextWidth(T)/2
      y = y - TextHeight("Wg")/2
      DrawText(x, y, T, FrontColor, BackColor)
    EndProcedure

    Macro GaugeValueType
      i
    EndMacro

    Prototype SGauge_PaintProto(*Gauge, Image)

    Structure SGauge
      X.i
      Y.i
      W.i
      H.i
      Min.GaugeValueType
      Max.GaugeValueType
      BigStep.GaugeValueType    ; A text is drawn for every BigStep
      SmallStep.GaugeValueType  ; A nub is drawn for every SmallStep
      Value.i
      Text.s
      SubText.s
      Gadget.i
      ; Style:
      SectorDegrees.i
      InnerCircleRadius.i
      BgColor.i
      WheelColor.i
      WheelBgColor.i
      TextColor.i
      SubTextColor.i
      HandColor.i
      WheelFont.i
      TextFont.i
      SubTextFont.i
      ; Style override:
      PaintBackground.SGauge_PaintProto
      PaintWheel.SGauge_PaintProto
      PaintDescription.SGauge_PaintProto
      PaintHand.SGauge_PaintProto
      ; Repaint cache (set to 1 after changing style override)
      ; (The hand is always repainted)
      BgNeedRepaint.i
      WheelNeedRepaint.i
      DescriptionNeedRepaint.i
      ; Image cache (don't touch)
      BgImg.i
      WheelImg.i
      DescriptionImg.i
      ComposedImg.i
    EndStructure

    ; Default paint functions
    Procedure SGauge_PaintBackground(*G.SGauge, Image)
      DrawingMode(#PB_2DDrawing_AllChannels)
      Box(0, 0, *G\w, *g\H, *G\BgColor)
      DrawingMode(#PB_2DDrawing_AllChannels | #PB_2DDrawing_Outlined)
      Box(0, 0, *G\w, *g\H, RGBA(0, 0, 0, 32))
    EndProcedure

    Procedure SGauge_PaintWheel(*G.SGauge, Image)
      With *G
        StartDegree.i = 0 + ((360-\SectorDegrees)/2)
        wpx = \W / 33
        wpx2 = wpx/4.*3-1
        centerX = \w/2
        centerY = \H/2
        r = MinI(centerX, centerY) - TextWidth("12345")
        SmallStepDegrees.d  = \SmallStep / \Max * \SectorDegrees
        BigStepDegrees.d    = \BigStep / \Max * \SectorDegrees
        DrawingMode(#PB_2DDrawing_AllChannels)
        For I = 0 To \SectorDegrees
          x = centerX + Sin(Radian(StartDegree+I))*r
          y = centerY + Cos(Radian(StartDegree+I))*r
          Circle(x, y, wpx, \WheelColor)
        Next
        DrawingMode(#PB_2DDrawing_AllChannels)
        For I = 0 To \SectorDegrees
          x = centerX + Sin(Radian(StartDegree+I))*r
          y = centerY + Cos(Radian(StartDegree+I))*r
          Circle(x, y, wpx2, \WheelBgColor)
        Next
        dI.d = 0
        While dI <= \SectorDegrees
          x1 = centerX + Sin(Radian(StartDegree+dI))*(r-wpx2)
          y1 = centerY + Cos(Radian(StartDegree+dI))*(r-wpx2)
          x2 = centerX + Sin(Radian(StartDegree+dI))*(r-wpx2/2)
          y2 = centerY + Cos(Radian(StartDegree+dI))*(r-wpx2/2)
          LineXY(x1, y1, x2, y2, \WheelColor)
          dI + SmallStepDegrees
        Wend
        dI = 0
        While dI <= \SectorDegrees + 1 ;?!
          x1 = centerX + Sin(Radian(StartDegree+dI))*(r-wpx)
          y1 = centerY + Cos(Radian(StartDegree+dI))*(r-wpx)
          x2 = centerX + Sin(Radian(StartDegree+dI))*(r+wpx)
          y2 = centerY + Cos(Radian(StartDegree+dI))*(r+wpx)
          LineXY(x1, y1, x2, y2, \WheelColor)
          dI + BigStepDegrees
        Wend
        DrawingMode(#PB_2DDrawing_AlphaBlend | #PB_2DDrawing_Transparent)
        DrawingFont(FontID(\WheelFont))
        dI = 0
        I = 0
        While dI <= \SectorDegrees+1 ; not sure why that is needed
          T.s = Str(\Max-I)
          x = centerX + Sin(Radian(StartDegree+dI))*(r+wpx*3)
          y = centerY + Cos(Radian(StartDegree+dI))*(r+wpx*3)
          DrawTextCentered(x, y, T, RGBA(0, 0, 0, 255), RGBA(0, 0, 0, 0))
          dI + BigStepDegrees
          I + \BigStep
        Wend
      EndWith
    EndProcedure

    Procedure SGauge_PaintDescription(*G.SGauge, Image)
      With *G
        DrawingMode(#PB_2DDrawing_AlphaBlend | #PB_2DDrawing_Transparent)
        DrawingFont(FontID(\TextFont))
        x = 0.5 * \w
        y = 0.8 * \h
        DrawTextCentered(x, y, \Text, \TextColor, 0)
        y + TextHeight("Wg")
        DrawingFont(FontID(\SubTextFont))
        DrawTextCentered(x, y, \SubText, \SubTextColor, 0)
      EndWith
    EndProcedure

    Procedure SGauge_PaintHand(*G.SGauge, Image)
      With *G
        StartDegree.i = 0 + ((360-\SectorDegrees)/2)

        DrawVal = \Max - \Value
        DirDegrees.d = StartDegree + DrawVal / \Max * \SectorDegrees
        centerX = \W / 2
        centerY = \H / 2
        DrawingFont(\WheelFont)
        r = MinI(centerX, centerY) - TextWidth("12345")
        tipX = centerX + Sin(Radian(DirDegrees)) * r
        tipY = centerY + Cos(Radian(DirDegrees)) * r
        innerx = centerX + Sin(Radian(DirDegrees)) * \InnerCircleRadius
        innery = centerY + Cos(Radian(DirDegrees)) * \InnerCircleRadius
        LineXY(innerx, innery, tipx, tipy, RGBA(255, 0, 0, 255))
        Circle(innerx, innery, 2, RGBA(255, 0, 0, 255))
      EndWith
    EndProcedure

    Procedure SoftFreeImage(Image)
      If Image
        FreeImage(Image)
      EndIf
    EndProcedure

    Procedure SoftFreeFont(Font)
      If Font
        FreeFont(Font)
      EndIf
    EndProcedure

    ; Set sane default settings for a gauge
    ; (except x and y which must be set manually unless already done)
    ; Better call this first, or your gauge won't show up
    Procedure Gauge_InitDefaults(*G.SGauge, X = #PB_Ignore, Y = #PB_Ignore, W = #PB_Ignore, H = #PB_Ignore)
      With *G
        If X <> #PB_Ignore
          \X = X
        EndIf
        If Y <> #PB_Ignore
          \Y = Y
        EndIf
        If W <> #PB_Ignore
          \W = W
        EndIf
        If H <> #PB_Ignore
          \H = H
        EndIf
        \Min = 0
        \Max = 100
        \BigStep = 10
        \SmallStep = 5
        \Value = 0
        \Text = "Value"
        \SubText = "in percent"
        \Gadget = -1
        \SectorDegrees = 270
        \InnerCircleRadius = 0
        \BgColor = RGBA(0, 0, 0, 0)
        \WheelColor = RGBA(62, 62, 128, 192)
        \WheelBgColor = RGBA(64, 64, 0, 32)
        \TextColor = RGBA(0, 0, 0, 255)
        \SubTextColor = RGBA(92, 92, 92, 255)
        \HandColor = RGBA(255, 255, 192, 255)
        SoftFreeFont(\WheelFont)
        SoftFreeFont(\TextFont)
        SoftFreeFont(\SubTextFont)
        \WheelFont.i = LoadFont(#PB_Any, "Tahoma", MaxD(7, 0.04*\W))
        \TextFont.i  = LoadFont(#PB_Any, "Tahoma", MaxD(8, 0.056*\W), #PB_Font_Bold)
        \SubTextFont.i  = LoadFont(#PB_Any, "Tahoma", MaxD(7, 0.04*\W))

        \PaintBackground  = @SGauge_PaintBackground()
        \PaintWheel       = @SGauge_PaintWheel()
        \PaintDescription = @SGauge_PaintDescription()
        \PaintHand        = @SGauge_PaintHand()

        \BgNeedRepaint.i = 1
        \WheelNeedRepaint.i = 1
        \DescriptionNeedRepaint.i = 1

        \BgImg = SoftFreeImage(\BgImg)
        \WheelImg = SoftFreeImage(\WheelImg)
        \DescriptionImg = SoftFreeImage(\DescriptionImg)
        \ComposedImg = SoftFreeImage(\ComposedImg)
      EndWith
    EndProcedure

    ; Called to redraw gauge
    Procedure Gauge_UpdateDisplay(*G.SGauge)
      With *G
        If \BgNeedRepaint
          SoftFreeImage(\BgImg)
          \BgImg = CreateImage(#PB_Any, \w, \H, 32 | #PB_Image_Transparent)
          StartDrawing(ImageOutput(\BgImg))
            \PaintBackground(*G, \BgImg)
          StopDrawing()
        EndIf
        If \WheelNeedRepaint
          SoftFreeImage(\WheelImg)
          \WheelImg= CreateImage(#PB_Any, \w, \h, 32 | #PB_Image_Transparent)
          StartDrawing(ImageOutput(\WheelImg))
            \PaintWheel(*G, \WheelImg)
          StopDrawing()
        EndIf
        If \DescriptionNeedRepaint
          SoftFreeImage(\DescriptionImg)
          \DescriptionImg= CreateImage(#PB_Any, \w, \h, 32 | #PB_Image_Transparent)
          StartDrawing(ImageOutput(\DescriptionImg))
            \PaintDescription(*G, \DescriptionImg)
          StopDrawing()
        EndIf
        SoftFreeImage(\ComposedImg)
        \ComposedImg = CreateImage(#PB_Any, \w, \h, 32 | #PB_Image_Transparent)
        StartDrawing(ImageOutput(\ComposedImg))
          DrawingMode(#PB_2DDrawing_AlphaBlend)
          DrawImage(ImageID(\BgImg), 0, 0)
          DrawImage(ImageID(\WheelImg), 0, 0)
          DrawImage(ImageID(\DescriptionImg), 0, 0)
          \PaintHand(*G, \ComposedImg)
        StopDrawing()
        If \Gadget = -1
          \Gadget = ImageGadget(#PB_Any, \x, \y, \w, \h, ImageID(\ComposedImg))
        Else
          ResizeGadget(\Gadget, \x, \y, #PB_Ignore, #PB_Ignore)
          SetGadgetState(\Gadget, ImageID(\ComposedImg))
        EndIf
      EndWith
    EndProcedure

    ; If changing some other setting than value, call this
    ; before Gauge_UpdateDisplay() or it won't be redrawn properly
    Procedure Gauge_SettingsChanged(*G.SGauge)
      With *G
        \BgNeedRepaint.i = 1
        \WheelNeedRepaint.i = 1
        \DescriptionNeedRepaint.i = 1
      EndWith
    EndProcedure

    ;- Example
    #W = 640
    #H = 384

    OpenWindow(0, 0, 0, #W, #H, "", #PB_Window_ScreenCentered | #PB_Window_SystemMenu | #PB_Window_SizeGadget | #PB_Window_MinimizeGadget | #PB_Window_MaximizeGadget)
    ; SpinGadget(0, 300, 10, 100, 22, 0, 100, #PB_Spin_Numeric)
    TrackBarGadget(0, 220, 10, 200, 22, 0, 100)
    SetGadgetState(0, 0)
    ; SpinGadget(1, 300, 40, 100, 22, 1, 360, #PB_Spin_Numeric)
    TrackBarGadget(1, 220, 40, 360, 22, 1, 360)
    SetGadgetState(1, 270)
    ;SpinGadget(2, 300, 70, 100, 22, 0, 80, #PB_Spin_Numeric)
    TrackBarGadget(2, 220, 70, 200, 22, 0, 40)
    SetGadgetState(2, 0)

    g.SGauge

    Gauge_InitDefaults(@G, 10, 10, 200, 200)
    Gauge_UpdateDisplay(@G)

    Repeat
      Select WaitWindowEvent()
        Case #PB_Event_Gadget
          Select EventGadget()
            Case 0: ; Change value
              g\Value = GetGadgetState(0)
              Gauge_UpdateDisplay(@g)
            Case 1: ; Change size in degrees
              g\SectorDegrees = GetGadgetState(1)
              Gauge_SettingsChanged(@G)
              Gauge_UpdateDisplay(@g)
            Case 2: ; Change hand origin radius
              g\InnerCircleRadius = GetGadgetState(2)
              Gauge_SettingsChanged(@G)
              Gauge_UpdateDisplay(@g)
          EndSelect
        Case #PB_Event_CloseWindow
          Break
      EndSelect
    ForEver

Créé le 18 février 2011 par Trond
Tiny visual designer (TVD)

Tiny Visual Designer (TVD) Version 0.94 est un mini designer visuel pour PureBasic.
L'image n'est pas très représentative de ce qu'il est possible de faire, dans la version 0.94 vous pouvez ajouter 10 types de gadgets :

- ButtonGadget
- CheckBoxGadget
- ComboBoxGadget
- EditorGadget
- Frame3DGadget
- ListIconGadget
- ListViewGadget
- OptionGadget
- StringGadget
- TextGadget

Cette version fonctionne aussi sous Linux (testé sur Ubuntu 10) mais donne des résultats différents de la version Windows.
- Les gadgets sont accessibles depuis le menu contextuel (popup)
- Chaque gadget est repositionnable et redimensionnable avec la souris ou bien en utilisant les raccourcis suivant.
Ctrl + Flèches pour repositionner les gadgets.
Alt + Flèches pour redimensionner les gadgets.

Créé le 3 avril 2011 par falsam

Téléchargez le zip

Version hors-ligne

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