Die Community zu .NET und Classic VB.
Menü

Tipp-Upload: VB 5/6 0136: CharArray, CharPointer

 von 

Über den Tipp  

Dieser Tippvorschlag ist noch unbewertet.

Der Vorschlag ist in den folgenden Kategorien zu finden:

  • System
  • Sonstiges

Dem Tippvorschlag wurden folgende Schlüsselwörter zugeordnet:
Chararray, Charpointer, Character, Integer, Safearray, Zeiger, universal Zeiger

Damit er übernommen werden kann, müssen noch Änderungen daran vorgenommen werden. Sofern Sie der Autor sind, können Sie sich anmelden, um die Liste einzusehen.

Der Vorschlag wurde erstellt am: 31.10.2007 08:28.
Die letzte Aktualisierung erfolgte am 20.11.2007 14:20.

Zurück zur Übersicht

Beschreibung  

Beim Parsen eines Strings kommt es des Öfteren vor, daß ein String zeichenweise durchwandert werden soll. Mid und MidB ist hier die meist verwendete Möglichkeit, Teile eines Strings zu extrahieren und in einen anderen String zu kopieren. Soll dann eine Entscheidung anhand des rausgelesen Zeichens getroffen werden, bspw in einem Select Case, so bietet der Select Case von VB die bequeme Möglichkeit selbst Strings als Argument übergeben zu dürfen. Diese bequeme Vorgehensweise erkauft man sich allerdings mit einer guten Portion Performance. Wer beim Parsen größerer Dateien auf Performance achten möchte, der greift ein wenig in die Trickkiste. Für den VB-Anwender stellt ein String einen besonderen Datentyp dar, der mit den in VB enthaltenen Stringfunktionen bearbeitet werden kann.
Eine andere Sichtweise ist es, einen String als einen zusammenhängenden Speicherbereich bzw als ein Array von Zeichen (Character) zu betrachten. In anderen Programmiersprachen (Delphi, C++) ist diese Sichtweise seit jeher Bestandteil der Sprache, weswegen Parser dort meist viel zügiger als in VB zu Werke gehen.
Es gibt jedoch in VBC keinen eigenen Datentyp für ein Zeichen, weshalb der Datentyp String meist für ein einzelnes Zeichen verwendet wird. Ein einzelnes Zeichen kann aber auch als ein 2-Byte langer Integer btrachtet werden. Ein Select Case mit einem numerischen Wert als Argument bringt ebenfalls einen Performancegewinn.
Ein Array als universal verwendbaren Zeiger ist der Trick der Wahl. Dabei wird eine Arrayvariable mit einem Zeiger auf einen selbstdefinierten SafeArraydescriptor geimpft.
In diesem kleinen BspProjekt wird eine Performancemessung der gezeigten Methode im Vergleich zu Mid / MidB durchgeführt. Dabei ergibt sich gegenüber MidB in der kompilierten Exedatei ein etwa 20-facher, in der VB-IDE immerhin noch 3-4facher Performancegewinn.

Wohlgemerkt wird hier lediglich der Vorgang des Extrahierens eines einzelnen Zeichens gemessen, wohingegen sich im gesamten Parse-Vorgang einer Datei, bzw überführen eines Strings in eine Objektdatenstruktur sich der Performancegewinn allein durch die hier gezeigte Methode, selbstverständlich nicht so gravierend bemerkbar machen wird.

Das Projekt besteht aus einem Formular zwei Modulen und einer Klasse StopWatch. Hauptbestanteil des Tipps sind die beiden Module ModUDTPtr und ModCharPointer, im Formular auch die Subs *BtnMidBWalk_Click und *BtnCharPtrWalk_Click. Es soll hier nicht der Focus auf die Klasse gerichtet sein, siehe dazu den Tipp <!TU0137 QueryPerformance, StopWatch mit Currency>.

Schwierigkeitsgrad

Schwierigkeitsgrad 1

Verwendete API-Aufrufe:

QueryPerformanceCounter, QueryPerformanceFrequency, RtlMoveMemory, RtlZeroMemory, VarPtr (ArrPtr)

Download:

Download des Beispielprojektes [6,84 KB]

' Dieser Source stammt von http://www.activevb.de
' und kann frei verwendet werden. Für eventuelle Schäden
' wird nicht gehaftet.

' Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
' Ansonsten viel Spaß und Erfolg mit diesem Source!

' ------------- Anfang Projektdatei Projekt1.vbp -------------

' --------- Anfang Formular "Form1" alias Form1.frm  ---------

' Steuerelement: Beschriftungsfeld "Label1"
' Steuerelement: Optionsfeld-Steuerelement "Option2" auf FrmBuildString
' Steuerelement: Schaltfläche "BtnMidBWalk"
' Steuerelement: Schaltfläche "BtnCharPtrWalk"
' Steuerelement: Optionsfeld-Steuerelement "Option1" auf FrmBuildString
' Steuerelement: Rahmensteuerelement "FrmBuildString"
' Steuerelement: Optionsfeld-Steuerelement "Option3" auf FrmBuildString
' Steuerelement: Schaltfläche "BtnWalkBArrAnsi"
' Steuerelement: Schaltfläche "BtnWalkBArrUnic"

Option Explicit

' Beim Parsen eines Strings kommt es des Öfteren vor, daß ein String
' zeichenweise durchwandert werden soll. Mid und MidB ist hier die meist
' verwendete Möglichkeit, Teile eines Strings zu extrahieren und in einen
' anderen String zu kopieren.
' Soll dann eine Entscheidung anhand des rausgelesen Zeichens getroffen
' werden, bspw in einem Select case, so bietet der Select Case von VB die
' bequeme Möglichkeit selbst Strings als Argument übergeben zu dürfen.
' Diese bequeme Vorgehensweise erkauft man sich allerdings mit einer guten
' Portion Performance.
' Wer beim Parsen größerer Dateien auf Performance achten möchte, der greift
' ein wenig in die Trickkiste. Für den gewöhnlichen VB-Anwender stellt ein
' String einen besonderen Datentyp dar, der mit den in VB enthaltenen String-
' funktionen bearbeitet werden kann.
' Eine andere Sichtweise ist es, einen String als einen zusammenhängenden
' Speicherbereich bzw als ein Array von Zeichen (Character) zu betrachten.
' Es gibt jedoch in VBC keinen eigenen Datentyp für ein Zeichen, weshalb der
' Datentyp String meist für ein einzelnes Zeichen verwendet wird.
' Ein einzelnes Zeichen kann aber auch als ein 2-Byte langer Integer btrachtet
' werden. Ein Select Case mit einem numerischen Wert als Argument bringt
' ebenfalls einen Performancegewinn.
' Ein Array als universal verwendbaren Zeiger ist der Trick der Wahl.
' Dabei wird einer Arrayvariable der Zeiger auf einen selbstdefinierten
' SafeArraydescriptor injiziert.
' In anderen Programmiersprachen (Delphi, C++) ist diese Vorgehensweise seit
' jeher Bestandteil der Sprache, weswegen Parser in anderen Programmiersprachen
' meist viel zügiger als in VB zu Werke gehen.
' In diesem kleinen BspProjekt wird eine Performancemessung der gezeigten
' Methode im Vergleich zu Mid / MidB durchgeführt.
' Dabei ergibt sich gegenüber MidB in der kompilierten Exedatei ein etwa
' 20-facher, in der VB-IDE immerhin noch 3-4facher Performancegewinn.

' Wohlgemerkt wird hier lediglich der Vorgang des Extrahierens eines einzelnen
' Zeichens betrachtet, wohingegen sich im gesamten Parse-Vorgang einer Datei,
' bzw überführen eines Strings in eine Objektdatenstruktur sich der Performance-
' gewinn allein durch die hier gezeigte Methode, selbstverständlich nicht so
' gravierend bemerkbar machen wird.

' Der String der durchwandert werden soll
Private mStrVal As String
Private mSW As StopWatch

Private Sub Form_Load()

    Set mSW = New StopWatch

End Sub

Private Sub Option1_Click()

    Call HourGlassBuildString

End Sub

Private Sub Option2_Click()

    Call HourGlassBuildString

End Sub

Private Sub Option3_Click()

    Call HourGlassBuildString

End Sub

' Dieser Programmteil dient lediglich zum Aufbau verschieden langer Strings
' die dann durchwandert werden.
Private Sub HourGlassBuildString()

    Dim mp As MousePointerConstants
    mp = Screen.MousePointer
    Screen.MousePointer = MousePointerConstants.vbArrowHourglass

    Call BuildString

    Screen.MousePointer = mp

    Call MessStringLength

