dimanche 18 décembre 2016

Code VB /VBA générique

Voici quelques codes générique que j'utilise dans tous mes développements  et qui me servent régulièrement dans du calcul mathématique ou de traitement de chaine de caractères :

'---------------------------------------------------------------------------
' Point en 3D
'---------------------------------------------------------------------------

Public Type Point3
    X As Double
    Y As Double
    Z As Double
End Type

'Longueur de vecteur
Function Longueur(ByRef P1 As Point3) As Double
  Longueur = Sqr((P1.X ^ 2) + (P1.Y ^ 2) + (P1.Z ^ 2))
End Function
 
'Distance entre 2 points
Function Distance(ByRef P1 As Point3, ByRef P2 As Point3) As Double
    Distance = Sqr((P2.X - P1.X) ^ 2 + (P2.Y - P1.Y) ^ 2 + (P2.Z - P1.Z) ^ 2)
End Function
 
'Addition de vecteur
Function VecAdd(ByRef P1 As Point3, ByRef P2 As Point3, Optional F As Double = 1) As Point3
 VecAdd.X = P1.X + F * P2.X
 VecAdd.Y = P1.Y + F * P2.Y
 VecAdd.Z = P1.Z + F * P2.Z
End Function
 
'Produit Scalaire
Function Dot(ByRef p As Point3, ByRef Q As Point3) As Double
    Dot = p.X * Q.X + p.Y * Q.Y + p.Z * Q.Z
End Function

'Soustraction de point
Function SubVect(ByRef P1 As Point3, ByRef P2 As Point3, ByRef F As Double) As Point3
 SubVect.X = P1.X - P2.X * F
 SubVect.Y = P1.Y - P2.Y * F
 SubVect.Z = P1.Z - P2.Z * F
End Function
 
'Produit vectoriel
Function VecProd(ByRef P1 As Point3, ByRef P2 As Point3) As Point3
Dim P4 As Point3

 P4.X = (P1.Y * P2.Z) - (P1.Z * P2.Y)
 P4.Y = (P1.Z * P2.X) - (P1.X * P2.Z)
 P4.Z = (P1.X * P2.Y) - (P1.Y * P2.X)
 VecProd = P4
End Function
 
' Soustraction de vecteur
Function VecSub(ByRef P1 As Point3, ByRef P2 As Point3, Optional t As Double = 1) As Point3
 VecSub.X = P1.X - t * P2.X
 VecSub.Y = P1.Y - t * P2.Y
 VecSub.Z = P1.Z - t * P2.Z
End Function
 
'Récupération du vecteur normal de 3 points
Function NormVec(ByRef P1 As Point3, ByRef P2 As Point3, ByRef P3 As Point3) As Point3
 NormVec = VecteurUnitaire(VecProd(VecSub(P1, P2), VecSub(P3, P2)))
End Function

' Transforme un vecteur en vecteur unitaire
Function VecteurUnitaire(ByRef P1 As Point3) As Point3
Dim Norm As Double
     Norm = Sqr(P1.X * P1.X + P1.Y * P1.Y + P1.Z * P1.Z)
     If Norm = 0 Then
            Exit Function
     End If
   
    VecteurUnitaire.X = P1.X / Norm
    VecteurUnitaire.Y = P1.Y / Norm
    VecteurUnitaire.Z = P1.Z / Norm
End Function
 
' Coordonnées du point Milieu
Function PointMilieu(ByRef P1 As Point3, ByRef P2 As Point3) As Point3
 PointMilieu.X = 0.5 * (P1.X + P2.X)
 PointMilieu.Y = 0.5 * (P1.Y + P2.Y)
 PointMilieu.Z = 0.5 * (P1.Z + P2.Z)
End Function
 
'****************************************************************
' Name: Round
'
' Inputs:DP is the decimal place to round to (0 to 14) e.g
' Round (3.56376, 3) will give the result 3.564
' Round (3.56376, 1) will give the result 3.6
' Round (3.56376, 0) will give the result 4
' Round (3.56376, 2) will give the result 3.56
' Round (1.4999, 3) will give the result 1.5
' Round (1.4899, 2) will give the result 1.49
' Returns:None
' Assumes:None
' Side Effects:None
'
'****************************************************************

Function Round(X1 As Double, DP As Integer) As Double
    Round = Int((X1 * 10 ^ DP) + 0.5) / 10 ^ DP
