Gestion et comptabilité possible avec PB

Partagez votre expérience de PureBasic avec les autres utilisateurs.
Répondre
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Gestion et comptabilité possible avec PB

Message par PAPIPP »

Bonjour à tous

Pour une bonne gestion le type flottant double précision est insuffisant
car on ne gère pas avec des règles d’arrondi parfaitement définies dans tout le processus soit d’une comptabilité soit d’une gestion rigoureuse.

Après quelques recherches sur DCB (décimal codé binaire) ou BCD (binaire codé décimal) je me suis rabattu sur la dll oleaut32.dll de microsoft.
Cette DLL est présente sur tous les systèmes windows soit en 32 bits soit en 64 bits.
Elle compte 398 routines sous XP qui permettent de travailler avec les ‘variants’ compatibles de VB.
Je me suis intéressé plus particulièrement au variant DECIMAL.

Structure DECIMAL.
Représente un type de données décimal qui fournit un signe et l'échelle d'un certain nombre (aussi en coordonnées.)
Des variables décimales sont stockées sous forme de 96 bits (12 octets) entiers non signés à l'échelle par une puissance variable de 10.
La puissance de 10 facteurs de mise à l'échelle spécifie le nombre de chiffres à droite de la virgule décimale, et varie de 0 à 28.
( voir la structure dans le PRG)

Pour obtenir les prototypes et procédures générés automatiquement avec le prg PureDLLHelper,
Copyright ©2012 de Thomas <ts-soft> Schulz http://www.realsource.de/downloads/doc_ ... edllhelper
Après téléchargement vous pouvez utiliser soit le PRG 32bits soit le PRG 64bits

Oleaut32.DLL est à base de chaines de caractères en binaire string (BSTR) qui est une sorte d’Unicode avec la longueur définie avant la chaine
Pour éviter de noyer le lecteur sous le nombre de routines je n’ai utilisé que les routines potentiellement utiles pour les calculs en DECIMAL

Voici à titre d’exemple les quatre opérations et une mise en forme des nombres de sortie
(virgule ou point) (Signe – ou parenthèses) (Blocs groupés par millier ou pas)
Pour montrer la précision obtenue j’ai comparé une division en DECIMAL avec une division en nombre flottant double précision.

Voici les macros utilisées dans le PRG

Code : Tout sélectionner

Macro _q_t_ ; cette macro génère chr(34) 
  "