End Sub

Private Sub BuildString()

    mStrVal = vbNullString

    Dim s As String
    s = "quick brown fox jumps over the lazy dog " ' 40 = 80Byte

    Call AppendStringN(mStrVal, s, 1000)

    s = mStrVal

    Call AppendStringN(mStrVal, s, 10 - 1)

    If Option1.Value Then Exit Sub

    s = mStrVal

    Call AppendStringN(mStrVal, s, 10 - 1)

    If Option2.Value Then Exit Sub

    s = mStrVal

    Call AppendStringN(mStrVal, s, 10 - 1)

    If Option3.Value Then Exit Sub

End Sub

Private Sub AppendStringN(AppendTo As String, StrVal As String, ByVal n As Long)

    Dim i As Long, lA As Long, lS As Long

    lA = LenB(AppendTo)
    lS = LenB(StrVal)
    AppendTo = AppendTo & Space$(n * lS \ 2)

    For i = lA + 1 To lA + (n * lS) Step lS
        MidB$(AppendTo, i, lS) = StrVal
    Next

End Sub

Private Sub MessStringLength()

    Dim b As Double, c As String
    b = LenB(mStrVal)
    c = IIf(b > 1000# * 1000#, "MB", "KB")
    b = IIf(b > 1000# * 1000#, b / 1000# / 1000#, b / 1000#)
    MsgBox CStr((b)) & " " & c

End Sub

Private Sub Start(amp As MousePointerConstants)

    amp = Screen.MousePointer
    Screen.MousePointer = MousePointerConstants.vbArrowHourglass
    mSW.Reset
    mSW.Start

End Sub

Private Sub MessStop(mp As MousePointerConstants)

    mSW.SStop
    MsgBox CStr(mSW.ElapsedMilliseconds) & " ms"
    Screen.MousePointer = mp

End Sub

' hier gehts los mit den Vergleichsmessungen
Private Sub BtnMidBWalk_Click()

    If LenB(mStrVal) = 0 Then Call BuildString

    Dim mp As MousePointerConstants

    Call Start(mp)

    Dim i As Long
    Dim c As String

    For i = 1 To LenB(mStrVal) Step 2
        c = MidB$(mStrVal, i, 2)
    Next

    Call MessStop(mp)

End Sub

Private Sub BtnCharPtrWalk_Click()

    If LenB(mStrVal) = 0 Then Call BuildString

    Dim mp As MousePointerConstants

    Call Start(mp)

    Dim i As Long
    Dim c As Integer
    Dim cp As TCharPointer: Call New_CharPointer(cp, mStrVal)

    For i = 1 To Len(mStrVal)
        c = cp.Chars(i)
    Next

    Call DeleteCharPointer(cp)

    Call MessStop(mp)

End Sub

Private Sub BtnWalkBArrAnsi_Click()

    If LenB(mStrVal) = 0 Then Call BuildString

    Dim mp As MousePointerConstants

    Call Start(mp)

    Dim i As Long
    Dim c As Byte
    Dim bArray() As Byte

    bArray = StrConv(mStrVal, vbFromUnicode)

    For i = 0 To Len(mStrVal) - 1
        c = bArray(i)
    Next

    Call MessStop(mp)

End Sub

Private Sub BtnWalkBArrUnic_Click()

    If LenB(mStrVal) = 0 Then Call BuildString

    Dim mp As MousePointerConstants

    Call Start(mp)

    Dim i As Long
    Dim c As Byte
    Dim bArray() As Byte

    bArray = StrConv(mStrVal, vbUnicode)

    For i = 0 To UBound(bArray) Step 2
        c = bArray(i)
    Next

    Call MessStop(mp)

End Sub

' ---------- Ende Formular "Form1" alias Form1.frm  ----------

' ------- Anfang Modul "ModUDTPtr" alias ModUDTPtr.bas -------

Option Explicit

' Ein SafeArray-Descriptor dient in VB als ein universaler Zeiger
Public Type TUDTPtr
    pSA        As Long
    Reserved   As Long ' z.B. für vbVarType oder IRecordInfo
    cDims      As Integer
    fFeatures  As Integer
    cbElements As Long
    cLocks     As Long
    pvData     As Long
    cElements  As Long
    lLBound    As Long
End Type

Public Enum SAFeature
    FADF_AUTO = &H1
    FADF_STATIC = &H2
    FADF_EMBEDDED = &H4

    FADF_FIXEDSIZE = &H10
    FADF_RECORD = &H20
    FADF_HAVEIID = &H40
    FADF_HAVEVARTYPE = &H80

    FADF_BSTR = &H100
    FADF_UNKNOWN = &H200
    FADF_DISPATCH = &H400
    FADF_VARIANT = &H800
    FADF_RESERVED = &HF008
End Enum

Public Declare Sub RtlMoveMemory Lib "kernel32" ( _
                   ByRef pDst As Any, _
                   ByRef pSrc As Any, _
                   ByVal bLength As Long)

Public Declare Sub RtlZeroMemory Lib "kernel32" ( _
                   ByRef pDst As Any, _
                   ByVal bLength As Long)

Public Declare Function ArrPtr Lib "msvbvm60" _
                        Alias "VarPtr" ( _
                        ByRef pArr() As Any) As Long

Public Sub New_UDTPtr(ByRef this As TUDTPtr, _
                      ByVal Feature As SAFeature, _
                      ByVal bytesPerElement As Long, _
                      Optional ByVal CountElements As Long = 1, _
                      Optional ByVal lLBound As Long = 0)

    With this
        .pSA = VarPtr(.cDims)
        .cDims = 1
        .cbElements = bytesPerElement
        .fFeatures = CInt(Feature)
        .cElements = CountElements
        .lLBound = lLBound
    End With

    Debug.Print UDTPtrToString(this)

End Sub

' Um zu überprüfen ob der UDTPtr auch das enthält was er soll
' kann man folgende Funktion verwenden
Public Function UDTPtrToString(this As TUDTPtr) As String

    Dim s As String

    With this
        s = s & "pSA        : " & CStr(.pSA) & vbCrLf
        s = s & "Reserved   : " & CStr(.Reserved) & vbCrLf
        s = s & "cDims      : " & CStr(.cDims) & vbCrLf
        s = s & "fFeatures  : " & FeaturesToString(CLng(.fFeatures)) & vbCrLf
        s = s & "cbElements : " & CStr(.cbElements) & vbCrLf
        s = s & "cLocks     : " & CStr(.cLocks) & vbCrLf
        s = s & "pvData     : " & CStr(.pvData) & vbCrLf
        s = s & "cElements  : " & CStr(.cElements) & vbCrLf
        s = s & "lLBound    : " & CStr(.lLBound) & vbCrLf
    End With

    UDTPtrToString = s

End Function

Private Function FeaturesToString(ByVal Feature As SAFeature) As String

    Dim s As String
    Dim sOr As String: sOr = " Or "

    If Feature And FADF_AUTO Then s = s & IIf(Len(s), sOr, vbNullString): s = s & "FADF_AUTO"
    If Feature And FADF_STATIC Then s = s & IIf(Len(s), sOr, vbNullString): s = s & "FADF_STATIC"

    If Feature And FADF_EMBEDDED Then s = s & IIf(Len(s), sOr, vbNullString): s = s & _
        "FADF_EMBEDDED"

    If Feature And FADF_FIXEDSIZE Then s = s & IIf(Len(s), sOr, vbNullString): s = s & _
        "FADF_FIXEDSIZE"

    If Feature And FADF_RECORD Then s = s & IIf(Len(s), sOr, vbNullString): s = s & "FADF_RECORD"
    If Feature And FADF_HAVEIID Then s = s & IIf(Len(s), sOr, vbNullString): s = s & "FADF_HAVEIID"

    If Feature And FADF_HAVEVARTYPE Then s = s & IIf(Len(s), sOr, vbNullString): s = s & _
        "FADF_HAVEVARTYPE"

    If Feature And FADF_BSTR Then s = s & IIf(Len(s), sOr, vbNullString): s = s & "FADF_BSTR"
    If Feature And FADF_UNKNOWN Then s = s & IIf(Len(s), sOr, vbNullString): s = s & "FADF_UNKNOWN"

    If Feature And FADF_DISPATCH Then s = s & IIf(Len(s), sOr, vbNullString): s = s & _
        "FADF_DISPATCH"

    If Feature And FADF_VARIANT Then s = s & IIf(Len(s), sOr, vbNullString): s = s & "FADF_VARIANT"

    If Feature And FADF_RESERVED Then s = s & IIf(Len(s), sOr, vbNullString): s = s & _
        "FADF_RESERVED"

    FeaturesToString = s

End Function

' -------- Ende Modul "ModUDTPtr" alias ModUDTPtr.bas --------

' --- Anfang Modul "ModCharPointer" alias ModCharPointer.bas ---

Option Explicit

Public Type TCharPointer
    pudt    As TUDTPtr
    Chars() As Integer
End Type

Public Sub New_CharPointer(ByRef this As TCharPointer, ByRef StrVal As String)

    With this

        Call New_UDTPtr(.pudt, FADF_AUTO Or FADF_FIXEDSIZE, 2, Len(StrVal), 1)

        With .pudt
            .pvData = StrPtr(StrVal)
        End With

        Call RtlMoveMemory(ByVal ArrPtr(.Chars), ByVal VarPtr(.pudt), 4)

    End With

End Sub

Public Sub DeleteCharPointer(ByRef this As TCharPointer)

    With this

        Call RtlZeroMemory(ByVal ArrPtr(.Chars), 4)

    End With

End Sub

' --- Ende Modul "ModCharPointer" alias ModCharPointer.bas ---

' ------ Anfang Klasse "StopWatch" alias StopWatch.cls  ------

Option Explicit

' Class StopWatch
' Namespace System.Diagnostics
' Der Datentyp Currency in VB ist ein 64Bit-Datentyp mit einem
' Festpunktanteil. D.h. beim Bitwert &H2710 (bzw decimal 10000)
' ist der Wert 1 definiert, bzw. der kleinste positive Wert des
' Datentyps Currency ist 0.0001
' Da die Einheit Ticks ebenfalls den Parameter 10000 beinhaltet,
' ist der VB-Datentyp Currency genau der richtige Datentyp für
' Zeitmessungen mit der QueryPerformance-API
Private mFrequency        As Currency
Private mIsHighResolution As Boolean
Private mIsRunning        As Boolean
Private mStartTimeStamp   As Currency
Private mElapsed          As Currency
Private mTickFrequency    As Double

' In der gleihnamigen VB.Net-Klasse wird hier der Datentyp Long,
' bzw Int64 verwendet.
' Der Korrekturfaktor für den Datentyp Currency
Private Const CurCorrect          As Long = 10000
Private Const TicksPerMillisecond As Long = 10000 / CurCorrect    ' &H2710
Private Const TicksPerSecond      As Long = 10000000 / CurCorrect ' &H989680

Private Declare Function QueryPerformanceCounter Lib "kernel32" ( _
                         ByRef lpPerformanceCount As Currency) As Long

Private Declare Function QueryPerformanceFrequency Lib "kernel32" ( _
                         ByRef lpFrequency As Currency) As Long

Private Declare Sub RtlMoveMemory Lib "kernel32" ( _
                    ByRef pDst As Any, _
                    ByRef pSrc As Any, _
                    ByVal bytLength As Long)

Private Sub Class_Initialize()

    If Not (QueryPerformanceFrequency(mFrequency) = 1) Then
        mIsHighResolution = False
        mFrequency = TicksPerSecond
        mTickFrequency = 1
    Else
        mIsHighResolution = True
        mTickFrequency = (TicksPerSecond / CDbl(mFrequency))
    End If

End Sub

' Public Function GetTimestamp() As Currency 'Long 'LongInt
Public Function GetTimestamp() As Currency

    GetTimestamp = pGetTimestamp * CurCorrect

End Function

Private Function pGetTimestamp() As Currency

    If mIsHighResolution Then

        Call QueryPerformanceCounter(pGetTimestamp)

    Else
        pGetTimestamp = DateTime.Now
    End If

End Function

Public Sub Start()

    If Not mIsRunning Then
        mStartTimeStamp = pGetTimestamp
        mIsRunning = True
    End If

End Sub

Public Function StartNew() As StopWatch

    Set StartNew = New StopWatch

    Call StartNew.Start

End Function

Public Sub SStop()

    If IsRunning Then

        Dim c As Currency: c = (pGetTimestamp - mStartTimeStamp)

        mElapsed = (mElapsed + c)
        mIsRunning = False
    End If

End Sub

Public Sub Reset()

    mElapsed = 0
    mIsRunning = False
    mStartTimeStamp = 0

End Sub

' Shared-Member Properties
Public Property Get Frequency() As Currency

    ' Diese Multiplikation mit CurCorrect ist nur dazu da, die Klasse
    ' nach außen hin konsistent zu halten mit der gleichnamigen Klasse
    ' aus dem .netFX
    Frequency = mFrequency * CurCorrect

End Property

Public Property Get IsHighResolution() As Boolean

    IsHighResolution = mIsHighResolution

End Property

' #################### '   Public Properties   ' #################### '
Public Property Get ElapsedToString() As String ' TimeSpan

    ElapsedToString = TimeSpanToString(GetElapsedDateTimeTicks)

End Property

Private Function TimeSpanToString(ByVal ticks As Currency) As String

    Dim b As String
    Dim h As Long, m As Long, s As Long, n As Long
    Dim days As Long:  days = CInt((ticks / 86400000))
    Dim time As Currency: time = (ticks Mod 86400000)

    If (ticks < 0) Then
        b = b & "-"
        days = -days
        time = -time
    End If

    If (days <> 0) Then
        b = b & CStr(days) & "."
    End If

    ' Stunden
    h = CInt(((time \ 3600000) Mod 24))
    b = b & IntToString(h, 2) & ":"

    ' Minuten
    m = CInt(((time \ 60000) Mod 60))
    b = b & IntToString(m, 2) & ":"

    ' Sekunden
    s = CInt(((time \ 1000) Mod 60))
    b = b & IntToString(s, 2)

    n = (ticks - (CCur(h) * CCur(3600000)) - (CCur(m) * CCur(60000)) - (CCur(s) * CCur( _
        1000))) * 10000

    If (n <> 0) Then
        b = b & "."
        b = b & IntToString(n, 7)
    End If

    TimeSpanToString = b

End Function

Private Function IntToString(ByVal n As Long, ByVal digits As Long) As String

    Dim l As Long

    IntToString = CStr(n)
    l = Len(IntToString)

    If l < digits Then IntToString = String$(digits - l, "0") & IntToString

End Function

Public Property Get ElapsedMilliseconds() As Currency ' Long 'LongInt

    ElapsedMilliseconds = GetElapsedDateTimeTicks / TicksPerMillisecond

End Property

Public Property Get ElapsedTicks() As Currency ' As Long 'LongInt

    ElapsedTicks = GetRawElapsedTicks * CurCorrect

End Property

Public Property Get IsRunning() As Boolean

    IsRunning = mIsRunning

End Property

' #################### '   Private Functions   ' #################### '
Private Function GetElapsedDateTimeTicks() As Currency

    Dim rawElapsedTicks As Currency: rawElapsedTicks = GetRawElapsedTicks

    If mIsHighResolution Then

        Dim d As Double: d = CDbl(rawElapsedTicks)
        d = (d * mTickFrequency)
        GetElapsedDateTimeTicks = CCur(d)
    Else
        GetElapsedDateTimeTicks = rawElapsedTicks
    End If

End Function

Private Function GetRawElapsedTicks() As Currency

    Dim Elapsed As Currency: Elapsed = mElapsed

    If mIsRunning Then

        Dim c As Currency: c = (GetTimestamp - mStartTimeStamp)

        Elapsed = (Elapsed + c)
    End If

    GetRawElapsedTicks = Elapsed

End Function

' ------- Ende Klasse "StopWatch" alias StopWatch.cls  -------

' -------------- Ende Projektdatei Projekt1.vbp --------------

	

Diskussion  

Diese Funktion ermöglicht es, Fragen, die die Veröffentlichung des Tipps betreffen, zu klären, oder Anregungen und Verbesserungsvorschläge einzubringen. Nach der Veröffentlichung des Tipps werden diese Beiträge nicht weiter verlinkt. Allgemeine Fragen zum Inhalt sollten daher hier nicht geklärt werden.

Um eine Diskussion eröffnen zu können, müssen sie angemeldet sein.