FORUM DE DISCUSSION SUR LE LANGAGE PANORAMIC

Développement d'applications avec le langage Panoramic
 
AccueilAccueil  FAQFAQ  RechercherRechercher  S'enregistrerS'enregistrer  MembresMembres  GroupesGroupes  Connexion  
Derniers sujets
» Problème de compilateur.
par Pedro Alvarez Hier à 20:01

» COMPILATEUR V 0.9 beta 8 du 18 aout 2017
par Pedro Alvarez Hier à 19:54

» Pb 17 (en analyse): ITEM_SELECT ne fonctionne pas
par Jack Jeu 17 Aoû 2017 - 19:26

» Compilateur FBPano
par Mike Jeu 17 Aoû 2017 - 13:52

» un nouveau editeur panobasic
par Jean Claude Jeu 17 Aoû 2017 - 10:18

» Le compilateur.
par Pedro Alvarez Jeu 17 Aoû 2017 - 8:36

» Pb 16 (en analyse): ON_CLOSE plante à l'exécution
par Jack Mer 16 Aoû 2017 - 20:00

» Pb 15 (en analyse): TIMER_ON plante à l'exécution
par Jack Mer 16 Aoû 2017 - 19:58

» KGF_dll - nouvelles versions
par Yannick Dim 13 Aoû 2017 - 17:35

» probleme d'outil
par Yannick Dim 13 Aoû 2017 - 17:32

» Carte de France des régions
par Yannick Sam 12 Aoû 2017 - 21:33

» Pb 14 (en analyse): PRINT_LOCATE plante à l'exécution
par Jack Ven 11 Aoû 2017 - 22:37

» Petit avertissement [Mots réservés]
par papydall Ven 11 Aoû 2017 - 13:45

» Distances sur plan
par JL35 Jeu 10 Aoû 2017 - 21:29

» Tracé : Triangle, Carrée, Dents de scie, Sinusoïde redressée
par papydall Jeu 10 Aoû 2017 - 14:52

Navigation
 Portail
 Index
 Membres
 Profil
 FAQ
 Rechercher
Rechercher
 
 

Résultats par :
 
Rechercher Recherche avancée
Août 2017
LunMarMerJeuVenSamDim
 123456
78910111213
14151617181920
21222324252627
28293031   
CalendrierCalendrier

Partagez | 
 

 Quelques SUBs, en vrac

Voir le sujet précédent Voir le sujet suivant Aller en bas 
Aller à la page : 1, 2, 3  Suivant
AuteurMessage
JL35



Nombre de messages : 5920
Localisation : 77
Date d'inscription : 29/11/2007

MessageSujet: Quelques SUBs, en vrac   Mar 15 Jan 2013 - 23:44

Quelques Subs extraites de ma bibliothèque perso.
J'ai voulu les rendre indépendantes du contexte, aussi, s'il y a un paramètre en retour, il est rendu systématiquement dans le clipboard, pour éviter à la Sub d'avoir à connaître une ou des variables du programme principal.
C'est à mon avis sans risque, le clipboard ne va pas être pollué entre deux instructions, entre le End_Sub et le moment où on récupère le paramètre.
C'est moins pratique s'il y a plusieurs paramètres à renvoyer, ils sont rendus séparés par des ';', ou bien par des retours-chariot/interligne, c'est facilement modifiable.
Ce sont des Subs toutes simples (il y en a que je n'ai pas mis, par exemple la manipulation d'images bmp), mais la bibliothèque ne demande qu'à s'étoffer !
Code:

' SUB_Bib.bas collection de SUBs
' Si résultats en retour, ils sont rendus dans des variables déclarées localement
' ------------------------------------------------------------------------------
' FONCTIONS PANORAMIC
' - Objets() définition d'un objet Panoramic
' FONCTIONS CHAINES ET TEXTES
' - InstrX() recherche d'une chaîne à partir d'un index donné
' - Rinstr() recherche d'une chaîne à partir de la fin
' - Compchain() comparaison de deux chaînes (<, = ou >)
' - Extract() extraction des éléments d'une chaîne avec séparateurs
' - TriAsc() Tri d'un fichier selon l'ordre Ascii strict
' - Replace() remplacer un mot par un autre dans une chaîne
' - Reverse() inverser une chaîne tête-bêche
' - Misfoc() formatage fichier à un nombre donné de caractères par ligne
' - Misfop() formatage fichier à un nombre donné de pixels par ligne
' FONCTIONS DISQUES/FICHIERS
' - Volumes() Liste des volumes monés
' - Codeco() Crypter/décrypter un fichier avec une clé donnée
' - File2String() lire un fichier quelconque dans une chaîne
' - String2File() écrire une chaîne dans un fichier
' FONCTIONS DATES
' - Qpap() calcul des quantièmes de Pâques, Ascension, Pentecôte
' - Dateserial() conversion d'une date en date série
' - Joursem() calcul du jour de la semaine
' - Jmq() calcul du quantième de l'année en fonction du jour et du mois
' - Qjm() calcul du jour et du mois en fonction du quantième de l'année
' FONCTIONS IMAGES
' - CreBmp() création d'une image Bmp
' - DimBmp() dimensions d'une image Bmp
' - BmpInfos() infos d'un fichier image Bmp
' - ImgInfos() infos d'un fichier image: dimensions et date
' - Jpg2Bmp() conversion d'une image Jpg en Bmp
' - Posxy() calcul du pointeur d'un bmp correspondant aux coordonnées données
' - RGB2Val() conversion de données RGB en valeur
' - Val2RGB() conversion d'une valeur en données RGB
' FONCTIONS MATHÉMATIQUES
' - VMKL()
' - CVL
' - Est_Divisible()
' FONCTIONS DIVERSES
' - Nomcourt() conversion d'un path long en path court (sans espaces)
' - Exprog() exécution d'un programme externe sans la fenêtre noire ms-dos
' ------------------------------------------------------------------------------

RGB2Val(255,255,255)
message str$(rs_cl%)
Val2RGB(16777215)
message str$(rs_cr%)+","+str$(rs_cg%)+","+str$(rs_cb%)
end
' =========================== FONCTIONS PANORAMIC ==============================
SUB Objets(obj$,No%,V%,T%,L%,W%,H%,P%)
' Définition d'un objet Panoramic:
' obj$= nom de l'objet, No% son numéro, V%=0 objet caché
' T%,L%,W%,H% Top,Left,Width,Height, P% <> 0 numéro du parent
DIM_LOCAL indx%
IF VARIABLE("T_obj$") = 0
  DIM T_obj$
  T_obj$="01SCENE3D;02BUTTON;03EDIT;04MEMO;05COMBO;06ALPHA;07FORM;08LIST;09PICTURE;"
  T_obj$=T_obj$+"10CHECK;11OPTION;12MAIN_MENU;13SUB_MENU;14SOUND;15MOVIE;16TRACKBAR;"
  T_obj$=T_obj$+"17OPEN_DIALOG;18SAVE_DIALOG;198SCROLL_BAR;20PROGRESS_BAR;21SPIN;"
  T_obj$=T_obj$+"22GRID;23CONTAINER;24;25;26DLIST;27SCENE2D;28TIMER;29;30;31;"
  T_obj$=T_obj$+"32CONTAINER_OPTION;33;34;35;36;37;38;39;40;41IMAGE;"
END_IF
indx% = INSTR(T_obj$,UPPER$(obj$)+";"): indx% = VAL(MID$(T_obj$,indx%-2,2))
SELECT indx%
    CASE 1: SCENE3D No%
    CASE 2: BUTTON No%
    CASE 3: EDIT No%
    CASE 4: MEMO No%
    CASE 5: COMBO No%
    CASE 6: ALPHA No%
    CASE 7: FORM No%
    CASE 8: LIST No%
    CASE 9: PICTURE No%
    CASE 10: CHECK No%
    CASE 11: OPTION No%
    CASE 12: MAIN_MENU No%
    CASE 13: SUB_MENU No%
    CASE 14: SOUND No%
    CASE 15: MOVIE No%
    CASE 16: TRACK_BAR No%
    CASE 17: OPEN_DIALOG No%
    CASE 18: SAVE_DIALOG No%
    CASE 19: SCROLL_BAR No%
    CASE 20: PROGRESS_BAR No%
    CASE 21: SPIN No%
    CASE 22: GRID No%
    CASE 23: CONTAINER No%
    CASE 26: DLIST No%
    CASE 27: SCENE2D No%
    CASE 28: TIMER No%
    CASE 32: CONTAINER_OPTION No%
    CASE 41: IMAGE No%
END_SELECT
IF T% > 0 THEN TOP No%,T%
IF L% > 0 THEN LEFT No%,L%
IF W% > 0 THEN WIDTH No%,W%
IF H% > 0 THEN HEIGHT No%,H%
IF P% > 0 THEN PARENT No%,P%
IF V% = 0 THEN HIDE No%
END_SUB
' ------------------------------------------------------------------------------
' ====================== FONCTIONS CHAINES ET TEXTES ===========================
SUB InstrX(ch$,sq$,xd%)
' recherche de sq$ dans ch$ à partir de xd% (~Instr indexé) -> rs_k%
DIM_LOCAL a_instrx$
IF VARIABLE("rs_k%") = 0 THEN DIM rs_k%
a_instrx$ = MID$(ch$, xd%, LEN(ch$)-xd%+1)
rs_k%% = INSTR(a_instrx$, sq$)
IF rs_k%% > 0 THEN rs_k%% = rs_k%+xd%-1
END_SUB
' ------------------------------------------------------------------------------
SUB Rinstr(ch$,sq$)
' recherche de sq$ dans ch$ à partir de la fin (~Instr inversé) -> rs_k%
IF VARIABLE("rs_k%") = 0 THEN DIM rs_k%
FOR rs_k% = LEN(ch$)-LEN(sq$)+1 TO 1 STEP -1
    IF MID$(ch$, rs_k%, LEN(sq$)) = sq$ THEN EXIT_FOR
NEXT rs_k%
END_SUB
' ------------------------------------------------------------------------------
SUB Compchain(ch1$,ch2$)
' comparaison de deux chaînes ascii (Tri ascii strict)
' résultat: =-1 si ch1$<ch2$, =0 si ch1$=ch2$, =1 si ch1$>ch2$ -> rs_di%
DIM_LOCAL i_comp%, i_vl1%, i_vl2%
IF VARIABLE("rs_di%") = 0 THEN DIM rs_di%
rs_di% = 0
FOR i_comp% = 1 TO LEN(ch1$)
    i_vl1% = ASC(MID$(ch1$,i_comp%,1))
    i_vl2% = ASC(MID$(ch2$,i_comp%,1))
    IF i_vl1% < i_vl2% THEN rs_di% = -1: EXIT_FOR
    IF i_vl1% > i_vl2% THEN rs_di% = 1: EXIT_FOR
