Extraction chaine dans String

Version imprimable

10/07/2025, 12h22
thuglife

1 pièce(s) jointe(s)

Extraction chaine dans String

Bonjour,

En VBA j'ai un string qui ressemble à la photo ci-dessous, je cherche à extraire certains paramètres contenu dans le string strResp avec leurs valeurs.

Pièce jointe 668666

par exemple j'aimerais extraire :
MaxAllocSpace:0 et CouldTrim:65800

si quelqu'un peut m'aider ?

Essaie cet exemple:

Code:

1
2
3
4
5
6
7
8
9
10
11
 Dim strResp As String
 Dim vec, c
 Dim Vals As New Collection
 strResp = "aaa:111 bbb:222 ccc:333"
 For Each c In Split(Trim(strResp), " ")
   vec = Split(c, ":")
   Vals.Add vec(1), CStr(vec(0))
 Next
 
 Debug.Print Vals("aaa")
 Debug.Print Vals("ccc")

10/07/2025, 13h18
thuglife

1 pièce(s) jointe(s)

Cela ne fonctionne pas mais je vois que le VEC est "mal" agencé
Pièce jointe 668669

Bonjours à tous,
Je détourne une fonction que j'utilise souvent :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
'@Description "Retrieves a value from a control's tag based on a key."
Private Function GetTheValue(TagValue As String, _
                             Value As String _
                             ) As String
 
    On Error Resume Next
 
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
 
    Dim TempTab() As String
    TempTab = Split(TagValue, " ")
 
    Dim Counter As Integer
    For Counter = LBound(TempTab) To UBound(TempTab)
        Dim Items() As String
        Items = Split(TempTab(Counter), ":")
        If UBound(Items) = 1 Then
            dict(Items(0)) = Items(1)
        End If
    Next
 
    If dict.Exists(Value) Then
        GetTheValue = dict(Value)
    Else
        GetTheValue = vbNullString
    End If
 
    If Not dict Is Nothing Then Set dict = Nothing
End Function

Vous pouvez faire un test comme ceci :

Code:

1
2
3
4
Sub test()
Const Chaine As String = "TotalAllocated:524880 NbFreeChunck:12"
MsgBox GetTheValue(Chaine, "NbFreeChunck")
End Sub

Vous pourriez faire plus simple d'utilisation avec une déclaration d'un type puis vous assignez les valeurs recherchée...
Pouvez vous nous faire parvenir la chaine. Et pas sous forme de photo. Merci

10/07/2025, 13h39
thuglife

1 pièce(s) jointe(s)

ça me fait pareil, on dirait que les tables sont "mal" rangées

Pièce jointe 668670
10/07/2025, 13h53
Valtrase
Re,
Pouvez-vous envoyer votre code car là nous ne somme pas sur la même longueur d'onde. Je teste la fonction est c'est ok d’après vos informations. Attention à la Casse.
Poster :
- Le code incriminé
- La ligne qui contient les donnée à traitées
ET SI POSSIBLE PAS SOUS FORME DE PHOTOS.
Utilisez le bouton # dans le menu pour l'insertion de code avec un copier/coller.
10/07/2025, 14h04
thuglife

je vais réfléchir à comment faire car la variable string récupère les infos via une requête http sur un équipement disponible sur mon réseau local (donc marchera pas chez vous)
je pense que ça doit être lié à la tabulation dans la chaine string
je regarde comment je peux faire
10/07/2025, 14h06
Invité

Il semble que le séparateur entre paramètres n'est pas un espace mais un autre caractère blanc soit retour ligne ou une tab
sur l'image il n'est pas possible à identifier le séparateur utilisé il faut poster le texte de strResp pour connaître

Re,
Si par exemple la variable String se nomme getStringToHTTP
Alors vous pouvez faire :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub test()
    Dim getStringToHttp As String
    getStringToHttp = MaFonctionDeRécupération
 
    Dim MaxAllocSpace As String
    MaxAllocSpace = GetTheValue(getStringToHttp, "MaxAllocSpace")
 
    Dim CouldTrim As String
    CouldTrim = GetTheValue(getStringToHttp, "CouldTrim")
 
    MsgBox "Les valeurs sont." & vbNewLine & _
           "MaxAllocSpace := " & MaxAllocSpace & vbNewLine & _
           "CouldTrim := " & CouldTrim
 
End Sub

10/07/2025, 14h55
thuglife

1 pièce(s) jointe(s)

Voici ca devrait fonctionner pour le debugg, j'ai mis l'équipement sur le net

Pièce jointe 668673

Re,
Bon vous avez un retour sur strResp avec des retour à la ligne donc il faut les remplacer par un espace ou bien changer la fonction getTheValue et l'adapter en conséquence.
Voici en modifiant le code de la procédure RequeteHTTPStats()

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
 