EndMacro 
	 
	Macro _n (__n) ; cette macro associée à la précédente liste le nom de variable et son contenu en décimal 
	_q_t_#__n#=_q_t_+Str(__n)+" " ;  
	EndMacro 
	 
	Macro _B (__B,_pr="%") ; macro associée à la première liste le nom de variable et son contenu en binaire 
	_q_t_#__B#=_q_t_+_pr+Bin(__B)+" " 
	EndMacro 
	 
	Macro _f (__F,__nv=8) ; cette macro liste le nom de la variable et son contenu en simple précision  
	_q_t_#__F#=_q_t_+StrF(__f,__nv)+" "   
	EndMacro 
	 
	Macro _d (__D,__nv=8) ; ; macro associée à la première liste le nom de variable et son contenu en double précision  
	_q_t_#__D#=_q_t_+StrD(__D,__nv)+" " 
	EndMacro 
	 
	Macro _H (__H,__nv=#PB_Quad,_pr="$"); cette macro liste le nom de la variable et son contenu en Hexa  
	_q_t_#__H#=_q_t_+_pr+RSet(Hex(__H,__nv),__nv*4,"0")+" " 
	EndMacro 
	 
	Macro _s (__S) ; cette macro liste le nom de la variable et son contenu en alpha  
	_q_t_#__S#=_q_t_+__S+" " 
	EndMacro 
	 
	Macro _U (__U); cette macro liste le nom de la variable et son contenu en Unicode 
	_q_t_#__U#=_q_t_+StrU(__U)+" " 
	EndMacro 
	 
	Macro _NL; cette macro donne le N° de ligne là où elle est appelée. elle peut servir de trace ou de repère ou même de N° d’erreur 
	"N°L=" + Str(#PB_Compiler_Line) + " ** " 
	EndMacro 
	 
	Macro __nbc(__cc); cette macro recherché le nb de cycles machine pour optimiser le code 
	__cc.q 
	!RDTSC 
	!PUSH edx 
	!PUSH eax 
	!POP dword[v_#__cc] 
	!POP dword[v_#__cc+4] 
	EndMacro 
	 
	 
	Macro S_wap (a__,b__); cette macro swap les adresses de 2 tableaux identiques à partir de PB520 l car swap sur tableaux est KO 
	EnableASM 
	!pushd [a_#a__] [a_#b__] 
	!popd [a_#a__] [a_#b__] 
	DisableASM 
	EndMacro 
	 
	Macro _AN_BIS (x); cette macro définie si une année x est bissextile ou non  
	((Not((x%4)<>0)) & ((1-(Not((x%100)<>0)) ) | (Not(((x>>2)%100)<>0)) ) ) 
	EndMacro 

Macro _HL (__HL,_pr="$") 
	_q_t_#__HL#=_q_t_+_PR+RSet(Hex(PeekL(@__HL),#PB_Long),8,"0")+" " 
	EndMacro
Voici le PRG de calcul en DECIMAL

Code : Tout sélectionner

Global lcid.l=$40C   ; Français FR:FR $40C ou 1036 avec virgule  ou US US=> 1033 ou $409 pour utilisation avec  point 

Structure decimal Align #PB_Structure_AlignC
	wReserved.w
	scale.b ; nombre après la virgule
	sign.b  ; O signe positif 1 signe négatif
	hi32.l
	lo64.q
EndStructure
Structure bs
  lg.l
  tr.s{255}
EndStructure
Procedure.s PeekBSTR(*BSTR)
  lenBSTR=PeekL(*BSTR-4)/2
  Dim Char.c(lenBSTR)
  For i=0 To lenBSTR
    Char(i)=PeekC(*BSTR+i*2)
  Next i
  ProcedureReturn PeekS(@Char(0))
EndProcedure

;==========================================================================
; Generated with PureDLLHelper, Copyright ©2012 by Thomas <ts-soft> Schulz
;==========================================================================
Prototype SysAllocStringByteLen(a,b)
Prototype SysAllocString(a)
Prototype SysReAllocString(a,b)
Prototype SysAllocStringLen(a,b)
Prototype SysReAllocStringLen()
Prototype SysFreeString(a)
Prototype SysStringLen(a)
Prototype VariantInit(a)
Prototype VariantClear(a)
Prototype VariantCopy(a,b)
Prototype VariantCopyInd(a,b)

Prototype VarBstrFromUI1(a,b,c,d)
Prototype VarBstrFromI2(a,b,c,d)
Prototype VarBstrFromI4(a,b,c,d)
Prototype VarBstrFromR4(a,b,c,d)
Prototype VarBstrFromR8(a,b,c,d,e)
Prototype VarBstrFromCy(a,b,c,d)
Prototype VarBstrFromDate(a,b,c,d,e)
Prototype VarBstrFromDisp(a,b,c,d)
Prototype VarBstrFromBool(a,b,c,d)
Prototype VarBstrCat(a,b,c)
Prototype VarBstrFromDec(a,b,c,d)
Prototype VarBstrCmp(a,b,c,d)
Prototype VarBstrFromI8(a,b,c,d,e)
Prototype VarBstrFromUI8(a,b,c,d,e)

Prototype VarDecSub(a,b,c)
Prototype VarDecAbs(a,b)
Prototype VarDecAdd(a,b,c)
Prototype VarDecDiv(a,b,c)
Prototype VarDecMul(a,b,c)
Prototype VarDecFix(a,b)
Prototype VarDecInt(a,b)
Prototype VarDecNeg(a,b)
Prototype VarDecFromUI1(a,b)
Prototype VarDecFromI2(a,b)
Prototype VarDecFromI4(a,b)
Prototype VarDecFromR4(a,b)
Prototype VarDecFromR8(a.d,b)
Prototype VarDecFromDate(a,b,c)
Prototype VarDecFromCy(a,b)
Prototype VarDecFromStr(a,b,c,d)
Prototype VarDecFromDisp(a,b,c)
Prototype VarDecFromBool(a,b)
Prototype VarDecRound(a,b,c)
Prototype VarDecCmp(a,b)
Prototype VarDecFromI1(a,b)
Prototype VarDecFromUI2(a,b)
Prototype VarDecFromUI4(a,b)
Prototype VarDecCmpR8(a,b,c)

Prototype VarI2FromDec(a,b)
Prototype VarI4FromDec(a,b)
Prototype VarR4FromDec(a,b)
Prototype VarR8FromDec(a,b)
Prototype VarDateFromDec(a,b)
Prototype VarCyFromDec(a,b)
Prototype VarBoolFromDec(a,b)
Prototype VarUI1FromDec(a,b)
Prototype VarI1FromDec(a,b)
Prototype VarUI2FromDec(a,b)
Prototype VarUI4FromDec(a,b)
Prototype VarI8FromDec(a,b)
Prototype VarDecFromI8(a,b,c)
Prototype VarDecFromUI8(a,b,c)
Prototype VarUI8FromDec(a,b)
Prototype VarBstrFromI1(a,b,c,d)
Prototype VarBstrFromUI2(a,b,c,d)
Prototype VarBstrFromUI4(a,b,c,d)
Prototype VectorFromBstr(a,b)
Prototype BstrFromVector(a,b)
Prototype BSTR_UserSize(a,b,c)
Prototype BSTR_UserMarshal(a,b,c)
Prototype BSTR_UserUnmarshal(a,b,c)
Prototype BSTR_UserFree(a,b)
Prototype VarFormatNumber(a,b,c,d,e,f,g)
;************************* fin prototype *************************
Global VarDecAdd.VarDecAdd
Global VarDecDiv.VarDecDiv
Global VarDecMul.VarDecMul
Global VarDecSub.VarDecSub
Global VarDecAbs.VarDecAbs
Global VarDecFix.VarDecFix
Global VarDecInt.VarDecInt
Global VarDecNeg.VarDecNeg
Global VarDecFromUI1.VarDecFromUI1
Global VarDecFromI2.VarDecFromI2
Global VarDecFromI4.VarDecFromI4
Global VarDecFromR4.VarDecFromR4
Global VarDecFromR8.VarDecFromR8
Global VarDecFromDate.VarDecFromDate
Global VarDecFromCy.VarDecFromCy
Global VarDecFromStr.VarDecFromStr
Global VarDecFromDisp.VarDecFromDisp
Global VarDecFromBool.VarDecFromBool
Global VarDecRound.VarDecRound
Global VarDecCmp.VarDecCmp
Global VarDecFromUI2.VarDecFromUI2
Global VarDecFromUI4.VarDecFromUI4
Global VarDecCmpR8.VarDecCmpR8

Global VarI2FromDec.VarI2FromDec
Global VarI4FromDec.VarI4FromDec
Global VarR4FromDec.VarR4FromDec
Global VarR8FromDec.VarR8FromDec
Global VarDateFromDec.VarDateFromDec
Global VarCyFromDec.VarCyFromDec
Global VarBstrFromDec.VarBstrFromDec
Global VarBoolFromDec.VarBoolFromDec
Global VarUI1FromDec.VarUI1FromDec
Global VarDecFromI1.VarDecFromI1
Global VarI1FromDec.VarI1FromDec
Global VarUI2FromDec.VarUI2FromDec
Global VarUI4FromDec.VarUI4FromDec
Global VarI8FromDec.VarI8FromDec
Global VarDecFromI8.VarDecFromI8
Global VarDecFromUI8.VarDecFromUI8
Global VarUI8FromDec.VarUI8FromDec
Global SysAllocString.SysAllocString
Global SysReAllocString.SysReAllocString
Global SysAllocStringLen.SysAllocStringLen
Global SysReAllocStringLen.SysReAllocStringLen
Global SysFreeString.SysFreeString
Global SysStringLen.SysStringLen
Global VariantInit.VariantInit
Global VariantClear.VariantClear
Global VariantCopy.VariantCopy
Global VariantCopyInd.VariantCopyInd

Global VarBstrFromUI1.VarBstrFromUI1
Global VarBstrFromI2.VarBstrFromI2
Global VarBstrFromI4.VarBstrFromI4
Global VarBstrFromR4.VarBstrFromR4
Global VarBstrFromR8.VarBstrFromR8
Global VarBstrFromCy.VarBstrFromCy
Global VarBstrFromDate.VarBstrFromDate
Global VarBstrFromDisp.VarBstrFromDisp
Global VarBstrFromBool.VarBstrFromBool
Global VarBstrFromI1.VarBstrFromI1
Global VarBstrFromUI2.VarBstrFromUI2
Global VarBstrFromUI4.VarBstrFromUI4

Global BSTR_UserSize.BSTR_UserSize
Global BSTR_UserMarshal.BSTR_UserMarshal
Global BSTR_UserUnmarshal.BSTR_UserUnmarshal
Global BSTR_UserFree.BSTR_UserFree
Global VarBstrCat.VarBstrCat
Global VarBstrCmp.VarBstrCmp
Global VarBstrFromI8.VarBstrFromI8
Global VarBstrFromUI8.VarBstrFromUI8
Global VectorFromBstr.VectorFromBstr
Global BstrFromVector.BstrFromVector
Global VarFormatNumber.VarFormatNumber
Global SysAllocStringByteLen.SysAllocStringByteLen

Procedure.i oleaut32_LoadDLL()
  Protected hDLL.i
    If ExamineEnvironmentVariables()
      While NextEnvironmentVariable()
        If Trim(LCase(EnvironmentVariableName()))="systemroot"
;           Debug EnvironmentVariableValue()
          chem_syst$=EnvironmentVariableValue()
          EndIf
    Wend
  EndIf

  hDLL=OpenLibrary(#PB_Any,chem_syst$+"\system32\oleaut32.dll") ; **************  à changer suivant votre répertoire system *******
  If hDLL<>0
    SysAllocString=GetFunction(hDLL,"SysAllocString")
    SysReAllocString=GetFunction(hDLL,"SysReAllocString")
    SysAllocStringLen=GetFunction(hDLL,"SysAllocStringLen")
    SysReAllocStringLen=GetFunction(hDLL,"SysReAllocStringLen")
    SysFreeString=GetFunction(hDLL,"SysFreeString")
    SysStringLen=GetFunction(hDLL,"SysStringLen")
    VarBstrFromUI1=GetFunction(hDLL,"VarBstrFromUI1")
    VarBstrFromI2=GetFunction(hDLL,"VarBstrFromI2")
    VarBstrFromI4=GetFunction(hDLL,"VarBstrFromI4")
    VarBstrFromR4=GetFunction(hDLL,"VarBstrFromR4")
    VarBstrFromR8=GetFunction(hDLL,"VarBstrFromR8")
    VarBstrFromCy=GetFunction(hDLL,"VarBstrFromCy")
    VarBstrFromDate=GetFunction(hDLL,"VarBstrFromDate")
    VarBstrFromDisp=GetFunction(hDLL,"VarBstrFromDisp")
    VarBstrFromBool=GetFunction(hDLL,"VarBstrFromBool")
    SysAllocStringByteLen=GetFunction(hDLL,"SysAllocStringByteLen")
    VarDecSub=GetFunction(hDLL,"VarDecSub")
    VarDecAbs=GetFunction(hDLL,"VarDecAbs")
    VarDecAdd=GetFunction(hDLL,"VarDecAdd")
    VarDecDiv=GetFunction(hDLL,"VarDecDiv")
    VarDecMul=GetFunction(hDLL,"VarDecMul")
    VarDecFix=GetFunction(hDLL,"VarDecFix")
    VarDecInt=GetFunction(hDLL,"VarDecInt")
    VarDecNeg=GetFunction(hDLL,"VarDecNeg")
    VarDecFromUI1=GetFunction(hDLL,"VarDecFromUI1")
    VarDecFromI2=GetFunction(hDLL,"VarDecFromI2")
    VarDecFromI4=GetFunction(hDLL,"VarDecFromI4")
    VarDecFromR4=GetFunction(hDLL,"VarDecFromR4")
    VarDecFromR8=GetFunction(hDLL,"VarDecFromR8")
    VarDecFromDate=GetFunction(hDLL,"VarDecFromDate")
    VarDecFromCy=GetFunction(hDLL,"VarDecFromCy")
    VarDecFromStr=GetFunction(hDLL,"VarDecFromStr")
    VarDecFromDisp=GetFunction(hDLL,"VarDecFromDisp")
    VarDecFromBool=GetFunction(hDLL,"VarDecFromBool")
    VarDecRound=GetFunction(hDLL,"VarDecRound")
    VarDecCmp=GetFunction(hDLL,"VarDecCmp")
    VarI2FromDec=GetFunction(hDLL,"VarI2FromDec")
    VarI4FromDec=GetFunction(hDLL,"VarI4FromDec")
    VarR4FromDec=GetFunction(hDLL,"VarR4FromDec")
    VarR8FromDec=GetFunction(hDLL,"VarR8FromDec")
    VarDateFromDec=GetFunction(hDLL,"VarDateFromDec")
    VarCyFromDec=GetFunction(hDLL,"VarCyFromDec")
    VarBstrFromDec=GetFunction(hDLL,"VarBstrFromDec")
    VarBoolFromDec=GetFunction(hDLL,"VarBoolFromDec")
    VarUI1FromDec=GetFunction(hDLL,"VarUI1FromDec")
    VarDecFromI1=GetFunction(hDLL,"VarDecFromI1")
    VarDecFromUI2=GetFunction(hDLL,"VarDecFromUI2")
    VarDecFromUI4=GetFunction(hDLL,"VarDecFromUI4")
    VarI1FromDec=GetFunction(hDLL,"VarI1FromDec")
    VarUI2FromDec=GetFunction(hDLL,"VarUI2FromDec")
    VarUI4FromDec=GetFunction(hDLL,"VarUI4FromDec")
    VarDecCmpR8=GetFunction(hDLL,"VarDecCmpR8")
    VarI8FromDec=GetFunction(hDLL,"VarI8FromDec")
    VarDecFromI8=GetFunction(hDLL,"VarDecFromI8")
    VarDecFromUI8=GetFunction(hDLL,"VarDecFromUI8")
    VarUI8FromDec=GetFunction(hDLL,"VarUI8FromDec")
    BSTR_UserSize=GetFunction(hDLL,"BSTR_UserSize")
    BSTR_UserMarshal=GetFunction(hDLL,"BSTR_UserMarshal")
    BSTR_UserUnmarshal=GetFunction(hDLL,"BSTR_UserUnmarshal")
    BSTR_UserFree=GetFunction(hDLL,"BSTR_UserFree")
    GetErrorInfo=GetFunction(hDLL,"GetErrorInfo")
    SetErrorInfo=GetFunction(hDLL,"SetErrorInfo")
    CreateErrorInfo=GetFunction(hDLL,"CreateErrorInfo")
    VarBstrFromI1=GetFunction(hDLL,"VarBstrFromI1")
    VarBstrFromUI2=GetFunction(hDLL,"VarBstrFromUI2")
    VarBstrFromUI4=GetFunction(hDLL,"VarBstrFromUI4")
    VarBstrCat=GetFunction(hDLL,"VarBstrCat")
    VarBstrCmp=GetFunction(hDLL,"VarBstrCmp")
    VarBstrFromI8=GetFunction(hDLL,"VarBstrFromI8")
    VarBstrFromUI8=GetFunction(hDLL,"VarBstrFromUI8")
    VectorFromBstr=GetFunction(hDLL,"VectorFromBstr")
    BstrFromVector=GetFunction(hDLL,"BstrFromVector")
    VarFormatNumber=GetFunction(hDLL,"VarFormatNumber")
    
    ProcedureReturn hDLL
  EndIf
  
  ProcedureReturn #False
EndProcedure



Procedure AnsiTOBStr(string$) ; By Zapman Inspired by Fr34k
	Protected Unicode$=Space(Len(String$)*2+2)
	Protected bstr_string.l
	PokeS(@Unicode$,String$,-1,#PB_Unicode)
	bstr_string=SysAllocString_(@Unicode$)
	ProcedureReturn bstr_string
EndProcedure

Procedure.s ReadBstr(*String) ; By Fr34k
	Result$=""
	If *String
		length.l=WideCharToMultiByte_(#CP_ACP,0,*String,-1,0,0,0,0)
		*Buffer=AllocateMemory(length)
		
		If *Buffer
			WideCharToMultiByte_(#CP_ACP,0,*String,-1,*Buffer,length,0,0)
			Result$=PeekS(*Buffer)
			FreeMemory(*Buffer)
		EndIf
	EndIf
	ProcedureReturn Result$
EndProcedure
Procedure AnsitoDEC(cAnsi.s,dy)
  Bstr0=AnsiTOBstr(cAnsi)
  VarDecFromStr(Bstr0,lcid,#LOCALE_NOUSEROVERRIDE,dy)
EndProcedure
Procedure.s DECtoAnsi(dy)
  Bstr0=AnsiTOBstr(Space(255))
  VarBstrFromDec(dy,lcid,#LOCALE_NOUSEROVERRIDE,Bstr0)
  ProcedureReturn ReadBstr(PeekL(bstr0))
EndProcedure
dll_ole.l=oleaut32_LoadDLL()
;
Debug dll_ole
Define.decimal x,y,z,Dx,Dy,Dz,Du,Dv,dnx,dny,dnz,rx,ry,rz,Da,DB,Dc,DD,De
Define.w DW
Define.l bstr,bstr2
Define.q cy,Cz
Define a.bs,B.bs,c.bs,d.bs,e.bs


lcid=$409   ; US US 
Vdpis.s="-3,14159265358979323846264338327" ; cette valeur avec virgule prise sur calc est plus prècise que la constante #pi
VDpi1000.s="-314159,265358979323846264"
Gosub essaipi
lcid=$40C  ; FR,FR
;  Vdpis.s="-3.14159265358979323846264338327" ; cette valeur avec point prise sur calc est plus prècise que la constante #pi
;  VDpi1000.s="-314159.265358979323846"
 Gosub essaipi
; *************** comparaison entre Dec et float double *************
For J=1 To 5
Vdr.d=j
AnsitoDEC(Str(j),dy)
Debug "**********"+_n(j)
For i=1 To 30
  vdd.d=j/i
  vdr.d=vdd/i
    AnsitoDEC(Str(i),dx)
    vardecdiv(dy,dx,dz)
    vardecdiv(dz,dx,dnz)
  Debug _n(i)+"  "+_d(vdd,18)+LSet(" DEC="+DECtoAnsi(dz), 33 ," ")+" "+_d(vdr,18)+LSet(" DEC="+DECtoAnsi(dnz),33," ")
Next
Next

End
;************************************************************************************************************************************
;************************* subroutine avec format (point ou virgule) (signe ou parenthèse) (bloc par millier ou pas) ****************
;************************************************************************************************************************************

;************* soit avec virgule lcid=$40C pour FR  soit avec  point à la place de la virgule  avec lcid=$409 pour US **********************************************
essaipi:
If lcid=$40C
  vdpis=ReplaceString(vdpis, ".", "," )
  VDpi1000=ReplaceString(vdpi1000, ".", "," )
 Else 
   vdpis=ReplaceString(vdpis, ",", "." )
   vdpi1000=ReplaceString(vdpi1000, ",", "." )
EndIf
posv.l=FindString(vdpis, "," ) 
posp.l=FindString(vdpis, "." ) 
posv10.l=FindString(vdpi1000, "," ) 
posp10.l=FindString(vdpi1000, "." ) 

Debug _nl+_n(posv)+_n(posp)+_n(posv10)+_n(posp10)+_hl(lcid)
AnsitoDEC(vdpis,dnx)
Debug Space(12)+_s(vdpis)
Debug Space(15)+_d(#PI,18); #pi est toujours défini avec un point
Debug "decimal PI après= "+DECtoAnsi(dnx)
vardecmul(dnx,dnx,dny)
Debug "decimal PI*PI après= "+dectoansi(dny)
VarDecRound(dny,4,dnz)
Debug "decimal round4 PI*PI après= "+dectoansi(dnz)
vardecsub(dny,dnx,dy)
Debug "decimal PI*PI après= "+dectoansi(dy)
VarDecRound(dy,6,dnz)
Debug "decimal round 6 PI*PI-PI après= "+dectoansi(dnz)
vardecadd(dy,dnx,ry)
Debug "decimal PI*PI-PI+PI après= "+dectoansi(ry)
VarDecRound(ry,6,dnz)
Debug "decimal round 6 PI*PI-PI+PI après= "+dectoansi(dnz)


;******************************************* FORMAT essai ***********************************
; VarFormatNumber function This topic has Not yet been rated-Rate this topic
;
; Formats a variant containing numbers INTO a string form.
; Syntax C++ HRESULT VarFormatNumber(_In_ LPVARIANT pvarIn,_In_ INT iNumDig,_In_ INT iIncLead,_In_ INT iUseParens,_In_ INT iGroup,_In_ ULONG dwFlags,_Out_ BSTR*pbstrOut);
;
; Parameters
; pvarIn[IN] The variant containing the value To format.
; iNumDig[IN] The number of digits To pad To after the decimal point.Specify-1 To use the system Default value.
; iIncLead[IN]  Specifies whether To include the leading digit on numbers.
;   Value	Meaning
;   -2  Use the system Default.
;   -1  Include the leading digit.
;    0  Do Not include the leading digit.
; iUseParens[IN]  Specifies whether negative numbers should use parentheses.
;   Value	Meaning
;   -2 Use the system Default.
;   -1   Use parentheses.
;    0   Do Not use parentheses.
; iGroup[IN]  Specifies whether thousands should be grouped. For example 10,000 versus 10000.
;     Note Regular numbers And currencies have separate system defaults For all the above options.
;       Value	Meaning
;       -2	    Use the system Default.
;       -1     Group thousands.
;        0     Do Not group thousands.
; dwFlags[IN]      VAR_CALENDAR_HIJRI is the only flag that can be set.
; pbstrOut[OUT]    Points To the formatted string that represents the variant.
;
; Return value
; This function can Return one of these values.
; Return code	Description
; S_OK                     Success.
; E_INVALIDARG       One Or more of the arguments is Not valid.
AnsitoDEC(vdpi1000,rx)
pi1000.s=dectoansi(rx)
Debug _s(pi1000)
bstr2=SysAllocString(@vdpi1000)
resul=VarFormatNumber(rx,-1,-2,-2,-2,0,bstr2)
; Debug _n(ry\hi32)+_n(ry\lo64)+_n(ry\sign)
Debug _n(resul)
Debug("decimal PI Format = "+ReadBstr(PeekL(bstr2)))+" toujours avec virgule car la fonction tient compte de la région"
Debug "                                            options régionales et linguistiques dans le panneau de configuration"
resul=VarFormatNumber(rx,6,-2,-1,-2,0,bstr2)
Debug _n(resul)
Debug("decimal PI Format () = "+ReadBstr(PeekL(bstr2)))+" avec parenthèses pour les nombres négatifs"

Debug "*************** fin 1 ****************"
Return
Si vous désirez utiliser une fonction présente dans la DLL il faut connaître le nombre et le type des paramètres de cette fonction.
Ils sont présentés dans la doc Microsoft utilisable en recherchant dans Google "Microsoft nom de la fonction"

Ps il existe une lib oleaut32.lib dans la librairie de PB mais celle-ci est incomplète c’est pourquoi j’ai utilisé la DLL présente sur tous les systèmes windows
A+
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Haut
Avatar de l’utilisateur
Ar-S
Messages : 9478
Inscription : dim. 09/oct./2005 16:51
Contact :
Contacter Ar-S

Re: Gestion et comptabilité possible avec PB

Message par Ar-S »

Merci pour le partage, un bon gros boulot de fait.
~~~~Règles du forum ~~~~
⋅.˳˳.⋅ॱ˙˙ॱ⋅.˳Ar-S ˳.⋅ॱ˙˙ॱ⋅.˳˳.⋅
W11x64 PB 6.x
Section HORS SUJET : ICI
LDV MULTIMEDIA : Dépannage informatique & mes Logiciels PB
UPLOAD D'IMAGES : Uploader des images de vos logiciels
Haut
Backup
Messages : 14526
Inscription : lun. 26/avr./2004 0:40

Re: Gestion et comptabilité possible avec PB

Message par Backup »

oui bien cool cependant .....

change le titre de ton message , car dans l'avenir , quelqu'un qui va chercher le fameux code qui permet
d'utiliser des grands nombres

ne pensera surement pas que le message titré "Gestion et comptabilité possible avec PB"
correspond a ce qu'il cherche ... :roll: :D

pensez a utilisez des titres explicites .... pour la recherche dans 1 ou 2 ans , c'est utile :)

Merci pour le code
Haut
Avatar de l’utilisateur
kernadec
Messages : 1594
Inscription : ven. 25/avr./2008 11:14

Re: Gestion et comptabilité possible avec PB

Message par kernadec »

bonjour PAPIPP

Merci pour le partage. :)
Et cela va bien me servir trop cool :)

Cordialement
Haut
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Re: Gestion et comptabilité possible avec PB

Message par PAPIPP »

Bonjour Dobro

Ta remarque est intéressante si on ne mettait l’accent que sur la précision.
Mais un bon logiciel de compta ne doit pas seulement être précis.
On doit pouvoir gérer les arrondis en fonction de la précision (nombre de décimales désirées)
De plus l’on doit pouvoir indépendamment de l’opération d’’arrondi définir à son gré le nombre de décimale que l’on désire.(Format par exemple)
Enfin il ne faut pas oublier le contrôle sur toutes les opérations (Dépassement de capacité, opérateur non conforme)
Je ne les ai pas testé dans l'essai ci_dessus pour alléger le PRG
C’est le cas des routines de la DLL de Microsoft.
C’est pourquoi j’ai intitulé ce titre qui n’est peut-être pas le meilleur


A+
Dernière modification par PAPIPP le jeu. 21/nov./2013 23:33, modifié 1 fois.
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Haut
Backup
Messages : 14526
Inscription : lun. 26/avr./2004 0:40

Re: Gestion et comptabilité possible avec PB

Message par Backup »

c'est surtout 2 choses

1- je n'avais pas lu ""Gestion et comptabilité possible avec PB"
mais "Gestion et compatibilité possible avec PB" ....

une contrepétrie est donc possible, surtout sur un forum de programmeur ou l'on parle plus souvent de
compatibilité plutot que de comptabilité

mon oeil est peut etre deformé a force .. :)
d'ou ma premiere réaction concernant le titre ...
Et ....

2- vu qu'il s'agit d'une librairie concernant la précision sur les grands nombre ... entre autre
et que nous sommes sur un forum de "programmeurs" nous sommes amené a utiliser ce genre de lib sur des programmes aussi divers que varié
(jeux,simulations,analyses,etc.... et ...aussi bien sur comptabilité
(bien que plus rarement .. les sujets concernant ce milieux etant plutôt rares ...sur notre forum ... )
que j'en suis venu a lire compatibilité au lieu de comptabilité :lol:

je me suis dit , qu'un titre genre "grand nombre avec PB" ou bien "PB et une grande précision" ...bref un titre non lié a un sujet rare
comme comptabilité sur notre forum , aurait peut etre été plus judicieux ...

mais je te remercie encore pour le partage ,n'y voit pas une volonté de t'agacer outre mesure :)
Haut
PAPIPP
Messages : 534
Inscription : sam. 23/févr./2008 17:58

Re: Gestion et comptabilité possible avec PB

Message par PAPIPP »

Bonjour à tous

Voici un exemple d’utilisation plus fonctionnel et plus simple de la DLL oleaut32.dll de Microsoft
Cet exemple tient compte des contrôles.
Et ajoute une procédure de format de sortie des nombres (Dec2AnsiFormat) en sortie plus souple que la
Première (DectoAnsiFormat)

Utilisez les macros définies ci-dessus

Code : Tout sélectionner

Global lcid.l=$40C   ; Français FR:FR $40C ou 1036 avec virgule  ou US US=> 1033 ou $409 pour utilisation avec  point 
Structure decimal Align #PB_Structure_AlignC
		wReserved.w
		scale.b ; nombre après la virgule
		sign.b  ; O signe positif 1 signe négatif
		hi32.l
		lo64.q
EndStructure
Structure bs
	lg.l
	tr.s{255}
EndStructure
Procedure NumErreur(erreur.l,Nlg.s,OPT=0)
  Static flag
  If flag=0
    Structure Err
      name.s{45}
      Nom.s{45}
    EndStructure
    Global NewMap errmap.ERR()
    Global ERRD.l, Perrd

    OpenConsole("erreur à l'exécution")
    EnableGraphicalConsole(0)
    ConsoleLocate(0,0)
    ;  ConsoleTitle("essai ASM")
      errmap("00000000")\Nom="Opération réussie"
      errmap()\name="Operation successful"
      
      errmap("80004001")\Nom="Non implémenté"
      errmap()\name="Not implemented"
      
      errmap("80004002")\Nom="Aucune interface pris en charge"
      errmap()\name="No such Interface supported"
      
      errmap("80004003")\Nom="Pointeur non valide"
      errmap()\name="Pointer that is Not valid"
      
      errmap("80004004")\Nom="Opération annulée"
      errmap()\name="Operation aborted"
      
      errmap("80004005")\Nom="Echec non spécifié"
      errmap()\name="Unspecified failure"
      
      errmap("8000FFFF")\Nom="Défaillance inattendue"
      errmap()\name="Unexpected failure"
      
      errmap("80070005")\Nom="Accès général refusé erreur"
      errmap()\name="General access denied error"
      
      errmap("80070006")\Nom="Handle qui n'est pas valide"
      errmap()\name="Handle that is Not valid"
      
      errmap("8007000E")\Nom="Impossible d'allouer la mémoire nécessaire"
      errmap()\name="Failed To allocate necessary memory"
      
      errmap("80070057")\Nom="Un ou plusieurs arguments ne sont pas valides"
      errmap()\name="One Or more arguments are Not valid"
      ; **********  tout n'est pas  traduit ************
      errmap("80020001")\nom="UNKNOWNINTERFACE	Unknown Interface"
      errmap("80020003")\nom="MEMBERNOTFOUND	Member Not found"
      errmap("80020004")\nom="PARAMNOTFOUND	Parameter Not found"
      errmap("80020005")\nom="TYPEMISMATCH	Type mismatch"
      errmap("80020006")\nom="UNKNOWNNAME	Unknown name"
      errmap("80020007")\nom="NONAMEDARGS	No named arguments"
      errmap("80020008")\nom="BADVARTYPE	Bad variable type"
      errmap("80020009")\nom="EXCEPTION	Exception occurred"
      
      errmap("8002000A")\name="OVERFLOW	OUT of present range"
      errmap("8002000A")\Nom="Hors de la zone prévue"
      
      errmap("8002000B")\nom="BADINDEX	Invalid index"
      errmap("8002000C")\nom="UNKNOWNLCID	Unknown language"
      errmap("8002000D")\nom="ARRAYISLOCKED	Memory is locked"
      errmap("8002000E")\nom="BADPARAMCOUNT	Invalid number of parameters"
      errmap("8002000F")\nom="PARAMNOTOPTIONAL	Parameter Not optional"
      errmap("80020010")\nom="BADCALLEE	Invalid callee"
      errmap("80020011")\nom="NOTACOLLECTION	Does Not support a collection"
      errmap("80020012")\nom="DIVBYZERO	Division by zero"
      errmap("80020013")\nom="BUFFERTOOSMALL	Buffer too small"
      ; ; errmap("80028016 TYPE_E_BUFFERTOOSMALL	Buffer too small"
      ; ; errmap("80028017 TYPE_E_FIELDNOTFOUND	Field name Not defined IN the record"
      ; ; errmap("80028018 TYPE_E_INVDATAREAD	Old format Or invalid type library"

      flag=1
    EndIf
    If opt=0 And erreur=0
      ProcedureReturn 
    EndIf 
    ;   errh.s=Hex(erreur,#PB_Quad)
    errh.s=RSet(Hex(erreur,#PB_Long),8,"0")
    nom$=errmap(errh)\Nom
    Debug nlg+" erreur="+errh+" "+nom$
    perrd=1
    CharToOem_(@nom$,@nom$)
    PrintN(nlg+" erreur="+errh+" "+nom$+" "+_h(erreur))
  EndProcedure

; Procedure.s PeekBSTR(*BSTR)
; 	lenBSTR=PeekL(*BSTR-4)/2
; 	Dim Char.c(lenBSTR)
; 	For i=0 To lenBSTR
; 		Char(i)=PeekC(*BSTR+i*2)
; 	Next i
; 	ProcedureReturn PeekS(@Char(0))
; EndProcedure

;==========================================================================
; Generated with PureDLLHelper, Copyright ©2012 by Thomas <ts-soft> Schulz
;==========================================================================
Prototype SysAllocStringByteLen(a,b)
Prototype SysAllocString(a)
Prototype SysReAllocString(a,b)
Prototype SysAllocStringLen(a,b)
Prototype SysReAllocStringLen()
Prototype SysFreeString(a)
Prototype SysStringLen(a)
Prototype VariantInit(a)
Prototype VariantClear(a)
Prototype VariantCopy(a,b)
Prototype VariantCopyInd(a,b)

Prototype VarBstrFromUI1(a,b,c,d)
Prototype VarBstrFromI2(a,b,c,d)
Prototype VarBstrFromI4(a,b,c,d)
Prototype VarBstrFromR4(a,b,c,d)
Prototype VarBstrFromR8(a,b,c,d,e)
Prototype VarBstrFromCy(a,b,c,d)
Prototype VarBstrFromDate(a,b,c,d,e)
Prototype VarBstrFromDisp(a,b,c,d)
Prototype VarBstrFromBool(a,b,c,d)
Prototype VarBstrCat(a,b,c)
Prototype VarBstrFromDec(a,b,c,d)
Prototype VarBstrCmp(a,b,c,d)
Prototype VarBstrFromI8(a,b,c,d,e)
Prototype VarBstrFromUI8(a,b,c,d,e)

Prototype VarDecSub(a,b,c)
Prototype VarDecAbs(a,b)
Prototype VarDecAdd(a,b,c)
Prototype VarDecDiv(a,b,c)
Prototype VarDecMul(a,b,c)
Prototype VarDecFix(a,b)
Prototype VarDecInt(a,b)
Prototype VarDecNeg(a,b)
Prototype VarDecFromUI1(a,b)
Prototype VarDecFromI2(a,b)
Prototype VarDecFromI4(a,b)
Prototype VarDecFromR4(a,b)
Prototype VarDecFromR8(a.d,b)
Prototype VarDecFromDate(a,b,c)
Prototype VarDecFromCy(a,b)
Prototype VarDecFromStr(a,b,c,d)
Prototype VarDecFromDisp(a,b,c)
Prototype VarDecFromBool(a,b)
Prototype VarDecRound(a,b,c)
Prototype VarDecCmp(a,b)
Prototype VarDecFromI1(a,b)
Prototype VarDecFromUI2(a,b)
Prototype VarDecFromUI4(a,b)
Prototype VarDecCmpR8(a,b,c)

Prototype VarI2FromDec(a,b)
Prototype VarI4FromDec(a,b)
Prototype VarR4FromDec(a,b)
Prototype VarR8FromDec(a,b)
Prototype VarDateFromDec(a,b)
Prototype VarCyFromDec(a,b)
Prototype VarBoolFromDec(a,b)
Prototype VarUI1FromDec(a,b)
Prototype VarI1FromDec(a,b)
Prototype VarUI2FromDec(a,b)
Prototype VarUI4FromDec(a,b)
Prototype VarI8FromDec(a,b)
Prototype VarDecFromI8(a,b,c)
Prototype VarDecFromUI8(a,b,c)
Prototype VarUI8FromDec(a,b)
Prototype VarBstrFromI1(a,b,c,d)
Prototype VarBstrFromUI2(a,b,c,d)
Prototype VarBstrFromUI4(a,b,c,d)
Prototype VectorFromBstr(a,b)
Prototype BstrFromVector(a,b)
Prototype BSTR_UserSize(a,b,c)
Prototype BSTR_UserMarshal(a,b,c)
Prototype BSTR_UserUnmarshal(a,b,c)
Prototype BSTR_UserFree(a,b)
Prototype VarFormatNumber(a,b,c,d,e,f,g)
;************************* fin prototype *************************
Global VarDecAdd.VarDecAdd
Global VarDecDiv.VarDecDiv
Global VarDecMul.VarDecMul
Global VarDecSub.VarDecSub
Global VarDecAbs.VarDecAbs
Global VarDecFix.VarDecFix
Global VarDecInt.VarDecInt
Global VarDecNeg.VarDecNeg
Global VarDecFromUI1.VarDecFromUI1
Global VarDecFromI2.VarDecFromI2
Global VarDecFromI4.VarDecFromI4
Global VarDecFromR4.VarDecFromR4
Global VarDecFromR8.VarDecFromR8
Global VarDecFromDate.VarDecFromDate
Global VarDecFromCy.VarDecFromCy
Global VarDecFromStr.VarDecFromStr
Global VarDecFromDisp.VarDecFromDisp
Global VarDecFromBool.VarDecFromBool
Global VarDecRound.VarDecRound
Global VarDecCmp.VarDecCmp
Global VarDecFromUI2.VarDecFromUI2
Global VarDecFromUI4.VarDecFromUI4
Global VarDecCmpR8.VarDecCmpR8

Global VarI2FromDec.VarI2FromDec
Global VarI4FromDec.VarI4FromDec
Global VarR4FromDec.VarR4FromDec
Global VarR8FromDec.VarR8FromDec
Global VarDateFromDec.VarDateFromDec
Global VarCyFromDec.VarCyFromDec
Global VarBstrFromDec.VarBstrFromDec
Global VarBoolFromDec.VarBoolFromDec
Global VarUI1FromDec.VarUI1FromDec
Global VarDecFromI1.VarDecFromI1
Global VarI1FromDec.VarI1FromDec
Global VarUI2FromDec.VarUI2FromDec
Global VarUI4FromDec.VarUI4FromDec
Global VarI8FromDec.VarI8FromDec
Global VarDecFromI8.VarDecFromI8
Global VarDecFromUI8.VarDecFromUI8
Global VarUI8FromDec.VarUI8FromDec
Global SysAllocString.SysAllocString
Global SysReAllocString.SysReAllocString
Global SysAllocStringLen.SysAllocStringLen
Global SysReAllocStringLen.SysReAllocStringLen
Global SysFreeString.SysFreeString
Global SysStringLen.SysStringLen
Global VariantInit.VariantInit
Global VariantClear.VariantClear
Global VariantCopy.VariantCopy
Global VariantCopyInd.VariantCopyInd

Global VarBstrFromUI1.VarBstrFromUI1
Global VarBstrFromI2.VarBstrFromI2
Global VarBstrFromI4.VarBstrFromI4
Global VarBstrFromR4.VarBstrFromR4
Global VarBstrFromR8.VarBstrFromR8
Global VarBstrFromCy.VarBstrFromCy
Global VarBstrFromDate.VarBstrFromDate
Global VarBstrFromDisp.VarBstrFromDisp
Global VarBstrFromBool.VarBstrFromBool
Global VarBstrFromI1.VarBstrFromI1
Global VarBstrFromUI2.VarBstrFromUI2
Global VarBstrFromUI4.VarBstrFromUI4

Global BSTR_UserSize.BSTR_UserSize
Global BSTR_UserMarshal.BSTR_UserMarshal
Global BSTR_UserUnmarshal.BSTR_UserUnmarshal
Global BSTR_UserFree.BSTR_UserFree
Global VarBstrCat.VarBstrCat
Global VarBstrCmp.VarBstrCmp
Global VarBstrFromI8.VarBstrFromI8
Global VarBstrFromUI8.VarBstrFromUI8
Global VectorFromBstr.VectorFromBstr
Global BstrFromVector.BstrFromVector
Global VarFormatNumber.VarFormatNumber
Global SysAllocStringByteLen.SysAllocStringByteLen

Procedure.i oleaut32_LoadDLL()
	Protected hDLL.i
		If ExamineEnvironmentVariables()
			While NextEnvironmentVariable()
				If Trim(LCase(EnvironmentVariableName()))="systemroot"
;           Debug EnvironmentVariableValue()
					chem_syst$=EnvironmentVariableValue()
					EndIf
		Wend
	EndIf

	hDLL=OpenLibrary(#PB_Any,chem_syst$+"\system32\oleaut32.dll") ; **************  à changer suivant votre répertoire system *******
	If hDLL<>0
		SysAllocString=GetFunction(hDLL,"SysAllocString")
		SysReAllocString=GetFunction(hDLL,"SysReAllocString")
		SysAllocStringLen=GetFunction(hDLL,"SysAllocStringLen")
		SysReAllocStringLen=GetFunction(hDLL,"SysReAllocStringLen")
		SysFreeString=GetFunction(hDLL,"SysFreeString")
		SysStringLen=GetFunction(hDLL,"SysStringLen")
		VarBstrFromUI1=GetFunction(hDLL,"VarBstrFromUI1")
		VarBstrFromI2=GetFunction(hDLL,"VarBstrFromI2")
		VarBstrFromI4=GetFunction(hDLL,"VarBstrFromI4")
		VarBstrFromR4=GetFunction(hDLL,"VarBstrFromR4")
		VarBstrFromR8=GetFunction(hDLL,"VarBstrFromR8")
		VarBstrFromCy=GetFunction(hDLL,"VarBstrFromCy")
		VarBstrFromDate=GetFunction(hDLL,"VarBstrFromDate")
		VarBstrFromDisp=GetFunction(hDLL,"VarBstrFromDisp")
		VarBstrFromBool=GetFunction(hDLL,"VarBstrFromBool")
		SysAllocStringByteLen=GetFunction(hDLL,"SysAllocStringByteLen")
		VarDecSub=GetFunction(hDLL,"VarDecSub")
		VarDecAbs=GetFunction(hDLL,"VarDecAbs")
		VarDecAdd=GetFunction(hDLL,"VarDecAdd")
		VarDecDiv=GetFunction(hDLL,"VarDecDiv")
		VarDecMul=GetFunction(hDLL,"VarDecMul")
		VarDecFix=GetFunction(hDLL,"VarDecFix")
		VarDecInt=GetFunction(hDLL,"VarDecInt")
		VarDecNeg=GetFunction(hDLL,"VarDecNeg")
		VarDecFromUI1=GetFunction(hDLL,"VarDecFromUI1")
		VarDecFromI2=GetFunction(hDLL,"VarDecFromI2")
		VarDecFromI4=GetFunction(hDLL,"VarDecFromI4")
		VarDecFromR4=GetFunction(hDLL,"VarDecFromR4")
		VarDecFromR8=GetFunction(hDLL,"VarDecFromR8")
		VarDecFromDate=GetFunction(hDLL,"VarDecFromDate")
		VarDecFromCy=GetFunction(hDLL,"VarDecFromCy")
		VarDecFromStr=GetFunction(hDLL,"VarDecFromStr")
		VarDecFromDisp=GetFunction(hDLL,"VarDecFromDisp")
		VarDecFromBool=GetFunction(hDLL,"VarDecFromBool")
		VarDecRound=GetFunction(hDLL,"VarDecRound")
		VarDecCmp=GetFunction(hDLL,"VarDecCmp")
		VarI2FromDec=GetFunction(hDLL,"VarI2FromDec")
		VarI4FromDec=GetFunction(hDLL,"VarI4FromDec")
		VarR4FromDec=GetFunction(hDLL,"VarR4FromDec")
		VarR8FromDec=GetFunction(hDLL,"VarR8FromDec")
		VarDateFromDec=GetFunction(hDLL,"VarDateFromDec")
		VarCyFromDec=GetFunction(hDLL,"VarCyFromDec")
		VarBstrFromDec=GetFunction(hDLL,"VarBstrFromDec")
		VarBoolFromDec=GetFunction(hDLL,"VarBoolFromDec")
		VarUI1FromDec=GetFunction(hDLL,"VarUI1FromDec")
		VarDecFromI1=GetFunction(hDLL,"VarDecFromI1")
		VarDecFromUI2=GetFunction(hDLL,"VarDecFromUI2")
		VarDecFromUI4=GetFunction(hDLL,"VarDecFromUI4")
		VarI1FromDec=GetFunction(hDLL,"VarI1FromDec")
		VarUI2FromDec=GetFunction(hDLL,"VarUI2FromDec")
		VarUI4FromDec=GetFunction(hDLL,"VarUI4FromDec")
		VarDecCmpR8=GetFunction(hDLL,"VarDecCmpR8")
		VarI8FromDec=GetFunction(hDLL,"VarI8FromDec")
		VarDecFromI8=GetFunction(hDLL,"VarDecFromI8")
		VarDecFromUI8=GetFunction(hDLL,"VarDecFromUI8")
		VarUI8FromDec=GetFunction(hDLL,"VarUI8FromDec")
		BSTR_UserSize=GetFunction(hDLL,"BSTR_UserSize")
		BSTR_UserMarshal=GetFunction(hDLL,"BSTR_UserMarshal")
		BSTR_UserUnmarshal=GetFunction(hDLL,"BSTR_UserUnmarshal")
		BSTR_UserFree=GetFunction(hDLL,"BSTR_UserFree")
		GetErrorInfo=GetFunction(hDLL,"GetErrorInfo")
		SetErrorInfo=GetFunction(hDLL,"SetErrorInfo")
		CreateErrorInfo=GetFunction(hDLL,"CreateErrorInfo")
		VarBstrFromI1=GetFunction(hDLL,"VarBstrFromI1")
		VarBstrFromUI2=GetFunction(hDLL,"VarBstrFromUI2")
		VarBstrFromUI4=GetFunction(hDLL,"VarBstrFromUI4")
		VarBstrCat=GetFunction(hDLL,"VarBstrCat")
		VarBstrCmp=GetFunction(hDLL,"VarBstrCmp")
		VarBstrFromI8=GetFunction(hDLL,"VarBstrFromI8")
		VarBstrFromUI8=GetFunction(hDLL,"VarBstrFromUI8")
		VectorFromBstr=GetFunction(hDLL,"VectorFromBstr")
		BstrFromVector=GetFunction(hDLL,"BstrFromVector")
		VarFormatNumber=GetFunction(hDLL,"VarFormatNumber")
		
		ProcedureReturn hDLL
	EndIf
	
	ProcedureReturn #False
EndProcedure



Procedure AnsitoBStr(string$) ; By Zapman Inspired by Fr34k
		Protected Unicode$=Space(Len(String$)*2+2)
		Protected bstr_string.l
		PokeS(@Unicode$,String$,-1,#PB_Unicode)
		bstr_string=SysAllocString_(@Unicode$)
		ProcedureReturn bstr_string
EndProcedure

; Procedure.s ReadBstr(*String) ; By Fr34k
; 		Result$=""
; 		If *String
; 				length.l=WideCharToMultiByte_(#CP_ACP,0,*String,-1,0,0,0,0)
; 				*Buffer=AllocateMemory(length)
; 				
; 				If *Buffer
; 						WideCharToMultiByte_(#CP_ACP,0,*String,-1,*Buffer,length,0,0)
; 						Result$=PeekS(*Buffer)
; 						FreeMemory(*Buffer)
; 				EndIf
; 		EndIf
; 		ProcedureReturn Result$
; 	EndProcedure
	Procedure.s BstrtoAnsi(*String) ; By Fr34k
		Result$=""
		If *String
				length.l=WideCharToMultiByte_(#CP_ACP,0,*String,-1,0,0,0,0)
				*Buffer=AllocateMemory(length)
				
				If *Buffer
						WideCharToMultiByte_(#CP_ACP,0,*String,-1,*Buffer,length,0,0)
						Result$=PeekS(*Buffer)
						FreeMemory(*Buffer)
				EndIf
		EndIf
		ProcedureReturn Result$
EndProcedure

Procedure AnsitoDEC(cAnsi.s,dy)
  If lcid=$40C
    cAnsi=ReplaceString(cAnsi, ".", "," )
  Else 
    cAnsi=ReplaceString(cAnsi, ",", "." )
  EndIf
	Bstr0=AnsiTOBstr(cAnsi)
	ERRD=VarDecFromStr(Bstr0,lcid,#LOCALE_NOUSEROVERRIDE,dy):NumErreur(ERRD,_nl)
EndProcedure
Procedure.s DectoAnsi(dy)
	Bstr0=AnsiTOBstr(Space(255))
	ERRD=VarBstrFromDec(dy,lcid,#LOCALE_NOUSEROVERRIDE,Bstr0):NumErreur(ERRD,_nl)
	ProcedureReturn BstrtoAnsi(PeekL(bstr0))
EndProcedure
Procedure.s DectoAnsiFormat(ddec,NBdec=-1,IncPR=-2,formneg=-2,Group=-2)
  Protected ddec2.decimal, bstr2.l
  ;******************************************* FORMAT essai ***********************************
  ; VarFormatNumber function This topic has Not yet been rated-Rate this topic
  ;
  ; Formats a variant containing numbers INTO a string form.
  ; Syntax C++ HRESULT VarFormatNumber(_In_ LPVARIANT pvarIn,_In_ INT iNumDig,_In_ INT iIncLead,_In_ INT iUseParens,_In_ INT iGroup,_In_ ULONG dwFlags,_Out_ BSTR*pbstrOut);
  ;
  ; Parameters
  ; pvarIn[IN] The variant containing the value To format.
  ; iNumDig[IN] The number of digits To pad To after the decimal point.Specify-1 To use the system Default value.
  ; iIncLead[IN]  Specifies whether To include the leading digit on numbers.
  ;   Value   Meaning
  ;   -2  Use the system Default.
  ;   -1  Include the leading digit.
  ;    0  Do Not include the leading digit.
  ; iUseParens[IN]  Specifies whether negative numbers should use parentheses.
  ;   Value   Meaning
  ;   -2 Use the system Default.
  ;   -1   Use parentheses.
  ;    0   Do Not use parentheses.
  ; iGroup[IN]  Specifies whether thousands should be grouped. For example 10,000 versus 10000.
  ;     Note Regular numbers And currencies have separate system defaults For all the above options.
  ;       Value   Meaning
  ;       -2       Use the system Default.
  ;       -1     Group thousands.
  ;        0     Do Not group thousands.
  ; dwFlags[IN]      VAR_CALENDAR_HIJRI is the only flag that can be set.
  ; pbstrOut[OUT]    Points To the formatted string that represents the variant.
  ;
  ; Return value
  ; This function can Return one of these values.
  ; Return code   Description
  ; S_OK                     Success.
  ; E_INVALIDARG       One Or more of the arguments is Not valid.
  ans.s=dectoansi(ddec)
  ansitodec(ans,ddec2)
  bstr2=AnsiTOBStr(Space(255))
  ERRD=VarFormatNumber(ddec2,Nbdec,IncPR,formneg,Group,0,bstr2):NumErreur(ERRD,_NL)
  ProcedureReturn BstrtoAnsi(PeekL(bstr2))
  
EndProcedure
Procedure.s StrNum(Number.s,nbdec.l=2,NBoct=0,sign=1,GRP=3,SepDec$=",",sepGr$=" ") ; Formats a number string as a number string customized for a specified locale.
  Number=ReplaceString(Number, ",", "." ) ;;;**** le LCID de GetNumberFormat() est sans effet
  Protected result.s,fmt.NUMBERFMT
  ; Structure NUMBERFMT
  ;   NumDigits.l
  ;   LeadingZero.l
  ;   Grouping.l
  ;   *lpDecimalSep.l
  ;   *lpThousandSep.l
  ;   NegativeOrder.l
  ; EndStructure
  
  fmt\NumDigits=nbdec     ; Indique le nombre de chiffres après la virgule.
  fmt\LeadingZero=1       ; Indique s'il faut utiliser les zéros de tête dans les champs décimaux.
  fmt\Grouping=GRP         ; Indique la taille de chaque groupe de chiffres à gauche du séparateur décimal.
  fmt\lpDecimalSep=@SepDec$    ; Pointeur du séparateut des décimales. "," pour la France et "." pour US
  fmt\lpThousandSep=@SepGr$    ; Pointeur du séparateur des groupes si groupe est demandé " " pour Fr et "," pour Us
  ; 	fmt\lpDecimalSep=@","      ; Pointeur du séparateut des décimales.
  ; 	fmt\lpThousandSep=@" "     ; Pointeur du séparateur des groupes si groupe est demandé
  ; 	fmt\NegativeOrder=4    ;    Signe derrière décollé du nombre
  ; 	fmt\NegativeOrder=3    ;    Signe -  derrière collé au nombre
  ;   fmt\NegativeOrder=2    ;    Signe - devant décollé au nombre
  ;   fmt\NegativeOrder=1    ;    Signe - devant collé au nombre
  ; 	fmt\NegativeOrder=0      ;  signe Avec parenthèses
  fmt\NegativeOrder=sign
  ;INT=GetNumberFormat(LCID,DWORD dwFlags,LPCTSTR lpValue,opt const NUMBERFMT *lpFormat,_Out_opt LPTSTR lpNumberStr,INT cchNumber);
  If nboct=0
    result=Space(GetNumberFormat_(lcid,0,Number,fmt,0,0))
  Else
    result=Space(nboct)
  EndIf 
  
  ERRD=GetNumberFormat_(lcid,0,Number,fmt,@result,Len(result))
  ;   Debug _nl+_n(ERRD)+_s(Sepdec$)+_s(SepGr$)+_n(lcid)+_n(nboct)
  ProcedureReturn result
EndProcedure

Procedure.s Dec2AnsiFormat(ddec,nbdec=2,NBoct=0,sign=1,GRP=3,SepDec$=",",sepGr$=" ")
  Protected ddec2.decimal, bstr2.l
  ;******************************************* FORMAT essai ***********************************
  ans.s=dectoansi(ddec)
  ; StrNum(Number.s,nbdec.l=2,NBoct=0,sign=1,GRP=3,SepDec$=",",sepGr$=" ")
  RES$=StrNum(ans,nbdec,NBoct,sign,GRP,SepDec$,sepGr$)
  ProcedureReturn res$
EndProcedure


dll_ole.l=oleaut32_LoadDLL()
;
Debug dll_ole
Define.decimal x,y,z,Dx,Dy,Dz,Du,Dv,dnx,dny,dnz,rx,ry,rz,Da,DB,Dc,DD,De,da1,da2,da3,da4,da5,dA6,dA7
Define.w DW
Define.l bstr,bstr2
Define.q cy,Cz
Define a.bs,B.bs,c.bs,d.bs,e.bs

lcid=$40C  ; FR,FR

;         3,1415926535897932384626433832795
Vdpis.s="-3,1415926535897932384626433832795" ; cette valeur avec virgule prise sur calc est plus prècise que la constante #pi
VDpi1000.s="-3141592,6535897932384626433832795"
ansitodec(VDpi1000,da1)
Debug _NL+_s(dectoansiformat(da1))+_s(dectoansi(da1))
Debug _NL+_s(dec2ansiformat(Da1))
Debug _NL+_s(dec2ansiformat(Da1,3)) ;par défaut 1   signe - devant collé au nombre
Debug _NL+_s(dec2ansiformat(Da1,3,0,0)); ;          signe Avec parenthèses
Debug _NL+_s(dec2ansiformat(Da1,3,0,2))  ;          Signe - devant décollé au nombre
Debug _NL+_s(dec2ansiformat(Da1,3,0,3));            Signe -  derrière collé au nombre
Debug _NL+_s(dec2ansiformat(Da1,3,0,4)) ;           Signe derrière décollé du nombre
Debug _NL+_s(dec2ansiformat(Da1,3,0,1,0)) ;         il n'y a plus de groupement 

ERRD=vardecmul(da1,da1,da2):NumErreur(ERRD,_NL)
Debug _s(dectoansiformat(da2))+_s(dectoansi(da2))

lcid=$409   ; US US
ansitodec(VDpi1000,da1)
Debug _s(dectoansiformat(da1))+_s(dectoansi(da1))
ERRD=vardecmul(da1,da1,da2):NumErreur(ERRD,_NL) ; premier exemple Pour controle 
NumErreur(VarDecRound(da2,4,da4),_NL);            deuxième exemple pour controle
Debug _s(dectoansiformat(da2))+_s(dectoansi(da2))+_s(dectoansi(da4))

Debug _s(dectoansiformat(da2,0))
Debug _s(dectoansiformat(da2,-1))
Debug _s(dectoansiformat(da2,-1,-1))
Debug _s(dectoansiformat(da2,-1,-1,0))

Debug _s(dectoansiformat(da1,0))
Debug _s(dectoansiformat(da1,-1))
Debug _s(dectoansiformat(da1,-1,-1))
Debug _s(dectoansiformat(da1,-1,-1,-1))

Debug _NL+_s(dec2ansiformat(Da2))
da2\sign=-128 ; Changement de signe du decimal DA2 0=> positif et -128 négatif 
Debug _NL+_s(dec2ansiformat(Da2))
Debug _NL+_s(dec2ansiformat(Da2,3))     ; par défaut le signe est à 1
Debug _NL+_s(dec2ansiformat(Da2,3,0,0));  ici paraenthèses
Debug _NL+_s(dec2ansiformat(Da2,3,0,2))
Debug _NL+_s(dec2ansiformat(Da2,3,0,3))
Debug _NL+_s(dec2ansiformat(Da2,3,0,4))
virg$=","
poin$="."
blan$=" "
;                        ddec,nbdec=2,NBoct=0,sign=1,GRP=3,SepDec$=",",sepGr$=" "
Debug _NL+_s(dec2ansiformat(Da2,3,0,1,3,poin$,virg$)) ; mode US . pour décimal et , pour séparer LES groupes
Debug _NL+_s(dec2ansiformat(Da2,3,0,1,3,virg$,blan$)) ; mode FR , pour décimal et " " pour séparer LES groupes
If Perrd<>0
  PrintN("Pour finir tapez sur Entrée")
  Input()
EndIf  
CloseConsole()
End
A+
Il est fort peu probable que les mêmes causes ne produisent pas les mêmes effets.(Einstein)
Et en logique positive cela donne.
Il est très fortement probable que les mêmes causes produisent les mêmes effets.
Haut
Répondre

Revenir à « Trucs et astuces »