NEXT i_comp%
IF rs_di% = 0 AND LEN(ch2$) > LEN(ch1$) THEN rs_di% = -1
END_SUB
' ------------------------------------------------------------------------------
SUB Extract(ch$, sep$)
' extraire les éléments d'une chaîne avec séparateurs sep$ (par exemple ;)
' résultats dans rs_el$(), nombre d'éléments dans rs_nx%
IF VARIABLE("rs_el$") = 0 THEN DIM rs_el$(50)
IF VARIABLE("rs_nx%") = 0 THEN DIM rs_nx%
DIM_LOCAL a_ex$, r_ex$, i_ex%
rs_nx% = 0
a_ex$ = ch$: r_ex$ = "": i_ex% = INSTR(a_ex$, sep$)
WHILE i_ex% > 0
    rs_nx% = rs_nx%+1: rs_el$(rs_nx%) = LEFT$(a_ex$, i_ex%-1)
    a_ex$ = MID$(a_ex$, i_ex%+LEN(sep$), LEN(a_ex$)-i_ex%)
    i_ex% = INSTR(a_ex$, sep$)
END_WHILE
rs_nx% = rs_nx%+1: rs_el$(rs_nx%) = a_ex$
END_SUB
' ------------------------------------------------------------------------------
SUB TriAsc(f1$,f2$)
' Tri de f1$ dans f2$ en respectant la stricte valeur Ascii des caractères
' (NB: f2$ peut être égal à f1$)
DIM_LOCAL Tr_ob%, Tr_a$, Tr_h$, Tr_i%, Tr_j%
Tr_ob% = 10000
WHILE OBJECT_EXISTS(Tr_ob%) = 1: Tr_ob% = Tr_ob% + 1: END_WHILE
DLIST Tr_ob%: DLIST Tr_ob%+1
FILE_LOAD Tr_ob%, f1$
FOR Tr_i% = 1 TO COUNT(Tr_ob%)
    Tr_a$ = ITEM_READ$(Tr_ob%, Tr_i%): Tr_h$ = ""
    FOR Tr_j% = 1 TO LEN(Tr_a$)
        Tr_h$ = Tr_h$ + RIGHT$("0"+HEX$(ASC(MID$(Tr_a$, Tr_j%, 1))), 2)
    NEXT Tr_j%
    ITEM_ADD Tr_ob%+1, Tr_h$
NEXT Tr_i%
SORT Tr_ob%+1: CLEAR Tr_ob%
FOR Tr_i% = 1 TO COUNT(Tr_ob%+1)
    Tr_h$ = ITEM_READ$(Tr_ob%+1, Tr_i%): Tr_a$ = ""
    FOR Tr_j% = 1 TO LEN(Tr_h$) STEP 2
        Tr_a$ = Tr_a$ + CHR$(HEX(MID$(Tr_h$, Tr_j%, 2)))
    NEXT Tr_j%
    ITEM_ADD Tr_ob%, Tr_a$
NEXT Tr_i%
FILE_SAVE Tr_ob%, f2$
DELETE Tr_ob%: DELETE Tr_ob%+1
END_SUB
' ------------------------------------------------------------------------------
SUB Replace(a$,b$,c$)
' Remplace dans a$ les occurences de b$ par c$ (tailles différentes éventuelles)
' chaîne résultante dans rs_ch$
DIM_LOCAL rm_k%, rm_u%, ff_a$
IF VARIABLE("rs_ch$") = 0 THEN DIM rs_ch$
rs_ch$ = a$: rm_k% = INSTR(rs_ch$, b$)
WHILE rm_k% > 0
    rs_ch$ = LEFT$(rs_ch$, rm_k%-1) + c$ + MID$(rs_ch$, rm_k%+LEN(b$), 500): ' nouvelle chaîne
    rm_u% = rm_k%+LEN(c$): ff_a$ = MID$(rs_ch$, rm_u%, 500)
    rm_k% = INSTR(ff_a$, b$)
    IF rm_k% = 0 THEN EXIT_WHILE
    rm_k% = rm_k%+rm_u%-1
END_WHILE
END_SUB
' ______________________________________________________________________________
SUB Reverse(a$)
' Inverse une chaîne de caractère, résultat dans rs_rv$
DIM_LOCAL rv_i%
IF VARIABLE("rs_rv$") = 0 THEN DIM rs_rv$
rs_rv$ = ""
FOR rv_i% = LEN(a$) TO 1 STEP -1
    rs_rv$ = rs_rv$ + MID$(a$, rv_i%, 1)
NEXT rv_i%
END_SUB
' ------------------------------------------------------------------------------
SUB Misfoc(f1$,f2$,ll%)
' Mise en forme d'un fichier texte en ajustant la longueur des lignes à une
' valeur ll% caractères donnée (coupure à l'espace le plus proche)
DIM_LOCAL m_a$, m_ra$, m_i%, m_k%
FILE_OPEN_READ 8, f1$: FILE_OPEN_WRITE 9, f2$
m_ra$ = ""
WHILE FILE_EOF(8) = 0
    FILE_READLN 8,  m_a$
    IF LEFT$(m_a$, 1) = " " OR LEFT$(m_a$, 1) = CHR$(9): ' début de pararaphe
        IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$: m_ra$ = ""
        WHILE LEN(m_a$) > ll%
            FOR m_i% = ll%+1 TO 1 STEP -1
                IF MID$(m_a$, m_i%, 1) = " " THEN EXIT_FOR
            NEXT m_i%
            FILE_WRITELN 9, RTRIM$(LEFT$(m_a$,m_i%-1)): m_a$ = MID$(m_a$,m_i%+1,500)
        END_WHILE
    END_IF
    IF m_ra$ <> "" THEN m_a$ = m_ra$ + " " + m_a$ : m_ra$ = ""
    WHILE LEN(m_a$) > ll%
        FOR m_i% = ll%+1 TO 1 STEP -1
            IF MID$(m_a$, m_i%, 1) = " " THEN EXIT_FOR
        NEXT m_i%
        FILE_WRITELN 9, RTRIM$(LEFT$(m_a$,m_i%-1)): m_a$ = MID$(m_a$,m_i%+1,500)
    END_WHILE
    m_ra$ = RTRIM$(m_a$)
END_WHILE
IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$
FILE_CLOSE 8: FILE_CLOSE 9
END_SUB
' ------------------------------------------------------------------------------
SUB Misfop(f1$,f2$,lp%,ob%)
' Mise en forme d'un fichier texte en ajustant la longueur des lignes à une
' valeur lp% pixels donnée (coupure à l'espace le plus proche), pour affichage
' dans l'objet ob%
PRINT_TARGET_IS ob%
DIM_LOCAL m_a$, m_ra$, m_i%, m_k%, m_ll%
FILE_OPEN_READ 8, f1$: FILE_OPEN_WRITE 9, f2$
m_ra$ = ""
WHILE FILE_EOF(8) = 0
    FILE_READLN 8,  m_a$
    IF LEFT$(m_a$, 1) = " " OR LEFT$(m_a$, 1) = CHR$(9): ' début de pararaphe
        IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$: m_ra$ = ""
        WHILE TEXT_WIDTH(m_a$,ob%) > lp%
            FOR m_i% = LEN(m_a$) TO 1 STEP -1
                IF MID$(m_a$, m_i%, 1) = " " THEN EXIT_FOR
            NEXT m_i%
            m_ra$ = MID$(m_a$, i%+1, 500): m_a$ = RTRIM$(LEFT$(m_a$, m_i%-1))
        END_WHILE
    END_IF
    IF m_ra$ <> "" THEN m_a$ = rtrim$(m_ra$) + " " + ltrim$(m_a$): m_ra$ = ""
    IF TEXT_WIDTH(m_a$,ob%) < lp%
        m_ra$ = m_a$
    ELSE
        m_i% = LEN(m_a$)
        WHILE TEXT_WIDTH(LEFT$(m_a$, m_i%),ob%) > lp%
            FOR m_k% = m_i%-1 TO 1 STEP -1
                IF MID$(m_a$, m_k%, 1) = " " THEN EXIT_FOR
            NEXT m_k%
            m_i% = m_k%-1
        END_WHILE
        FILE_WRITELN 9, LEFT$(m_a$, m_i%)
        m_ra$ = LTRIM$(MID$(m_a$, m_i%+1, 500))
    END_IF
END_WHILE
IF m_ra$ <> "" THEN FILE_WRITELN 9, m_ra$
FILE_CLOSE 8: FILE_CLOSE 9
END_SUB
' ______________________________________________________________________________
' ======================== FONCTIONS DISQUES/FICHIERS ==========================
SUB Volumes()
' Liste des volumes montés, avec leur nom, séparés par ';' -> volu$
DIM_LOCAL vol_scr$, vol_fv$, vol_a$, v_q$
IF VARIABLE("volu$") = 0 THEN DIM volu$
vol_scr$ = "C:\Temp\Vol.vbs": ' script exécutable créé
vol_fv$ = "C:\Temp\Volumes.txt"
v_q$ = CHR$(34)
DATA "VOLUMES"
DATA "Dim net, shell, computer, fso, WMISet,oWinnt"
DATA "Dim fst, fichier"
DATA "Set fst    = CreateObject("+v_q$+"Scripting.FileSystemObject"+v_q$+")"
DATA "Set fichier = fst.CreateTextFile("+v_q$+"C:\Temp\Volumes.txt"+v_q$+")"
DATA "Set net    = Wscript.CreateObject("+v_q$+"WScript.Network"+v_q$+")"
DATA "Set shell  = WScript.CreateObject("+v_q$+"WScript.Shell"+v_q$+")"
DATA "Set fso    = WScript.CreateObject("+v_q$+"Scripting.FileSystemObject"+v_q$+")"
DATA "computer = net.ComputerName"
DATA "set WMISet = GetObject("+v_q$+"winmgmts:{impersonationLevel=impersonate}!//"+v_q$+" & Computer).ExecQuery _"
DATA "("+v_q$+"SELECT * FROM Win32_LogicalDisk"+v_q$+")"
DATA "Message = "+v_q$+""+v_q$+" "
DATA "For each Disk in WMISet"
DATA "    Capa = Disk.Size"
DATA "    If Capa <> "+v_q$+""+v_q$+" Then"
DATA "        Name = Disk.VolumeName"
DATA "        If Message <> "+v_q$+""+v_q$+" Then Message = Message & VBCRLF"
DATA "        Message = Message & Disk.Name & "+v_q$+" "+v_q$+" & Name"
DATA "    End if"
DATA "Next"
DATA "fichier.WriteLine (Message)"
DATA "fichier.Close"
DATA "wscript.quit"
DATA "f"
FILE_OPEN_WRITE 1, vol_scr$
RESTORE: READ vol_a$: WHILE vol_a$ <> "VOLUMES": READ vol_a$: END_WHILE
READ vol_a$: WHILE vol_a$ <> "f": FILE_WRITELN 1, vol_a$: READ vol_a$: END_WHILE
FILE_CLOSE 1
EXECUTE_WAIT "Wscript.exe " + vol_scr$
FILE_OPEN_READ 9,vol_fv$: volu$ = ""
WHILE FILE_EOF(9) = 0: FILE_READLN 9, vol_a$: volu$=volu$+vol_a$+";": END_WHILE
FILE_CLOSE 9: FILE_DELETE vol_fv$
volu$ = LEFT$(volu$,LEN(volu$)-1)
END_SUB
' ______________________________________________________________________________
SUB Codeco(fi$,fo$,cle$)
' Cryptage/Décryptage d'un fichier quelconque fi$ dans fo$, avec la clé cle$
DIM_LOCAL cd_i%, cd_x%, cd_va%, cd_vc%
FILEBIN_OPEN_READ 8, fi$: FILEBIN_OPEN_WRITE 9, fo$
cd_x% = 1
FOR cd_i% = 1 TO FILEBIN_SIZE(8)
    FILEBIN_READ 8, cd_va%
    cd_vc% = BIN_XOR(cd_va%,  ASC(MID$(cle$, cd_x%, 1)))
    FILEBIN_WRITE 9, cd_vc%
    cd_x% = cd_x% + 1: IF cd_x% > LEN(cle$) THEN cd_x% = 1