End Function

'****************************************************************
' Name: A 'strtok' function for VB
' Description:I wrote four functions to tokenize strings. He
'     re they are...
'The functions work like this TokLeftLeft finds the leftmost token and
'then returns the left part of the string (empty if not there). You
'can figure out the rest. Note that if the token is more than 1 character
'then the function will always return "".
'****************************************************************

Public Function TokLeftLeft(ByRef Source As String, ByRef token As String) As String
Dim I As Integer
       TokLeftLeft = Source

              For I = 1 To Len(Source)
                            If Mid(Source, I, 1) = token Then
                                   TokLeftLeft = Left(Source, I - 1)
                                   Exit Function
                            End If
              Next I

End Function


Public Function
TokLeftRight(ByRef Source As String, ByRef token As String) As String

Dim I As Integer
       TokLeftRight = Source

              For I = 1 To Len(Source)
                            If Mid(Source, I, 1) = token Then
                                   TokLeftRight = Right(Source, Len(Source) - I)
                                   Exit Function
                            End If
              Next I
End Function


Public Function
TokRightLeft(ByRef Source As String, ByRef token As String) As String 

Dim I As Integer
       TokRightLeft = ""

              For I = Len(Source) To 1 Step -1
                            If Mid(Source, I, 1) = token Then
                                   TokRightLeft = Left(Source, I - 1)
                                   Exit Function
                            End If
              Next I
End Function

 
Public Function TokRightRight(ByRef Source As String, ByRef token As String) As String
Dim I As Integer
       TokRightRight = ""
              For I = Len(Source) To 1 Step -1
                            If Mid(Source, I, 1) = token Then
                                   TokRightRight = Right(Source, Len(Source) - I)
                                   Exit Function
                            End If

              Next I
End Function

1 commentaire:

  1. It's incredible, your way is working!
    Thank you !!
    Previously, I calculate the direction of movement in a manner described Bryan Carpio Felsher on the site coe.org, that way
    sometimes make mistake.


    www.coe.org/p/fo/st/thread=29348&post=88186&posted=1#p88186 quote from this site:

    "I really do not get why so many posts have such trouble with Circles. The sign of the cross product between the INDIRV and vector from start point to center point of circle gives you the answer. Here's what it looks like in the post I wrote a long time ago.

    Sub GetCircleDirection
    CrossProductI = IndirvCircJ * IndirvK - IndirvCircK * IndirvJ
    CrossProductJ = IndirvCircK * IndirvI - IndirvCircI * IndirvK
    CrossProductK = IndirvCircI * IndirvJ - IndirvCircJ * IndirvI

    If Sgn (CrossProductK)> 0 Then
    CircleDirection = 2 'CCLW
    CircleCode = CCLWCircleCode
    ElseIf Sgn (CrossProductK) <0 Then CircleDirection = 1 'CLW
    CircleCode = SLVTsirkleKode
    End If

    Return
    End Sub "

    C'est incroyable, votre façon de travailler!
    Je vous remercie !!
    Auparavant, je calcule la direction du mouvement d'une manière décrite Bryan Carpio Felsher sur le site coe.org, de cette façon
      Parfois faire erreur.


    www.coe.org/p/fo/st/thread=29348&post=88186&posted=1#p88186 citation de ce site:

    "Je ne comprends vraiment pas pourquoi tant de postes ont de tels problèmes avec les cercles.Le signe de la croix produit entre l'INDIRV et le vecteur de point de départ à centre de cercle vous donne la réponse.C'est ce que cela ressemble dans le post que j'ai écrit il y a longtemps.

    Sub GetCircleDirection
    CrossProductI = IndirvCircJ*IndirvK - IndirvCircK*IndirvJ
    CrossProductJ = IndirvCircK*IndirvI - IndirvCircI*IndirvK
    CrossProductK = IndirvCircI*IndirvJ - IndirvCircJ*IndirvI

    If Sgn(CrossProductK) > 0 Then
    CircleDirection = 2 'CCLW
    CircleCode = CCLWCircleCode
    ElseIf Sgn(CrossProductK) < 0 Then CircleDirection = 1 'CLW
    CircleCode = СЛВЦирклеКоде
    End If

    Return
    End Sub "

    RépondreSupprimer