Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0374: Wurzelberechnung nach dem Heronverfahren

VB 5/6-Tipp 0374: Wurzelberechnung nach dem Heronverfahren

 von Marc Ermshaus

Schwierigkeitsgrad:

Verwendete API-Aufrufe: keine

Download: Download des Beispielprojektes [3,6 KB]

'Dieser Quellcode 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 Project1.vbp -------------
'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Textfeld "txtAuswahl2"
' Steuerelement: Textfeld "txtAuswahlProdukt"
' Steuerelement: Textfeld "txtAuswahl1"
' Steuerelement: Textfeld "txtAnzahl"
' Steuerelement: Schaltfläche "cmdQuadratzahlen"
' Steuerelement: Listen-Steuerelement "lstProdukt"
' Steuerelement: Schaltfläche "cmdWurzelZiehen"
' Steuerelement: Listen-Steuerelement "lstResultat2"
' Steuerelement: Listen-Steuerelement "lstResultat1"
' Steuerelement: Textfeld "txtEingabe"
' Steuerelement: Beschriftungsfeld "lblEchteWurzel"
' Steuerelement: Linien-Steuerelement "Line1"
' Steuerelement: Beschriftungsfeld "txtWurzel"


'Autor: Marc Ermshaus
'E-Mail: marcermshaus@aol.com

Option Explicit

Private AusgangsZahl As Double
Private Resultat1 As Double
Private Resultat1ListIndex As Integer
Private Resultat2 As Double
Private Resultat2ListIndex As Integer
Private Wurzel As Double
Private Zahl As Integer
Private Fertig As Boolean
Private ProduktListIndex As Integer
Private TooltipsZeigen As Boolean

Private Sub cmdQuadratzahlen_Click()
    Zahl = 0
    lstResultat1.Clear
    lstResultat2.Clear
    lstProdukt.Clear
    
    If Len(txtAnzahl.Text) = 0 Or _
        IsNumeric(txtAnzahl.Text) = False Then
        
        txtEingabe.Text = "ERROR"
        Exit Sub
    End If
    
    txtWurzel.Caption = "Berechne ..."
    lblEchteWurzel.Caption = ""
    
    DoEvents
    
    Do
        Zahl = Zahl + 1
        
        lstResultat1.AddItem Zahl
        lstResultat2.AddItem Zahl ^ 2
        lstProdukt.AddItem Zahl ^ 3
    Loop Until Zahl = txtAnzahl.Text
    
    txtWurzel.Caption = "In der ersten Liste steht die " & _
        "Ausgangszahl, in der zweiten diese Zahl hoch 2 " & _
        "und in der dritten hoch 3."
    
    lblEchteWurzel.Caption = ""
End Sub

Private Sub cmdWurzelZiehen_Click()
    Fertig = False
    
    Resultat1 = 0
    Resultat2 = 0
    Resultat1ListIndex = 0
    Resultat2ListIndex = 0
    ProduktListIndex = 0
    
    lstResultat1.Clear
    lstResultat2.Clear
    lstProdukt.Clear
    
    AusgangsZahl = 0
    
    If IsNumeric(txtEingabe.Text) = False _
        Or txtEingabe.Text = "0" Then
        
        txtEingabe.Text = "ERROR"
        Exit Sub
    End If
    
    AusgangsZahl = txtEingabe.Text
    
    Resultat1 = 1
    Resultat2 = AusgangsZahl
    
    lstResultat1.List(0) = Resultat1
    lstResultat2.List(0) = AusgangsZahl
    lstProdukt.List(0) = lstResultat1.List(0) _
                         * lstResultat2.List(0)
    
    txtWurzel.Caption = "Berechne ..."
    
    DoEvents
    Call HeronMethode
End Sub

Private Sub HeronMethode()
    Do Until Fertig = True
        Resultat1 = (Resultat1 + Resultat2) / 2
        Resultat2 = AusgangsZahl / Resultat1
        
        Resultat1ListIndex = Resultat1ListIndex + 1
        lstResultat1.List(Resultat1ListIndex) = Resultat1
        Resultat2ListIndex = Resultat2ListIndex + 1
        lstResultat2.List(Resultat2ListIndex) = Resultat2
        ProduktListIndex = ProduktListIndex + 1
        
        lstProdukt.List(ProduktListIndex) = Resultat1 * Resultat2
        
        If Resultat1 - Resultat2 < 0.0000000009 Then Fertig = True
        If Resultat1 = Resultat2 Then Fertig = True
    Loop
    
    'Falls Zahlen verschieden sind, wird gemittelt
    If Resultat1 <> Resultat2 Then
        Resultat1 = (Resultat1 + Resultat2) / 2
        Resultat2 = Resultat1

        lstResultat1.AddItem "___________________________"
        lstResultat2.AddItem "___________________________"
        lstProdukt.AddItem "_________"
        lstResultat1.AddItem Resultat1
        lstResultat2.AddItem Resultat2
        
        lstProdukt.AddItem Resultat1 * Resultat2
    End If
  
    txtWurzel.Caption = "Die Wurzel aus " & AusgangsZahl & _
        " lautet " & Resultat1 & "."
                      
    lblEchteWurzel.Caption = "Die mit der sqr-Funktion " & _
        "ermittelte Wurzel der Zahl " & AusgangsZahl & " lautet " & _
        Sqr(AusgangsZahl) & "."
        
    With txtEingabe
        .SelStart = 0
        .SelLength = Len(txtEingabe.Text)
        .SetFocus
    End With
End Sub

Private Sub lstResultat1_Click()
    lstResultat2.ListIndex = lstResultat1.ListIndex
    lstProdukt.ListIndex = lstResultat1.ListIndex
    
    lstResultat1.TopIndex = lstResultat1.ListIndex
    
    lstResultat2.TopIndex = lstResultat1.TopIndex
    lstProdukt.TopIndex = lstResultat1.TopIndex
    
    txtAuswahl1.Text = lstResultat1.Text
    txtAuswahl2.Text = lstResultat2.Text
    txtAuswahlProdukt.Text = lstProdukt.Text
End Sub

Private Sub lstResultat2_Click()
    lstResultat1.ListIndex = lstResultat2.ListIndex
    lstProdukt.ListIndex = lstResultat2.ListIndex
    
    lstResultat2.TopIndex = lstResultat2.ListIndex
    
    lstResultat1.TopIndex = lstResultat2.TopIndex
    lstProdukt.TopIndex = lstResultat2.TopIndex
    
    txtAuswahl1.Text = lstResultat1.Text
    txtAuswahl2.Text = lstResultat2.Text
    txtAuswahlProdukt.Text = lstProdukt.Text
End Sub
'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Project1.vbp --------------

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 2 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.