NEXT cd_i%
FILEBIN_CLOSE 8: FILEBIN_CLOSE 9
END_SUB
' ______________________________________________________________________________
SUB File2String(f$)
' Copie d'un fichier entier quelconque f$ dans une chaîne -> f_ch$
DIM_LOCAL f_sz%, f_ix%, f_va%
IF VARIABLE("f_ch$") = 0 THEN DIM f_ch$
f_ch$ = ""
FILEBIN_OPEN_READ 9, f$: f_sz% = FILEBIN_SIZE(9)
DIM_LOCAL f_v%(f_sz%)
FOR f_ix% = 1 TO f_sz%
    FILEBIN_READ 9, f_va%: f_ch$ = f_ch$ + CHR$(f_va%)
NEXT f_ix%
FILEBIN_CLOSE 9
END_SUB
' ______________________________________________________________________________
SUB String2File(a$,f$)
' Ecriture d'une chaîne complète a$ dans un fichier binaire f$
DIM_LOCAL f_sz%, f_ix%, f_va%
FILEBIN_OPEN_WRITE 9, f$
FOR f_ix% = 1 TO LEN(a$)
    FILEBIN_WRITE 9, ASC(MID$(a$, f_ix%, 1)
NEXT f_ix%
FILEBIN_CLOSE 9
END_SUB
' ______________________________________________________________________________
' ========================== FONCTIONS DATES ===================================
SUB QPaques(Annee)
' Quantièmes de Pâques, Ascension, Pentecôte en fonction de Annee
' Résultats dans rs_qpa, rs_qas, rs_qpe
DIM_LOCAL qp_a,qp_b,qp_c,qp_d,qp_e,qp_f,qp_g,qp_h,qp_i,qp_k,qp_l,qp_m
DIM_LOCAL qp_bi,qp_ci,qp_cj
IF VARIABLE("rs_qpa") = 0 THEN DIM rs_qpa
IF VARIABLE("rs_qas") = 0 THEN DIM rs_qas
IF VARIABLE("rs_qpe") = 0 THEN DIM rs_qpe
qp_a = 19*FRAC(Annee/19)
qp_b = INT(Annee/100)
qp_c = 100*FRAC(Annee/100)
qp_ci = 4*FRAC(Annee/4)
qp_cj = 400*FRAC(Annee/400)
qp_bi = 0: IF qp_ci = 0 AND (qp_c <> 0 OR qp_cj = 0) THEN qp_bi = 1
qp_d = INT(qp_b/4)
qp_e = 4*FRAC(qp_b/4)
qp_f = INT((qp_b + 8) / 25)
qp_g = INT((qp_b - qp_f + 1) / 3)
qp_h = 30*FRAC((19 * qp_a + qp_b - qp_d - qp_g + 15)/30)
qp_i = INT(qp_c/4)
qp_k = 4*FRAC(qp_c/4)
qp_l = 7*FRAC((32 + 2 * qp_e + 2 * qp_i - qp_h - qp_k)/7)
qp_m = INT((qp_a + 11 * qp_h + 22 * qp_l) / 451)
rs_qpa = qp_h + qp_l - 7 * qp_m + 81 + qp_bi
rs_qpa = INT(rs_qpa + .1)
rs_qas = rs_qpa + 39: rs_qpe = rs_qpa + 49
END_SUB
' ------------------------------------------------------------------------------
SUB DateSerial(Annee,Mois,Jour)
' Date série en fonction de Annee, Mois, Jour -> rs_ds%
' (pour calculer par exemple le nombre de jours entre deux dates)
DIM_LOCAL ds_res,ds_bi
IF VARIABLE("rs_ds%") = 0 THEN DIM rs_ds%
SELECT Mois
    CASE 1: ds_res = 0
    CASE 2: ds_res = 31
    CASE 3: ds_res = 59
    CASE 4: ds_res = 90
    CASE 5: ds_res = 120
    CASE 6: ds_res = 151
    CASE 7: ds_res = 181
    CASE 8: ds_res = 212
    CASE 9: ds_res = 243
    CASE 10: ds_res = 273
    CASE 11: ds_res = 304
    CASE 12: ds_res = 334
END_SELECT
ds_res = ds_res + Jour - 1: ds_bi = 0
IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN ds_bi=1
IF ds_bi = 1 THEN IF Mois > 2 THEN ds_res = ds_res + 1
REPEAT
    Annee = Annee-1: ds_bi = 0
    IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN ds_bi=1
    ds_res = ds_res + 365 + ds_bi
UNTIL Annee <= 1753
rs_ds% = ds_res-53688: ' date serial
END_SUB
' ------------------------------------------------------------------------------
SUB JourSem(Annee,Mois,Jour)
' Jour de la semaine d'une date donnée (0= Dimanche à 6= Samedi) -> rs_js%
DIM_LOCAL js_d
IF VARIABLE("rs_js%") = 0 THEN DIM rs_js%
js_d = Annee
IF Mois<3 THEN js_d = js_d-1
js_d=INT(23*Mois/9)+Jour+4+Annee+INT(js_d/4)-INT(js_d/100)+INT(js_d/400)
IF Mois>=3 THEN js_d = js_d-2
rs_js% = js_d-7*INT(js_d/7)
END_SUB
' ------------------------------------------------------------------------------
SUB Jmq(Annee,Mois,Jour)
' Quantième de l'année en fonction de Annee, Mois, Jour -> rs_qa%
DIM_LOCAL Jm_Q, Jm_m
IF VARIABLE("rs_qa%") = 0 THEN DIM rs_qa%
Jm_Q = 0
IF Mois > 1
    FOR Jm_m = 1 TO Mois - 1
        SELECT CASE Jm_m
            CASE 1: Jm_Q = Jm_Q+31
            CASE 2: Jm_Q = Jm_Q+28
IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN Jm_Q=Jm_Q+1
            CASE 3: Jm_Q = Jm_Q+31
            CASE 4: Jm_Q = Jm_Q+30
            CASE 5: Jm_Q = Jm_Q+31
            CASE 6: Jm_Q = Jm_Q+30
            CASE 7: Jm_Q = Jm_Q+31
            CASE 8: Jm_Q = Jm_Q+31
            CASE 9: Jm_Q = Jm_Q+30
            CASE 10: Jm_Q = Jm_Q+31
            CASE 11: Jm_Q = Jm_Q+30
        END_SELECT
    NEXT m
END_IF
rs_qa% = Jm_Q+Jour
END_SUB
' ------------------------------------------------------------------------------
SUB Qjm(Annee,Q)
' Mois et jour en fonction du quantième -> Mois, Jour
DIM_LOCAL qj_bi%, qj_qt%, qj_lm%
qj_bi% = 0: qj_qt% = 0
IF (FRAC(Annee/4)=0 AND FRAC(Annee/100)>0) OR FRAC(Annee/400)=0 THEN qj_bi%=1
Mois = 1: qj_qt% = 31
IF Q<32
    Jour = Q
ELSE
    WHILE Q > qj_qt%
        Mois = Mois + 1
        IF Mois = 4 OR Mois = 6 OR Mois = 9 OR Mois = 11
            qj_lm% = 30
        ELSE
            IF Mois = 2
                qj_lm% = 28 + qj_bi%
            ELSE
                qj_lm% = 31
            END_IF
        END_IF
        qj_qt% = qj_qt% + qj_lm%
    END_WHILE
    Jour = Q - qj_qt% + qj_lm%
END_IF
END_SUB
' ------------------------------------------------------------------------------
' ============================== FONCTIONS IMAGES ==============================
SUB CreBmp(f$,w%,h%,r%,g%,b%)
' Création d'une image Bmp f$, dimensions w% x h%, de couleur r%,g%,b%
DIM_LOCAL bm_nbo%
bm_nbo% = NUMBER_OBJECTS + 1: PICTURE bm_nbo%: HIDE bm_nbo%
WIDTH bm_nbo%, w%: HEIGHT bm_nbo%, h%
2D_TARGET_IS bm_nbo%: 2D_FILL_COLOR r%, g%, b%
2D_PEN_COLOR r%, g%, b%: 2D_RECTANGLE 0, 0, w%-1, h%-1
FILE_SAVE bm_nbo%, f$
DELETE bm_nbo%
END_SUB
' ------------------------------------------------------------------------------
SUB DimBmp(f$)
' Dimensions d'une image bmp -> rs_wi%, rs_hi% (largeur, hauteur en pixels)
DIM_LOCAL bm_w%, bm_h%, bm_vdi%
IF VARIABLE("rs_wi%") = 0 THEN DIM rs_wi%
IF VARIABLE("rs_hi%") = 0 THEN DIM rs_hi%
FILEBIN_OPEN_READ 9, f$
FILEBIN_POSITION 9, 19
FILEBIN_READ 9, rs_wi%%: FILEBIN_READ 9, bm_vdi%: rs_wi% = rs_wi% + 256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_wi% = rs_wi% + 256*256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_wi% = rs_wi% + 256*256*256*bm_vdi%
FILEBIN_READ 9, rs_hi%: FILEBIN_READ 9, bm_vdi%: rs_hi% = rs_hi% + 256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_hi% = rs_hi% + 256*256*bm_vdi%
FILEBIN_READ 9, bm_vdi%: rs_hi% = rs_hi% + 256*256*256*bm_vdi%
FILEBIN_CLOSE 9
END_SUB
' ------------------------------------------------------------------------------
SUB BmpInfos(f$, w_img%, h_img%, tf_img%, bpp_img%, th_img%, ll_img%)
' Lecture des données du fichier bmp f$
' -> rs_wi%=largeur, rs_hi%=hauteur, rs_tf%=taille fichier, rs_bp%=bits/pixel,
' -> rs_th%=taille header, rs_ll%=taille ligne d'image
DIM_LOCAL tf%, v%(54), inf_res$
IF VARIABLE("rs_wi%") = 0 THEN DIM rs_wi%
IF VARIABLE("rs_hi%") = 0 THEN DIM rs_hi%
IF VARIABLE("rs_tf%") = 0 THEN DIM rs_tf%
IF VARIABLE("rs_bp%") = 0 THEN DIM rs_bp%
IF VARIABLE("rs_th%") = 0 THEN DIM rs_th%
IF VARIABLE("rs_ll%") = 0 THEN DIM rs_ll%
FILEBIN_OPEN_READ 9, f$: FILEBIN_BLOCK_READ 9, 54, v%(1): FILEBIN_CLOSE 9
rs_tf% = v%(3)+256*v%(4)+256*256*v%(5)+256*256*256*v%(6): ' taille totale du fichier
rs_th% = v%(11)+256*v%(12)+256*256*v%(13)+256*256*256*v%(14): ' taille du header
rs_wi% = v%(19)+256*v%(20)+256*256*v%(21)+256*256*256*v%(22): ' largeur image, en pixels
rs_hi% = v%(23)+256*v%(24)+256*256*v%(25)+256*256*256*v%(26): ' hauteur image, en pixels
rs_bp% = v%(29)+256*v%(30): ' bits par pixel image
rs_ll% = (rs_tf%-rs_th%)/rs_hi%: ' longueur d'une ligne image, en octets
END_SUB
' ------------------------------------------------------------------------------
SUB Img_infos(f$)
' Image f$ -> rs_wi%, rs_hi%, rs_dat$ (dimensions, date/heure de prise de vue)
DIM_LOCAL a_img$, f_img$, i_img$, w_img%, h_img%, d_img$: ' variables locales
IF VARIABLE("rs_wi%") = 0 THEN DIM rs_wi%
IF VARIABLE("rs_hi%") = 0 THEN DIM rs_hi%
IF VARIABLE("rs_dat$") = 0 THEN DIM rs_dat$
f_img$ = "C:\TEMP\Ifxwz.txt"
i_img$ = "C:\Progra~2\Irfanv~1\i_view32.exe ": ' <=========== chemin de IrfanView
EXECUTE_WAIT i_img$ + f$ + " /info=" + f_img$ + " /fullinfo"
FILE_OPEN_READ 9, f_img$: w_img% = 0: h_img% = 0: d_img$ = ""
WHILE FILE_EOF(9) = 0: FILE_READLN 9, a_img$
    IF LEFT$(a_img$, 16) = "Image dimensions"
        a_img$ = MID$(a_img$, 20, 50)
        rs_wi% = VAL(LEFT$(a_img$, INSTR(a_img$, " ") - 1))
        a_img$ = MID$(a_img$, INSTR(a_img$, " ") + 3, 50)
        rs_hi% = VAL(LEFT$(a_img$, INSTR(a_img$, " ") - 1))
    ELSE
        IF LEFT$(a_img$, 16) = "DateTimeOriginal"
            a_img$ = MID$(a_img$, 20, 50)
            rs_dat$ = MID$(a_img$,9,2)+"/"+MID$(a_img$,6,2)+"/"+LEFT$(a_img$,4)+MID$(a_img$,11,6)
            EXIT_WHILE
        END_IF
    END_IF
END_WHILE
FILE_CLOSE 9: FILE_DELETE f_img$
END_SUB
' ------------------------------------------------------------------------------
SUB Jpg2Bmp(fi$,fo$)
' Conversion d'une image Jpg (fi$) en Bmp (fo$)
DIM_LOCAL j_nbo%
j_nbo% = NUMBER_OBJECTS + 1: PICTURE j_nbo%: HIDE j_nbo%
FILE_LOAD j_nbo%, fi$: FILE_SAVE j_nbo%, fo$: DELETE j_nbo%
END_SUB
' ------------------------------------------------------------------------------
SUB Posxy(f$,x%,y%)
' Position dans le fichier bmp et couleur du pixel aux coordonnées x et y pixels
' -> rs_pos% position dans le fichier, rs_cr%, rs_cg%, rs_cb% couleur du pixel
DIM_LOCAL v%(54), bm_tf%, bm_lh%, bm_wi%, bm_hi%, bm_bpp%, bm_ll%
IF VARIABLE("rs_pos%") = 0 THEN DIM rs_pos%
IF VARIABLE("rs_cr%") = 0 THEN DIM rs_cr%
IF VARIABLE("rs_cg%") = 0 THEN DIM rs_cg%
IF VARIABLE("rs_cb%") = 0 THEN DIM rs_cb%
FILEBIN_OPEN_READ 9, f$: FILEBIN_BLOCK_READ 9, 54, v%(1)
bm_tf% = v%(3)+256*v%(4)+256*256*v%(5)+256*256*256*v%(6): ' taille totale du fichier
bm_lh% = v%(11)+256*v%(12)+256*256*v%(13)+256*256*256*v%(14): ' taille du header
bm_wi% = v%(19)+256*v%(20)+256*256*v%(21)+256*256*256*v%(22): ' largeur image, en pixels
bm_hi% = v%(23)+256*v%(24)+256*256*v%(25)+256*256*256*v%(26): ' hauteur image, en pixels
bm_bpp% = v%(29)+256*v%(30): ' bits par pixel image
bm_ll% = (bm_tf%-bm_lh%)/h%: ' longueur d'une ligne image, en octets
rs_pos% = bm_tf% - (y%+1) * bm_ll% + x% * bm_bpp%/8
FILEBIN_POSITION 9, rs_pos%
FILEBIN_READ 9, rs_cb%: FILEBIN_READ 9, rs_cg%: FILEBIN_READ 9, rs_cr%: ' couleur
FILEBIN_CLOSE 9
END_SUB
' ------------------------------------------------------------------------------
SUB RGB2Val(r%,g%,b%)
' Conversion des couleurs R,G,B en valeur entière
IF VARIABLE("rs_cl%") = 0 THEN DIM rs_cl%
rs_cl% = b%+256*g%+256*256*r%
END_SUB
' ------------------------------------------------------------------------------
SUB Val2RGB(couleur)
' Décomposition d'une valeur de couleur en composantes R,G,B: rs_cr%, rs_cg%, rs_cb%
IF VARIABLE("rs_cr%") = 0 THEN DIM rs_cr%
IF VARIABLE("rs_cg%") = 0 THEN DIM rs_cg%
IF VARIABLE("rs_cb%") = 0 THEN DIM rs_cb%
rs_cr% = BIN_AND(couleur,16711680)/65536
rs_cg% = BIN_AND(couleur,65280)/256
rs_cb% = BIN_AND(couleur,255)
END_SUB
' ------------------------------------------------------------------------------
' ============================ FONCTIONS MATHÉMATIQUES =========================
SUB VMKL(v%)
' Conversion d'un entier en chaîne de 4 octets, poids faibles en tête -> rs_mkl$
DIM_LOCAL mk_v
IF VARIABLE("rs_mkl$") = 0 THEN DIM rs_mkl$
mk_v = v%: rs_mkl$ = ""
WHILE LEN(rs_mkl$) < 4
    rs_mkl$ = rs_mkl$ + CHR$(256*FRAC(mk_v/256))
    mk_v = INT(mk_v/256)
END_WHILE
END_SUB
' ------------------------------------------------------------------------------
SUB CVL(v$)
' conversion chaîne de 4 octets (poids faibles en tête) en entier -> rs_cv%
DIM_LOCAL cv_i%
IF VARIABLE("rs_cv%") = 0 THEN DIM rs_cv%
rs_cv% = 0
FOR cv_i% = 4 TO 1 STEP -1
    rs_cv% = 256*rs_cv% + ASC(MID$(vl$, cv_i%, 1))
NEXT cv_i%
END_SUB
' ------------------------------------------------------------------------------
SUB Est_Divisible_par(nombre,diviseur)
' teste si nombre est divisible par diviseur (papydall) -> rs_div$
IF VARIABLE("rs_div$") = 0 THEN DIM rs_div$
dim_local rep$
if mod(nombre,diviseur) = 0
    rs_div$ = "OUI " + str$(nombre) + " est divisible par " + str$(diviseur)
else
    rs_div$ = "NON " + str$(nombre) + " n'est pas divisible par " + str$(diviseur)
end_if
END_SUB
' ------------------------------------------------------------------------------
' ==================================== DIVERS ==================================
SUB Nomcourt(Path$)
' Conversion de Path long en Path court (sans espace) - rs_nc$
DIM_LOCAL nc_fbat$,nc_tmp$,nc_court$
nc_fbat$ = "C:\Temp\Nomcourt.bat": nc_tmp$ = "C:\Temp\temp"
FILE_OPEN_WRITE 9, nc_fbat$
FILE_WRITELN 9, "@echo off"
FILE_WRITELN 9, "for %%A in ("+CHR$(34)+Path$+CHR$(34)+") do echo.%%~sfA >"+nc_tmp$
FILE_CLOSE 9
EXECUTE_WAIT nc_fbat$
FILE_OPEN_READ 9, nc_tmp$
FILE_READLN 9, rs_nc$
FILE_CLOSE 9: FILE_DELETE nc_tmp$: FILE_DELETE nc_fbat$
END_SUB
' ------------------------------------------------------------------------------
SUB Exprog(prog$)
    ' Exécution d'un programme externe sans la fenêtre noire Ms-DOS
    ' - exemple: Exprog("Cmd.exe /c DIR C:\UTIL >C:\TEMP\Dir.txt")
    DIM_LOCAL scr$, bat$, qu$
    scr$ = "C:\TEMP\Vbscript.vbs"
    bat$ = "C:\TEMP\Bat.bat"
    qu$ = CHR$(34)
    ' ===== Création du fichier .bat
    FILE_OPEN_WRITE 9, bat$: FILE_WRITELN 9, prog$: FILE_CLOSE 9
    ' ===== Création du script .vbs
    FILE_OPEN_WRITE 9, scr$
    FILE_WRITELN 9, "CreateObject("+qu$+"Wscript.Shell"+qu$+").Run "+qu$+bat$+qu$+",0,True"
    FILE_CLOSE 9
    ' ===== Exécution du script
    EXECUTE_WAIT "WSCRIPT.exe "+scr$
    FILE_DELETE bat$: FILE_DELETE scr$
END_SUB
' ------------------------------------------------------------------------------
C'est bien calme aujourd'hui... la neige ?

Edit: troncature intempestive d'une ligne dans Img_Infos.
Ajouté aussi la sub papydall (test de divisibilité).

Edit 16/21h30 changement de tactique pour le renvoi des paramètres
21/1 erreur dans la SUB Jmq (manquait CASE 6: Juin !)
1/2 petite mise à jour, petit bug.
14/2 ajout de deux subs: Misfoc et Misfop


Dernière édition par JL35 le Jeu 14 Fév 2013 - 18:23, édité 7 fois
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
papydall

avatar

Nombre de messages : 5508
Age : 67
Localisation : Moknine (Tunisie) Entre la chaise et le clavier
Date d'inscription : 03/03/2012

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 0:59

Salut JL35

Merci, j’adopte !
Quand on disposera de la possibilité de définir des fonctions (retournant des valeurs) en plus des SUBs, ça sera beaucoup plus souple d’emploi.
On s’affranchira du CLIPBOARD et de la gymnastique pour faire qu’une SUB sache retourner un résultat.
En attendant, voici ma micro contribution ( 2 SUBs qui devraient être 2 FUNCs) que tu peux ,si tu veux, ajouter à SUB_Bib.bas ( en les adaptant à ta manière).

Code:
est_divisible_par(21,4)
est_divisible_par(34,2)
print
RoundUp(2.4) : RoundUp(3.5)
end
' ******************************************************************************
' teste si nombre est divisible par diviseur
SUB est_divisible_par(nombre,diviseur)
    dim_local rep$
    if mod(nombre,diviseur) = 0
      rep$ = "OUI " + str$(nombre) + " est divisible par " + str$(diviseur)
    else
      rep$ = "NON " + str$(nombre) + " n'est pas divisible par " + str$(diviseur)
    end_if
    print rep$
end_sub
' ******************************************************************************
' Arrondit un réel en un entier le plus proche
SUB RoundUp(x)
  dim_local result%
  result% = int(x) + int(frac(x)*2)
  print "RoundUp("+str$(x)+") = ";result%
end_sub
' ******************************************************************************

PS : J’ai consulté la météo (vieille habitude d’un météorologue en retraite) et je vois que la France est sous la pluie et la neige !
Est-ce la cause du calme plat sur le Forum ?



Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://papydall-panoramic.forumarabia.com/
Jicehel

avatar

Nombre de messages : 5849
Age : 45
Localisation : 77500
Date d'inscription : 19/04/2011

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 12:33

Merci à vous deux pour ce partage de fonctions.
Ca vous dirait que l'on fasse des librairies par thèmes ?
Je crois que quelqu'un avait fait des fichiers .LIB il y a quelques années, si je ne m'abuse. On pourrait faire pareil pour avoir des "librairies standards" à inclure dans nos programmes selon leur thème, peut être. Qu'en pensez-vous ?
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Yannick

avatar

Nombre de messages : 7968
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Mer 16 Jan 2013 - 14:16

@ Jicehel,

Cela pourrait se faire mais peut être serait il bien d'attendre
la version avec un vrai compilateur.

Je m'explique :

Actuellement, des fichiers *.LIB standard risque d'allourdire nos programmes
avec des Sub non utilisées.

Ceci dit, rien n'empêche de commencer à les créer...
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Jicehel

avatar

Nombre de messages : 5849
Age : 45
Localisation : 77500
Date d'inscription : 19/04/2011

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 14:45

Ce que tu dis est vrai ygeronimi et la difficulté des libs est de n'avoir que les fonctions essentielles ou très couramment utilisées dans certaines lib + des librairies supplémentaires avec les fonctions complémentaires. (L'autre difficulté étant de standardiser la façon de les faire...)

