Sources PureBasic
Sources PureBasicConsultez toutes les sources
Nombre d'auteurs : 41, nombre de sources : 88, dernière mise à jour : 13 août 2011
Sommaire→Applications
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
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
EndDataSectionCréé le 27 novembre 2008 par Denis
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
EndProcedureExemple 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
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
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
EndProcedureCréé le 3 décembre 2008 par Claude-OI
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_CloseWindowMis à jour le 7 novembre 2010 par Le Soldat Inconnu
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
ForEverCréé le 18 février 2011 par Trond
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