Keskustelu: Ohjelmointikysymykset: VB6: substr_count vb6:lle

miiro [11.12.2005 13:46:39]

onko vb kutoselle olemassa vastaavanlaista funktiota kuin substr_count? Substr_countin infoa: https://www.ohjelmointiputka.net/hak/?kieli=PHP&nimi=substr_count

Blaze [11.12.2005 14:41:57]

Sikäli kun tiedän, niin ei, mutta voit tehdä oman helposti InStr:ää hyödyntämällä.

miiro [11.12.2005 14:55:31]

ok. kiitos.

tesmu [11.12.2005 16:33:58]

Public Function Substr_Count(merkkijono as String,merkki as String) as Long
Static Count as Long
For i = 0 to Len(merkkijono)
  If Mid(merkkijono,i,1)=merkki Then Count=Count +1
Next i
Substr_Count = Count
End Function

Jos halutaan että kirjainkoolla ei ole väliä niin sillon scannataan ucasena tai lcasena ihan sama

Merri [11.12.2005 20:15:21]

Jos vauhdille on tarvetta...

' sijoita omaan moduuliinsa
Option Explicit

Private Declare Sub RtlMoveMemory Lib "ntdll.dll" (ByRef lpvDest As Any, ByRef lpvSrc As Any, ByVal cbLen As Long)
'Private Declare Function VarPtrArray Lib "msvbvm50.dll" Alias "VarPtr" (Var() As Any) As Long
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (Var() As Any) As Long

Private BufStrHeader(5) As Long
Private BufFindHeader(5) As Long
Private BufStr() As Integer
Private BufFind() As Integer
Private OldStr As Long
Private OldFind As Long
Public Sub SisicInitialize()
    BufStrHeader(0) = 1
    BufStrHeader(1) = 2
    BufStrHeader(4) = &H7FFFFFFF
    BufFindHeader(0) = 1
    BufFindHeader(1) = 2
    BufFindHeader(4) = &H7FFFFFFF
    OldStr = 0
    OldFind = 0
End Sub
Public Sub SisicTerminate()
    RtlMoveMemory ByVal VarPtrArray(BufStr), 0&, 4
    RtlMoveMemory ByVal VarPtrArray(BufFind), 0&, 4
End Sub
Public Function SisicM(ByRef pStr As Long, ByRef pFind As Long, ByRef lenStr As Long, ByRef lenFind As Long) As Long
    Dim lngA As Long, lngB As Long, lngC As Long
    Dim intFind As Integer, intStr As Integer
    Dim intFirst As Integer, intLast As Integer, lngCounter As Long, lngFlag As Long

    If OldStr <> pStr Then
        BufStrHeader(3) = pStr
        RtlMoveMemory ByVal VarPtrArray(BufStr), VarPtr(BufStrHeader(0)), 4
        OldStr = pStr
    End If
    If OldFind <> pFind Then
        BufFindHeader(3) = pFind
        RtlMoveMemory ByVal VarPtrArray(BufFind), VarPtr(BufFindHeader(0)), 4
        OldFind = pFind
    End If

    If lenFind = 1 Then
        intFirst = BufFind(0)
        For lngA = lenStr - 1 To 0 Step -1
            intStr = BufStr(lngA)
            If intFirst = intStr Then lngCounter = lngCounter + 1
        Next lngA
    ElseIf lenFind = 2 Then
        lenFind = 1
        intFirst = BufFind(0)
        intLast = BufFind(lenFind)
        For lngA = lenStr - 1 To lenFind Step -1
            intStr = BufStr(lngA)
            If intLast = intStr Then
                intStr = BufStr(lngA - lenFind)
                If intFirst = intStr Then lngCounter = lngCounter + 1: lngA = lngA - lenFind
            End If
        Next lngA
    Else
        lenFind = lenFind - 1
        intFirst = BufFind(0)
        intLast = BufFind(lenFind)
        For lngA = lenStr - 1 To lenFind Step -1
            intStr = BufStr(lngA)
            If intLast = intStr Then
                intStr = BufStr(lngA - lenFind)
                If intFirst = intStr Then
                    lngC = lngA - 1
                    For lngB = lenFind - 1 To 1 Step -1
                        intFind = BufFind(lngB)
                        intStr = BufStr(lngC)
                        If Not (intFind = intStr) Then lngFlag = 1: Exit For
                        lngC = lngC - 1
                    Next lngB
                    If lngFlag = 1 Then lngFlag = 0 Else lngCounter = lngCounter + 1: lngA = lngC
                End If
            End If
        Next lngA
    End If
    SisicM = lngCounter
End Function

Päihittää mm. useamman InStr:n avulla tehdyn funktion mennen tullen. Optimointi on tosin tehnyt tämän käytöstä vähän vaikeampaa: SisicInitialize täytyy kutsua vaikka ohjelman alussa ja SisicTerminate sitten kun ohjelma suljetaan. Lisäksi kutsu tapahtuu näin:

Määrä = SisicM(StrPtr(Teksti), StrPtr(Hakusana), Len(Teksti), Len(Hakusana))

Nopeuden huomaa vasta sitten, kun ohjelman kääntää exeksi asettaen Advanced Optimizations -ikkunan kohtiin ruksit.

miiro [16.12.2005 19:52:55]

No, kiitos kummallekin!

tesmu [17.12.2005 15:19:45]

Korjausta tuohon minun koodiini

Public Function Substr_Count(merkkijono As String, merkki As String) As Long
Dim Count As Long
For i = 1 To Len(merkkijono)
  If Mid(UCase(merkkijono), i, Len(merkki)) = UCase(merkki) Then Count = Count + 1
Next i
Substr_Count = Count
End Function

Vastaus

Aihe on jo aika vanha, joten et voi enää vastata siihen.

Kirjautuminen

Haku

Tehtävät