C'est un découpage qui nécessite une vrai réfelxion (avec plusieurs cerveaux pour se faire aux différentes façon de programmer).

Après, bon, les fonctions non utilisées des librairies ont un poids très faible en kilo octets, honnétement. Ce n'est pas elles qui alourdissent réellement la taille d'un programme par rapport aux données externes et autres grosses données (images, sons, fichiers de données, ...)
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Yannick

avatar

Nombre de messages : 7968
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Mer 16 Jan 2013 - 16:00

Je donne une piste que j'ai utilisé pour les "form"

appel :
Code:
Formulaire(N%,V%,H%,W%,T%,L%)
N% : Numéro du "form"
V% : hide/Show (0/1)
H% : Height
W% : Width
T% : Top ( 0=centré / >0 emplacement )
L% : Left ( 0=centré / >0 emplacement )

Sub :
Code:
Sub Formulaire(N%,V%,H%,W%,T%,L%)
  Form N%
  If V%=0 then Hide N%
  Height N%,H% : Width N%,W%
  If T%>0 : Top N%,T% : Else : Top% N%, (screen_y-H%)/2 : End_If
  If L%>0 : Top N%,L% : Else : Left% N%,(screen_x-W%)/2 : End_If
End_Sub

Pour les objets on peut rajouter P% entre N% et V% pour "Parent"
dans la sub on a donc :
Code:
....
Objet N% : Parent N%,P%
....