Dim wq As WinHttp.WinHttpRequest
Sub RequeteHTTPStats()
 
 
 
    Dim strURL As String, strResp As String
    Dim i, j As Integer
    Dim vec, c
    Dim Vals As New Collection
 
    Const HTTPREQUEST_SETCREDENTIALS_FOR_SERVER As Long = 0
    Const HTTPREQUEST_SETCREDENTIALS_FOR_PROXY As Long = 1
 
    Range("D3:BE7397").ClearContents
    j = WorksheetFunction.CountA(Range("a:a"))
 
    For i = 3 To j
 
        strURL = "http://" & Range("A" & i).Value
        strURL = strURL & "/rcgi.bin/ParamForm?AST_Param=$$dtES $ftT"
 
        On Error GoTo ERRH
        Set wq = New WinHttpRequest
        ' Création requêtte HTTP de type GET
        wq.Open "GET", strURL
        wq.SetCredentials Range("B" & i).Value, Range("C" & i).Value, HTTPREQUEST_SETCREDENTIALS_FOR_SERVER
        ' Envoie de la requête
        wq.Send
 
        If wq.Status = 200 Then
            ' Récupérer le corps de la réponse
            strResp = wq.ResponseText
            ' exploitation de la réponse
            Debug.Print strResp ' // Vérification du retour de données
            strResp = Replace(strResp, vbCrLf, " ") '<-- CHANGEMENT ICI
            MsgBox GetTheValue(strResp, "NbFreeChunck")
        Else
            Range("D" & i).Value = wq.Status & " " & wq.StatusText & " " & "Statut renvoyé par serveur"
        End If
BOUCLE:
    Next i
    GoTo ENDPROC
 
ERRH:
    'MsgBox ERR.Description
    Range("D" & i).Value = "Erreur No." & Err.Number & " : " & Err.Description
    Resume BOUCLE
 
ENDPROC:
    Set wq = Nothing
 
End Sub
 
'@Description "Retrieves a value from a control's tag based on a key."
Private Function GetTheValue(TagValue As String, _
                             Value As String _
                             ) As String
 
    On Error Resume Next
 
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
 
    Dim TempTab() As String
    TempTab = Split(TagValue, " ")
 
    Dim counter As Integer
    For counter = LBound(TempTab) To UBound(TempTab)
        Dim Items() As String
        Items = Split(TempTab(counter), ":")
        If UBound(Items) = 1 Then
            dict(Items(0)) = Items(1)
        End If
    Next
 
    If dict.Exists(Value) Then
        GetTheValue = dict(Value)
    Else
        GetTheValue = vbNullString
    End If
 
    If Not dict Is Nothing Then Set dict = Nothing
End Function

Sinon en modifiant la fonction GetTheValue MAIS DANS CE CAS SUPPRMER LA LIGNE AVEC LE REPLACE DE LA PROCEDURE RequeteHTTPStats()

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
'@Description "Retrieves a value from a control's tag based on a key."
Private Function GetTheValue(TagValue As String, _
                             Value As String _
                             ) As String
 
    On Error Resume Next
 
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
 
    Dim TempTab() As String
    TempTab = Split(TagValue, vbCrLf)
 
    Dim counter As Integer
    For counter = LBound(TempTab) To UBound(TempTab)
        Dim Items() As String
        Items = Split(TempTab(counter), ":")
        If UBound(Items) = 1 Then
            dict(Items(0)) = Items(1)
        End If
    Next
 
    If dict.Exists(Value) Then
        GetTheValue = dict(Value)
    Else
        GetTheValue = vbNullString
    End If
 
    If Not dict Is Nothing Then Set dict = Nothing
End Function

10/07/2025, 18h09
thuglife

franchement merci beaucoup !!!
j'en perdais mon latin...

PS : j'ai fait une petite amélioration, j'ai spliter avec des ; plutot que des espace (il y avait quelques bug de découpe avec les espaces)
10/07/2025, 20h23
Valtrase

Re,
Pas de quoi. Un petit clic sur le pouce fait toujours plaisir.

Bonne programmation.

Hello,

Les fonctions de manipulation des chaînes de caractère native de VBA sont sympa, mais trouvent vite leurs limites.
Les expressions régulières peuvent s'avérer bien plus puissantes.

Dans votre cas, qu'est-ce que l'on a ?
Une serie de paires clef - valeurs, séparées par un espace.
Chaque clef est séparé de la valeur par un deux points(:).

Les fonctions suivantes font le même job:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 Public Function GetKeyValues(ByVal Data As String) As Scripting.Dictionary Dim Rx As VBScript_RegExp_55.RegExp Set Rx = CreateObject("VbScript.RegExp") Rx.Global = True Rx.Pattern = "[^\f\v\t ]+" Dim Matchs As VBScript_RegExp_55.MatchCollection Set Matchs = Rx.Execute(Data) '// Obtiens les paires clef / valeurs Dim KeyValues As Scripting.Dictionary Set KeyValues = CreateObject("Scripting.Dictionary") Dim Match As VBScript_RegExp_55.Match For Each Match In Matchs GetKeyValue Match, KeyValues '// Separe les clefs des valeurs Next Set GetKeyValues = KeyValues End Function Public Sub GetKeyValue(ByVal Match As VBScript_RegExp_55.Match, ByRef KeyValues As Scripting.Dictionary) Dim Rx As VBScript_RegExp_55.RegExp Set Rx = CreateObject("VbScript.RegExp") Rx.Global = True Rx.Pattern = "([^:]+):([^:]+)" KeyValues.Add Key:=Rx.Replace(Match.Value, "$1"), Item:=Rx.Replace(Match.Value, "$2") End Sub
PS:
Les données d'origine ne sont pas altérées.
J'ai volontairement omis le test d'éxistance des clefs, une clef dupliquée peut indiquer un problème.