On peut aussi ajouter le texte par défaut C$ ( C pour Caption ) lorsque c'est un objet ayant un "caption", en fin de déclaration

bref...je vous laisse méditer là dessus.... Laughing
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Jicehel

avatar

Nombre de messages : 5849
Age : 45
Localisation : 77500
Date d'inscription : 19/04/2011

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 16:26

Pour les noms des procédures, on pourrait adopter une convention de nommage entre nous, du type
O devant si le résultat est retouné dans un objet (une liste par exemple)
C devant si le résultat est retrouné dans le pressepapier
sans rien ou pour vérifier que la procédure s'est bien déroulé, on utiliserai par exemple la variable "Nom de la procédure_return"

Après, il y aurait _Lettre correspondant à la bibliothèque
exemple :
S pour string, fonction concernant les chaines
F pour file, fonction concernant les fichiers
D pour date, fonction concernant les dates
C pour conversion, fonction de converssion de données
M pour math, fonctions mathématiques
I pour IDE, fonctions relatives à l'interface graphique

Perso, par rapport aux dernières fonctions utilisées, on pourrait déjà créer ces 6 librairies.

Pour la fonction RINSTR, par exemple, on pourrait avoir 2 déclinaisons de la procédure:
C_S_RInstr(S1$,S2$) qui renvoit dans le presse papier la position de S2$ dans S1$ ou 0 si non trouvé et -1 en cas d'erreur
S_RInstr%(S1$,S2$) qui renvoit dans S_RInstr_return% la position de S2$ dans S1$ ou 0 si non trouvé et -1 en cas d'erreur
Il pourrait y en avoir une troisième version mais je pense, sans interet, mais ce n'est que mon opinion: O_S_RInstr(S1$,S2$,N_obj%) qui renvoit dans l'objet N_obj% la position de S2$ dans S1$ ou 0 si non trouvé et -1 en cas d'erreur
(Objet devant avoir une nature connu, par exemple un DLIST)

Pour ta fonction Formulaire, par exemple, ça pourrait devenir: I_Formulaire(No%,Visible%,Pos_H%,Largeur%,Pos_V%,Hauteur%,Centré%)
Idéalement, cette fonction retournerait -1 dans la variable I_Formulaire_return% en cas d'erreur et 0 en cas de succes

Pour créer un autre objet, on pourrait en effet faire une fonction : I_Objet(No%, No_ObjetParent%, Visible%,Pos_H%,Largeur%,Pos_V%,Hauteur%)
Idéalement, cette fonction retournerait -1 dans la variable I_Objet_return% en cas d'erreur et 0 en cas de succes

Perso, je laisserait caption à part pour que cette fonction reste fonction reste plus universelle.

Bon, ce n'est pas le tout, mais je dois retourner bosser. J'espère qu'il y a quelques bonnes idées dans tout mon baratin ...


Revenir en haut Aller en bas
Voir le profil de l'utilisateur
JL35



Nombre de messages : 5920
Localisation : 77
Date d'inscription : 29/11/2007

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 16:28

J'arrive..
Merci à tous pour vos avis.

Jicehel, évidemment ce serait bien d'avoir des bibliothèques par thèmes, et pour répondre aussi à ygeronimi, dans mon esprit ce ne seraient pas des lib au sens propre, mais simplement des collections de SUBs d'où extraire uniquement les SUB dont on a besoin (par copier/coller), sans inclure la bibliothèque entière.
Je vois plutôt ça comme un fichier texte unique (ou à la rigueur plusieurs, par catégorie), où on va piocher en fonction des besoins. (en Basic j'avais une telle bibliothèque, et un programme spécial qui insérait une sub donnée à un endroit donné d'un programme donné).

Oui papydall, on est bien sous la neige (région parisienne du moins), ça ralentit un peu les activités !
Papydall, ta sub RoundUp(x): arrondir un réel à l'entier le plus proche.
Pourquoi ne pas le mettre directement dans un entier, et ça s'arrondit tout seul !
Tu fais va% = v, tout simplement
va% = 3.1416 -> va% = 3, va% = 3.7517 -> va% = 4 euréka !
Il me semble que
Code:
result% = x
donne exactement la même chose que
Code:
result% = int(x) + int(frac(x)*2)


PS salut Jicehel, on s'est croisés.

Il y a de bonnes idées, certes, mais tout ça me paraît bien compliqué... pour moi (un peu simpliste), il suffit de mettre au début de la procédure en commentaire un résumé de la fonction, des paramètres attendus et renvoyés (sous quelle forme).
Je retiens aussi l'idée de renvoyer le résultat dans un objet panoramic (dlist par exemple) dont on donne le numéro à la sub au moment de l'appel, intéressant. Ce qui plairait mieux aux détracteurs du clipboard.
On pourrait par exemple dans le programme principal écrire une ligne, une seule pour toutes les subs appelées, du genre:
Code:
DIM Rsub%: Rsub% = 1999: DLIST Rsub%
Puis à l'appel des subs qui rendent un paramètre:
Code:
Masub(p1,p2,...,Rsub%)
retour$ = ITEM_READ$(Rsub%,1) ou bien retour = VAL(ITEM_READ$(Rsub%,1))
Et dans la sub, pour renvoyer le paramètre:
Code:
...
CLEAR Rsub%: ITEM_ADD Rsub%, valeur$, ou STR$(valeur)
END_SUB
Je reconnais que c'est un peu tordu, et je continue à déplorer qu'on ne puisse pas renvoyer un paramètre passé dans l'appel. Comme en Basic.

Et bon courage pour le boulot Jicehel, tu as de la chance toi d'être encore un rouage utile de la société Very Happy
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Jicehel

avatar

Nombre de messages : 5849
Age : 45
Localisation : 77500
Date d'inscription : 19/04/2011

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 18:56

Merci, mais par contre boulot + enfants + administration à gérer => Manque de temps. C'est pas juste.
Sinon, pour la règle, je reconnais, c'est un peu compliqué, l'idée serait de simplifier un peu la lecture si l'on fait un ou plusieurs include et si les librairies étaient standardisées, ça éviterait de devoir les retélécharger à chaque fois (selon le même principe que la DLL de KLAUS, si l'on n'utilise pas les nouvelles fonctions qu'il ajoute régulièrement)
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Yannick

avatar

Nombre de messages : 7968
Age : 46
Localisation : Bretagne
Date d'inscription : 15/02/2010

MessageSujet: re   Mer 16 Jan 2013 - 19:22

Pour le manque de temps, l' administration ce suffit à elle même !

lol!
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
papydall

avatar

Nombre de messages : 5508
Age : 67
Localisation : Moknine (Tunisie) Entre la chaise et le clavier
Date d'inscription : 03/03/2012

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 19:32

Salut tout le monde.

J’ai lu avec intérêt vos proses. Dans l’ensemble j’adhère à vos idées.
On essaye tant bien que mal de « standardiser » les retours des résultats par les SUBs aux appelants de ces mêmes SUBs.
Or le rôle d’une SUB est d’accomplir une certaine tâche bien définie sans être obligée de retourner quoi que ce soit.

Le retour d’un résultat est le « job » des fonctions (FNC ou FUNC ou FUNCTION ou autre syntaxe).
En attendant l’implémentation de ces dernières (le problème du retour du résultat ne se posera plus), on fait ce qu’on peut.
Personnellement ni le clipboard, ni l’utilisation d’une tierce variable ne me satisfont pour récupérer le résultat.
Mais on peut faire avec, faute de mieux !

Je vais réfléchir à une liste de fonctions utiles (surtout au niveau de l’algorithme) pour être prêt le jour J.

@JL35
Tu as parfaitement raison : affecter une valeur flottante à une variable entière fait bien l’arrondi !
Je le savais, je le savais mais, dans la précipitation (la hâte et non pas la pluie ou la neige !) j’ai voulu contribuer par something : c’est loupé !
Ma sub RoundUp est nulle et archi nulle. Sad
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://papydall-panoramic.forumarabia.com/
JL35



Nombre de messages : 5920
Localisation : 77
Date d'inscription : 29/11/2007

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 19:54

Elle n'est pas nulle mais elle est non avenue ! Very Happy

Il est bien entendu que ce qu'on fait c'est beaucoup à défaut des Functions. Mais rien n'empêche une Sub d'avoir à retourner des résultats, s'il y a plusieurs résultats à renvoyer (par exemple les dimensions d'une image) il faut bien les retourner, ou alors une Function pour la largeur, une autre pour la hauteur, une troisième pour la date etc.
Pour moi la théorique FUNCTION ABC(...) renvoie la valeur ABC (c'est à dire une seule valeur ou chaîne).

En attendant je rajoute quelques petites subs, par exemple remplacer dans une chaîne une séquence par une autre, ou inverser une chaîne (pas sûr que ça serve à grand chose...).
)...esohc dnarg à evres aç euq rûs sap( enîahc enu resrevni uo ,ertua enu rap ecneuqés enu enîahc enu snad recalpmer elpmexe rap ,sbus setitep seuqleuq etuojar ej tnadnetta nE
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 10062
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 21:04

Je redis ici cue que je fais, pour ma part, au niveau du retour d'information des procédures. J'ai adopté cette technique pour le module KGF_SUB qui "habille" tous les appels à des fonctions de KGF.dl, à l'aide de procédures Panoramic.

Prenons un exemple: une procédure MaProcedure qui doit retourner un entier, une chaîne de caractères et un tableau de flottants (oui, je sais, je cherche la petite bête). Je fais systématiquement de la manière suivante:
Code:

sub MaProcedure(...liste de paramètres...)
' définition des variables pour les valeurz retournées
  if variable("MaProcedure")=0 then dim MaProcedure
  if variable("MaProcedure$")=0 then dim MaProcedure$
  if variable("MaProcedure_tableau")=0 then dim MaProcedure_tableau(10)
  dim_local i%
' juste à titre d'exemple
  ... ici, traitement de la procédure

' chargement des variables pour les valeurs retournées
  MaProcedure = ...valeur...  : ' valeur principale de retour - même nom que la procédure !
  MaProcedure$ = "...chaîne..." : ' chaîne de caractères à retourner
  for i%=0 to 10
    MaProcedure_tableau(i%) = ...valeur flottante...
  next i%
end_sub

Et je l'utilise de la manière suivante:
Code:

...
MaProcedure(...)
message "Résultat: "+str$(MaProcedure)
message "Chaîne retournée: "+MaProcedure$
message "Valeur flottante 3 = "+str$(MaProcedure_tableau(3)

Nul besoin de déclarer ces variables en-dehors de la procédure - le simple fait de l'utiliser la première fois déclare automatiquement toutes les variables nécessaires. Et je peux retourner des valeurs quelconques, et en nombre illimité.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
JL35



Nombre de messages : 5920
Localisation : 77
Date d'inscription : 29/11/2007

MessageSujet: Re: Quelques SUBs, en vrac   Mer 16 Jan 2013 - 23:43

Finalement j'ai adopté la méthode Klaus, qui me parait plus rationnelle, édulcorée: créer si nécessaire en interne dans la sub la ou les variables qui contiendra les éléments éventuels en retour de la sub.

Je n'ai pas donné (contrairement à Klaus) à ces variables le nom de la sub elle-même (je reconnais que c'est plus sûr, mais ça ne me plait pas trop que des éléments différents portent le même nom).

Pour les repérer, ces variables sont créées avec un préfixe rs_ (comme retour sub), il y a un faible risque de redondance d'une sub à l'autre, mais ce n'est pas grave, en principe ces variables ne sont exploitées par le programme principal que juste derrière l'appel, donc avant l'appel à une sub ultérieure.

Donc plus de clipboard, j'espère que je n'ai pas fait (trop) d'erreur dans la conversion.

Il faut évidemment préciser en commentaire au début de chaque sub, non seulement la nature des paramètres en entrée, mais la nature et le nom de la (ou les) variable(s) qui contiendra les données en sortie.
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Nardo26

avatar

Nombre de messages : 2294
Age : 49
Localisation : Valence
Date d'inscription : 02/07/2010

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 0:58

Bonsoir,
il existe aussi des SUB un peu folkloriques avec des variables de retour...
Perso j'utilise dans ce cas là, une DLIST dont l'identificateur est passé en paramètre à la SUB...
Code:

DLIST 125
MaProcedure(Param1,Param2,125)
...
Avec ce système on peut même envisager des passages de paramètre variables
Par exemple une procédure qui peut accepter 1, 2 ou N paramètres en entrée et autant en sortie peut être codée de cette manière:
Code:

DLIST 123
' appel à la SUB Toto avec 2 paramètres
ITEM_ADD 123, Param1 : ITEM_ADD 123, Param2
Toto(123)
Print "Nombre de valeur en retour:";COUNT(123)
' appel à la SUB Toto avec 3 paramètres
CLEAR 123
ITEM_ADD 123, Param1 : ITEM_ADD 123, Param2: ITEM_ADD 123, Param3
Toto(123)
Print "Nombre de valeur en retour:";COUNT(123)
....


Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://nardo26.lescigales.org
JL35



Nombre de messages : 5920
Localisation : 77
Date d'inscription : 29/11/2007

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 1:20

Bonsoir Nardo,
Effectivement c'est aussi une solution assez élégante que j'ai testé aussi, une seule petite Dlist pour toutes les subs, ça évite la multiplication des variables et on peut y empiler les résultats sans limite.
Après tout, chacun peut choisir sa solution, ça ne fait pas beaucoup de modifs, mais enfin ce serait mieux de se mettre d'accord sur une solution unique, pour les échanges de programmes.

Tout ça ne vaut pas le fait de pouvoir passer le paramètre de retour en appel à la sub... dommage.

Bonne nuit, en attendant !
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Klaus

avatar

Nombre de messages : 10062
Age : 68
Localisation : Ile de France
Date d'inscription : 29/12/2009

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 1:35

Eh bien, Nardo26, ma technique tient compte de cela ! Que ce soit une valeur, plusieurs valeurs ou même des tableaux, je peux le faire comme documenté dans mon post précédent. Avec la technique des DLIST, tu auras sûrement des problèmes avec des tableaux...
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://klauspanoramic.comxa.com/index.html
papydall

avatar

Nombre de messages : 5508
Age : 67
Localisation : Moknine (Tunisie) Entre la chaise et le clavier
Date d'inscription : 03/03/2012

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 2:03

Hello world !

Voici une petite SUB qui pourrait devenir une FNC le moment venu.
Elle répond au doux nom de Accent_Off et elle a pour mission de remplacer les lettres accentuées en leurs homologues non accentuées.
Code:
' Accent_Off(chaine$) est une procédure qui transforme les voyelles accentuées,
' le c cedille ainsi que le ñ en lettres non accentuées, le æ et le œ en ae et oe
' Elle pourra très bien faire l'objet d'une fonction
' ******************************************************************************

Accent_Off("éèàçôæûÿöýãåñ")
end

Sub Accent_Off(tex$)
    dim_local i%,c$,c1$,t$,asc%
    if len(tex$) = 0 then exit_sub
    for i% = 1 to len(tex$)
        c$ = mid$(tex$,i%,1) : c1$ = c$
        asc% = asc(c$)
        select asc%
            case 156 : c1$ = chr$(111) +chr$(101) : ' œ ---> oe
            case 224 : c1$ = chr$(097) : ' à ---> a
            case 225 : c1$ = chr$(097) : ' á ---> a
            case 226 : c1$ = chr$(097) : ' â ---> a
            case 227 : c1$ = chr$(097) : ' ã ---> a
            case 228 : c1$ = chr$(097) : ' ä ---> a
            case 229 : c1$ = chr$(097) : ' å ---> a
            case 230 : c1$ = chr$(097) + chr$(101) : ' æ ---> ae
            ' ---------------------------------------------------
            case 231 : c1$ = chr$(099) : ' ç ---> c
            case 232 : c1$ = chr$(101) : ' è ---> e
            case 233 : c1$ = chr$(101) : ' é ---> e
            case 234 : c1$ = chr$(101) : ' ê ---> e
            case 235 : c1$ = chr$(101) : ' ë ---> e
            ' -------------------------------------
            case 236 : c1$ = chr$(105) : ' ì ---> i
            case 237 : c1$ = chr$(105) : ' í ---> i
            case 238 : c1$ = chr$(105) : ' î ---> i
            case 239 : c1$ = chr$(105) : ' ï ---> i
            ' -------------------------------------
            case 240 : c1$ = chr$(111) : ' ð ---> o
            case 241 : c1$ = chr$(110) : ' ñ ---> n
            case 242 : c1$ = chr$(111) : ' ò ---> o
            case 243 : c1$ = chr$(111) : ' ó ---> o
            case 244 : c1$ = chr$(111) : ' ô ---> o
            case 245 : c1$ = chr$(111) : ' õ ---> o
            case 246 : c1$ = chr$(111) : ' ö ---> o
            ' -------------------------------------
            case 249 : c1$ = chr$(117) : ' ù ---> u
            case 250 : c1$ = chr$(117) : ' ú ---> u
            case 251 : c1$ = chr$(117) : ' ú ---> u
            case 252 : c1$ = chr$(117) : ' ü ---> u
            ' -------------------------------------
            case 253 : c1$ = chr$(121) : ' ý ---> y
            case 255 : c1$ = chr$(121) : ' ÿ ---> y
            ' -------------------------------------
        end_select
        t$ = t$ + c1$
    next i%
    message upper$(t$)
end_sub
' ******************************************************************************

Et une SUB permettant de calculer le triangle de Pascal

Code:
' Le Triangle de Pascal
' Le triangle arithmétique de Pascal est le triangle dont la ligne d'indice n
' (n = 0, 1, 2...) donne les nombres qui apparaissent dans le développement de
' (a + b)^n et dans des nombreux domaines en mathématiques comme l'analyse combinatoire.

' EXEMPLE : Pour calculer (a + b)^5
' La ligne 5 donne : 1 ; 5 ; 10 ; 10 ; 5 ; 1
' soit les coefficients de :
' (a + b)^5 = 1×a^5 + 5×a^4b + 10×a^3b² + 10×a²b^3 + 5×ab^4 + 1×b^5.

' ATTENTION : les coefficients croissent très rapidement et il y a risque de
' dépassement de la plage des nombres entiers. Par exemple, si vous appelez la
' procédure avec la valeur 35, certains coefficients deviennent négatifs : c'est
' une conséquence du dépassement.
' Pour aller plus loin, vous pouvez changer les variables entières en flottantes
' Mais à quoi ça pourrait servir ?



height 0,600 : width 0,1200

Triangle_Pascal(25)
end
' ******************************************************************************
SUB Triangle_Pascal(n%)
    dim_local i%,j%,tab%(n%+1,n%+1)
    For i% = 1 to n%+1 : For j% =1 to n%+1 : Tab%(i%,j%) = 0 : next j% : next i%
    For i% = 1 to n%+1
      For j%=1 to n%+1
        If j% = 1
          tab%(i%,j%)=1
        else
          if i%<>1 then tab%(i%,j%)= tab%(i%-1,j%)+tab%(i%-1,j%-1)
        end_if
        if tab%(i%,j%)<>0 then print tab%(i%,j%); " " ;
      next j%
      print
    next i%
END_SUB
' ******************************************************************************


Dernière édition par papydall le Jeu 17 Jan 2013 - 4:41, édité 1 fois (Raison : Ajout de la SUB Triangle_Pascal(n%))
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://papydall-panoramic.forumarabia.com/
Jean Claude

avatar

Nombre de messages : 4989
Age : 63
Localisation : 83 Var
Date d'inscription : 07/05/2009

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 10:22

Merci Papydall pour Accent_Off, cette SUB tombe à pic pour moi.

Et je vais également m'en servir pour en faire une autre qui s'appellera Accent_On_Upper

Je la poste dès qu'elle est faite.

A+
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
pan59

avatar

Nombre de messages : 367
Age : 60
Localisation : Wattignies
Date d'inscription : 16/10/2011

MessageSujet: Subs en vrac.   Jeu 17 Jan 2013 - 10:29

Voici quelques subs en vrac que j'utilise:



Code:
sub reverse_string(param1$)

  ' En paramètre, la chaîne que l'on désire écrire à l'envers.
  ' En retour dans rs$ la chaîne inversée.

    rs$=""
   
    for kk%=len(param1$) to 1 step -1
        rs$=rs$+mid$(param1$,kk%,1)
    next kk%

end_sub

Code:
sub lastIndexof(param1$, param2$, position%)

    ' En entrée, on donne chaine$, sous_chaine$ et position%.
    ' En sortie, on fournit dans 'res%' la dernière occurence de sous_chaine$ dans chaine$.
    ' Si sous_chaine$ n'existe pas, on fournit -1.

    reverse_string(param1$)
    res%=instr(rs$,param2$)-1
    if res%<position% then res%=-1

end_sub

Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Jean Claude

avatar

Nombre de messages : 4989
Age : 63
Localisation : 83 Var
Date d'inscription : 07/05/2009

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 11:21

Merci Pan59 pour ta participation

Voici calquée sur le model de Papydall la SUB Accent_On_Lower_To_Upper qui transforme des minuscules accentuées en majuscules accentuées.

Code:
' Accent_On_Lower_To_Upper (chaine$) est une procédure qui transforme les
' voyelles accentuées d'une chaine en minuscule en voyelle accentuées majuscules
' ******************************************************************************

Accent_On_Lower_To_Upper("œ,à,á,â,ä,å,æ,ç,è,é,ê,ë, etc... ")
end

Sub Accent_On_Lower_To_Upper(tex$)
    dim_local i%,c$,c1$,t$,asc%
    if len(tex$) = 0 then exit_sub
    for i% = 1 to len(tex$)
        c$ = mid$(tex$,i%,1) : c1$ = c$
        asc% = asc(c$)
        select asc%
            case 156 : c1$ = chr$(140) : ' œ ---> Œ
            case 224 : c1$ = chr$(192) : ' à ---> À
            case 225 : c1$ = chr$(193) : ' á ---> Á
            case 226 : c1$ = chr$(194) : ' â ---> Â
            case 227 : c1$ = chr$(195) : ' ã ---> Ã
            case 228 : c1$ = chr$(196) : ' ä ---> Ä
            case 229 : c1$ = chr$(197) : ' å ---> Å
            case 230 : c1$ = chr$(198) : ' æ ---> Æ
            ' -------------------------------------
            case 231 : c1$ = chr$(199) : ' ç ---> Ç
            case 232 : c1$ = chr$(200) : ' è ---> È
            case 233 : c1$ = chr$(201) : ' é ---> É
            case 234 : c1$ = chr$(202) : ' ê ---> Ê
            case 235 : c1$ = chr$(203) : ' ë ---> Ë
            ' -------------------------------------
            case 236 : c1$ = chr$(204) : ' ì ---> Ì
            case 237 : c1$ = chr$(205) : ' í ---> Í
            case 238 : c1$ = chr$(206) : ' î ---> Î
            case 239 : c1$ = chr$(207) : ' ï ---> Ï
            ' -------------------------------------
            case 240 : c1$ = chr$(213) : ' ð ---> Ð
            case 241 : c1$ = chr$(209) : ' ñ ---> Ñ
            case 242 : c1$ = chr$(210) : ' ò ---> Ò
            case 243 : c1$ = chr$(211) : ' ó ---> Ó
            case 244 : c1$ = chr$(212) : ' ô ---> Ô
            case 245 : c1$ = chr$(213) : ' õ ---> Õ
            case 246 : c1$ = chr$(214) : ' ö ---> Ö
            ' -------------------------------------
            case 249 : c1$ = chr$(217) : ' ù ---> Ù
            case 250 : c1$ = chr$(218) : ' ú ---> Ú
            case 251 : c1$ = chr$(219) : ' û ---> Û
            case 252 : c1$ = chr$(220) : ' ü ---> Ü
            ' -------------------------------------
            case 253 : c1$ = chr$(221) : ' ý ---> Ý
            case 255 : c1$ = chr$(159) : ' ÿ ---> Ÿ
            ' -------------------------------------
        end_select
        t$ = t$ + c1$
    next i%
    message t$
end_sub
' ******************************************************************************


Une astuce que j'ai découverte sur gogol car je me demandait comment faisait Papydall pour obtenir "œ ou Œ" :
si tu tapes 0159 pendant que alt est enfoncée tu obtiens Ÿ
et c'est valable pour toutes les minuscules qui sont dans le code ci-dessus


A+


Dernière édition par Jean Claude le Jeu 17 Jan 2013 - 13:18, édité 4 fois
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Jicehel

avatar

Nombre de messages : 5849
Age : 45
Localisation : 77500
Date d'inscription : 19/04/2011

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 12:58

Il faut que je fasse la macro que j'ai sous Excel aussi pour transformer les caractères spéciaux en code HTML, c'est bien pratique aussi dans certains cas Wink (C'est exactement le même que ta procédure Jean-Claude, mais avec des chaines de substitutions à la place des codes ASCII)
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Jean Claude

avatar

Nombre de messages : 4989
Age : 63
Localisation : 83 Var
Date d'inscription : 07/05/2009

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 15:27

2 autres pour saisir une date controlée

j'ai réinventé l'ouvre_boite Very Happy
Code:

' Sub Saisie_Date par Jean claude 01/2013
' le controle du jour par rapport au mois et à l'année est automatique (ex: essayez de taper 31/02/2011)
' retourne a$=année,b$=mois,c$=jour

' Sub Ouvre_Boite(numéro du container,Width du container,Height du container,Top du container,
'                Left du container,Texte du caption du container,NbChr%,Num_Chr%)
' Permet d'ouvrir un container contenant des objets de taille voulue, position voulue et caption cap$

' les objet sont créer automatiquement (pas besion de les numéroter)

dim a$,b$,c$,cap$,Provenance$
dim no%,n%
label jour,J2,mois,M2,annee,A1,A2,valide_date

Boite_Date():' création des objets nécessaires à la saisie dans un container (Boite)

cap$=" Jour "+string$(6,chr$(126))+" Mois "+string$(6,chr$(126))+" Année "+string$(6,chr$(126))
' ou
' cap$=""
' ou
' cap$=" Saisie date ":' dans ce cas il faut mettre la valeur 12 à la variable NbChr%

Ouvre_Boite(Boite_date%,225,45,140,102,cap$,0,126)

a$=right$(date$,4):b$=mid$(date$,4,2):c$=left$(date$,2):' ou une autre date
Saisie_Date(a$,b$,c$,edit_annee%,BT_annee_modif%,combo_mois%,BT_mois_modif%,combo_jour%,BT_jour_modif%,BT_Valid_date%)

caption 0,c$+"/"+b$+"/"+a$:' retour

END
' -------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub Saisie_Date(annee$,moi$,jour$,num_edit_annee%,num_BT_annee_modif%,num_combo_mois%,num_BT_mois_modif%,num_combo_jour%,num_BT_jour_modif%,num_BT_Valid_date%):' retourne a$=année,b$=mois,c$=jour
inactive num_edit_annee%:text num_edit_annee%,annee$:active num_BT_annee_modif%:on_click num_BT_annee_modif%,annee
inactive num_combo_mois%:text num_combo_mois%,moi$:active num_BT_mois_modif%:on_click num_BT_mois_modif%,mois
inactive num_combo_jour%:text num_combo_jour%,jour$:active num_BT_jour_modif%:on_click num_BT_jour_modif%,jour
active num_BT_Valid_date%:on_click num_BT_Valid_date%,valide_date
if annee$="" or moi$="" or jour$=""
MESSAGE "ERREUR: une ou plusieurs variables annee$,moi$,jour$, non renseignée(s) au SUB Saisie_Date":terminate
end_if
if len(annee$)<>4 or len(moi$)<>2 or len(jour$)<>2
MESSAGE "ERREUR: une ou plusieurs variables annee$,moi$,jour$, incorrecte(s) (longueur string$) au SUB Saisie_Date":terminate
end_if
if val(text$(num_edit_annee%))=0 or val(text$(num_combo_mois%))=0 or val(text$(num_combo_jour%))=0
MESSAGE "ERREUR: une ou plusieurs variables annee$,moi$,jour$, incorrecte(s) au SUB Saisie_Date":terminate
end_if
end
jour:
inactive num_BT_mois_modif%:inactive num_BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
Charge_Combo_Jour(text$(num_edit_annee%),text$(num_combo_mois%),text$(num_combo_jour%),num_combo_jour%)
active num_combo_jour%:on_click num_combo_jour%,J2
return
J2:
jour$=text$(num_combo_jour%):inactive num_combo_jour%
active num_BT_mois_modif%:active num_BT_annee_modif%:active num_BT_jour_modif%:active num_BT_Valid_date%
return
mois:
inactive num_BT_mois_modif%:inactive num_BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
active num_combo_mois%:on_click num_combo_mois%,M2
return
M2:
moi$=text$(num_combo_mois%):inactive num_combo_mois%
active num_BT_mois_modif%:active num_BT_annee_modif%:active num_BT_jour_modif%:active num_BT_Valid_date%
Provenance$="M2":Charge_Combo_Jour(text$(num_edit_annee%),text$(num_combo_mois%),text$(num_combo_jour%),num_combo_jour%)
Provenance$=""
return
annee:
inactive num_BT_mois_modif%:inactive num_BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
active num_edit_annee%:set_focus num_edit_annee%:on_key_up num_edit_annee%,A1
return
A1:
if key_up_code=13 then goto A2
return
A2:
annee$=text$(num_edit_annee%):inactive num_edit_annee%
if len(annee$)<>4 then message "Saisie incorrecte (format JJ/MM/AAAA)":text num_edit_annee%,"":goto annee
active num_BT_mois_modif%:active num_BT_annee_modif%:active num_BT_jour_modif%:active num_BT_Valid_date%
return
valide_date:
a$=text$(num_edit_annee%):b$=text$(num_combo_mois%):c$=text$(num_combo_jour%)
inactive num_BT_mois_modif%:inactive BT_annee_modif%:inactive num_BT_jour_modif%:inactive num_BT_Valid_date%
Exit_Sub
return
End_Sub
' ----------------------------------
Sub Charge_Combo_Jour(aaaa$,mm$,jj$,num_combo_jour%)
dim_local i%,aaaa%,mm%,jj%,bissextile%,maxj%
if Provenance$<>"M2" then clear num_combo_jour%
text num_combo_jour%,jj$:aaaa%=val(aaaa$):bissextile%=0:mm%=val(mm$)
IF (FRAC(aaaa%/4)=0 AND FRAC(aaaa%/100)>0) OR FRAC(aaaa%/400)=0 THEN bissextile%=1:' JL35
if mm%=2
  if bissextile%=1
    maxj%=29:if Provenance$="M2" and val(jj$)>maxj% then jj$=str$(maxj%)
  else
    maxj%=28:if Provenance$="M2" and val(jj$)>maxj% then jj$=str$(maxj%)
  end_if
else
  if mm%=4 or mm%=6 or mm%=9 or mm%=11
  maxj%=30:if Provenance$="M2" and val(jj$)>maxj% then jj$=str$(maxj%)
  else
  maxj%=31
  end_if
end_if
if Provenance$="M2" then text num_combo_jour%,jj$:Exit_Sub
for i%=1 to 9:item_add num_combo_jour%,"0"+str$(i%):next i%
for i%=10 to maxj%:item_add num_combo_jour%,str$(i%):next i%
End_Sub
' --------------
Sub Boite_Date()
dim Boite_date%,edit_annee%,BT_annee_modif%,combo_mois%,BT_mois_modif%,combo_jour%,BT_jour_modif%,BT_Valid_date%
no%=no%+1:Boite_date%=no%:Container no%:width no%,225:top no%,10:left no%,6:hide no%
          font_color no%,0,0,150:font_name no%,"Arial":height no%,45
no%=no%+1:edit_annee%=no%:edit no%:parent no%,Boite_date%:font_color no%,0,0,255
        width no%,40:top no%,17:left no%,135:color no%,240,240,255
no%=no%+1:BT_annee_modif%=no%:alpha no%:parent no%,Boite_date%
        font_name no%,"wingdings":font_size no%,14:caption no%,chr$(63):font_color no%,0,0,255
        top no%,16:left no%,175:hint no%," Modifier l'Année "
no%=no%+1:combo_mois%=no%:combo no%:parent no%,Boite_date%:color no%,240,240,255:font_color no%,0,0,255
        width no%,40:top no%,17:left no%,72
        for n%=1 to 12
          if n%<10 then item_add no%,"0"+str$(n%)
          if n%>9 then item_add no%,str$(n%)
        next n%
no%=no%+1:BT_mois_modif%=no%:alpha no%:parent no%,Boite_date%:hint no%," Modifier le Mois "
        font_name no%,"wingdings":font_size no%,14:caption no%,chr$(63):font_color no%,0,0,255
        top no%,16:left no%,110
no%=no%+1:combo_jour%=no%:combo no%:parent no%,Boite_date%:color no%,240,240,255:font_color no%,0,0,255
        width no%,40:top no%,17:left no%,5
no%=no%+1:BT_jour_modif%=no%:alpha no%:parent no%,Boite_date%:hint no%," Modifier le Jour "
        font_name no%,"wingdings":font_size no%,16:caption no%,chr$(63):font_color no%,0,0,255
        top no%,14:left no%,43
no%=no%+1:BT_Valid_date%=no%:alpha no%:parent no%,Boite_date%:' font_color no%,0,0,255
        font_name no%,"wingdings":font_size no%,19:caption no%,chr$(67):font_color no%,0,0,255
        top no%,15:left no%,200
End_Sub
' ---------------------------------------------------
Sub Ouvre_Boite(nobj%,W%,H%,T%,L%,T$,NbChr%,Num_Chr%)
width nobj%,W%:height nobj%,H%:top nobj%,T%:left nobj%,L%:cap$=T$:Align_Caption(nobj%,NbChr%,Num_Chr%,cap$):show nobj%
End_Sub
Sub Align_Caption(no%,nb%,numC%,cap$)
if nb%=0 then caption no%," "+cap$+" ":End_sub
cap$=string$(nb%,chr$(numC%))+cap$+string$(nb%,chr$(numC%))
caption no%," "+cap$+" "
End_Sub
' ------------------------------------------------------------------------------
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
papydall

avatar

Nombre de messages : 5508
Age : 67
Localisation : Moknine (Tunisie) Entre la chaise et le clavier
Date d'inscription : 03/03/2012

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 16:34

Merci Jean Claude.
Merci Pan59.

Jean Claude a écrit:

Une astuce que j'ai découverte sur gogol car je me demandait comment faisait Papydall pour obtenir "œ ou Œ" :
si tu tapes 0159 pendant que alt est enfoncée tu obtiens Ÿ
et c'est valable pour toutes les minuscules qui sont dans le code ci-dessus
gogol est un nombre qui vaut 10^100 et je ne crois pas qu’il ait pu te fournir l’astuce dont tu parles !

Jean Claude a écrit:
j'ai réinventé l'ouvre_boite Very Happy

Jolie boîte mais je n’y ai pas encore rentré dedans !
Ce n’est pas facile pour moi de la parcourir des yeux : des lignes un peu trop longues, plus le manque d’indentation, etc..
Mais au moins, elle est fonctionnelle, BRAVO !

Juste un dernier mot : quand on valide (en cliquant sur OK symbolisé par une jolie main) tout devient INACTIVE et plus moyen de changer d’avis !
Revenir en haut Aller en bas
Voir le profil de l'utilisateur http://papydall-panoramic.forumarabia.com/
Jean Claude

avatar

Nombre de messages : 4989
Age : 63
Localisation : 83 Var
Date d'inscription : 07/05/2009

MessageSujet: Re: Quelques SUBs, en vrac   Jeu 17 Jan 2013 - 17:55

Bonjour Papydall

D'accord pour l’indentation, mais tu peux toujours te servir du programme de JL35 ou de Nardo pour embellir le code.

Tous les objets de la boite sont désactivés à la sortie et c'est volontaire. Mais tu peux les réactiver en rappelant les procédures (ouvre_boite et saisie_date) par un bouton, regroupées dans un label "Saisie_Date" . Suivant ton code.

N’empêche que c'est grâce à ton sub accent_off que je me suis mis à chercher sur Google (gogol) la méthode pour entrer des Œ ou des majuscules accentuées.

A+
Revenir en haut Aller en bas
Voir le profil de l'utilisateur
Contenu sponsorisé




MessageSujet: Re: Quelques SUBs, en vrac   

Revenir en haut Aller en bas
 
Quelques SUBs, en vrac
Voir le sujet précédent Voir le sujet suivant Revenir en haut 
Page 1 sur 3Aller à la page : 1, 2, 3  Suivant
 Sujets similaires
-
» quelques ajouts
» Quelques mots sur moi
» Barre de navigation en haut et fixe : quelques soucis...
» quelques topics sont passé "en rouge"
» Quelques questions en CSS

Permission de ce forum:Vous ne pouvez pas répondre aux sujets dans ce forum
FORUM DE DISCUSSION SUR LE LANGAGE PANORAMIC :: PANORAMIC 32 bits :: Vos sources, vos utilitaires à partager-
Sauter vers: