Wenn man hin und wieder passive Bauteile, wie Widerstände, Kondensatoren und Spulen berechnet, kommt man meist in Kontakt mit den nach DIN genormten E-Reihen. Mit dem angefügten Modul werden nun diese Normreihen generiert und die Hauptfunktion gibt einen Wert aus dieser Reihe zurück, der dem Übergabewert am nächsten kommt. Fügen Sie folgenden Code in einem Modul: Option Explicit ' Die genormten E-Reihen Public Enum E_Typen E3 = 3 E6 = 6 E12 = 12 E24 = 24 E48 = 48 E96 = 96 E192 = 192 End Enum ' Die Grundeinheiten ' Wenn das Ausgabecontrol, auf denen die Werte ausgegeben werden, ' auf eine Unicode-Schriftart gesetzt ist und Griechisch als Script ' gewählt wurde, kann auch das Omega angezeigt werden. ' Beim Aufruf der Function "E-Wert_finden" wird je nach Wahl der ' Einheit das Wort "Ohm" oder das Zeichen Omega zurückgegeben. Public Enum B_Einheiten Farad = 1 Henry = 2 Omega = 3 Ohm = 4 End Enum ' Für die Rückgabe der Bauteildaten Public Type Bauteil dblWert As Double strWert As String eTol As String End Type Public Function E_Wert_finden( _ ByVal Reihe As E_Typen, _ ByVal WertInGrundeinheit As Double, _ ByRef Einheit As B_Einheiten) As Bauteil ' Übergabeparameter ' 1. die E-Reihe, in welcher der nächstgelegene Wert gefunden ' werden soll ' 2. Der Übergabewert in Ohm, Henry oder Farad ' 3. Die Maßeinheit (Ohm, Henry, Farad) ' ' Zurückgegeben wird ein Variablentype mit ... ' - dem gefundenen nächstgelegenem E-Normwert in der ' Grundeinheit (Ohm, Henry, Farad) ' - dem Rückgabewert als String mit passendem Suffix ' und dem Einheitenzeichen ' - die Toleranzklasse der E-Normreihe Dim E() As Double Dim tmp As Integer Dim Counter As Integer Dim Found1 As Integer Dim Found2 As Integer Dim Abstand1 As Double Dim Abstand2 As Double Dim Faktor As Double Dim RetVal As Double Dim Toleranz As String Dim Suffix As String If WertInGrundeinheit <= 0 Then Exit Function On Error GoTo Fehler ' Wertefeld initialisieren, welches die ' E-Normwerte beinnhaltet tmp = Reihe ReDim E(0 To tmp) E(UBound(E())) = 1000 For Counter = 0 To tmp - 1 If tmp >= 48 Then E(Counter) = (Round((10 ^ (Counter / tmp)), 2)) * 100 Else E(Counter) = Round(((Round((10 ^ (Counter / tmp)), 2)) * 10), 0) * 10 ' Nach der Formel errechnete Werte zwischen 260 und 460 ' entsprechen nicht der DIN-Norm If E(Counter) >= 260 And E(Counter) <= 460 Then E(Counter) = E(Counter) + 10 End If End If Next ' Toleranz der E-Reihen: Select Case tmp Case 3: Toleranz = ">20%" Case 6: Toleranz = "20%" Case 12: Toleranz = "10%" Case 24: Toleranz = "5%" Case 48: Toleranz = "2%" Case 96: Toleranz = "1%" Case 192: Toleranz = "0,5%" End Select ' Eingabewert umformatieren Faktor = 1 If WertInGrundeinheit >= 1000 Then Do Until WertInGrundeinheit < 1000 WertInGrundeinheit = WertInGrundeinheit / 10 Faktor = Faktor * 10 Loop ElseIf WertInGrundeinheit < 100 Then Do Until WertInGrundeinheit >= 100 WertInGrundeinheit = WertInGrundeinheit * 10 Faktor = Faktor / 10 Loop End If ' Variablenfeld absuchen nach den nächstgelegenen 2 Werten For Counter = 0 To UBound(E()) Abstand1 = WertInGrundeinheit - E(Counter) If Abstand1 <= 0 Then Found1 = Counter: Exit For Next If Counter > 0 Then Abstand2 = WertInGrundeinheit - E(Counter - 1) Found2 = Counter - 1 End If ' Auswerten welcher Wert am nächsten ist Abstand1 = Abs(Abstand1) Abstand2 = Abs(Abstand2) If Abstand1 = Abstand2 Or Abstand1 < Abstand2 Then RetVal = E(Found1) Else RetVal = E(Found2) End If ' Wert mit Faktor multiplizieren und in die ' Rückgabewerte auffüllen RetVal = RetVal * Faktor E_Wert_finden.dblWert = RetVal E_Wert_finden.eTol = Toleranz ' Maßeinheit und Suffix anhängen Select Case Einheit Case 1: Suffix = "F" Case 2: Suffix = "H" Case 3: Suffix = ChrW(217) Case 4: Suffix = "Ohm" End Select E_Wert_finden.strWert = FormatEinheit(RetVal) & Suffix Exit Function Fehler: MsgBox "Fehler Nr: " & Err.Number, vbCritical End Function Public Function FormatEinheit(Wert As Double) As String ' Hier wird ein Widerstandswert, Spulenwert.. in der ' Grundform übergeben ' Zurückgeliefert wird ein Stirng mit dem Suffx und dem ' formatierten Wert Dim RetVal As Double Dim Suffix As String RetVal = Wert If RetVal >= 10 ^ 12 Then RetVal = RetVal / 10 ^ 12 Suffix = "T" ElseIf RetVal >= 10 ^ 9 Then RetVal = RetVal / 10 ^ 9 Suffix = "G" ElseIf RetVal >= 10 ^ 6 Then RetVal = RetVal / 10 ^ 6 Suffix = "M" ElseIf RetVal >= 10 ^ 3 Then RetVal = RetVal / 10 ^ 3 Suffix = "k" ElseIf RetVal < 10 ^ -9 Then RetVal = RetVal * 10 ^ 12 Suffix = "p" ElseIf RetVal < 10 ^ -6 Then RetVal = RetVal * 10 ^ 9 Suffix = "n" ElseIf RetVal < 10 ^ -3 Then RetVal = RetVal * 10 ^ 6 Suffix = "µ" ElseIf RetVal < 1 Then RetVal = RetVal * 10 ^ 3 Suffix = "m" End If Suffix = Format$(RetVal, "0.00") & " " & Suffix FormatEinheit = Suffix End Function Nun ein praktischer Anwendungsfall.
Option Explicit Private Sub Form_Load() Dim Counter As Integer ' Steuerelemente initialisieren Me.Caption = "LED Vorwiderstand berechnen" ' Textbox auf Griechisch setzten... ' dann können zwar keine Umlaute mehr angezeigt ' werden, aber das Omega Text1.Font = "Arial Unicode" Text1.Font.Charset = 161 Text1.FontBold = True Text1.FontSize = 12 For Counter = 10 To 50 Step 5 List1.AddItem "LED = 2,2 Volt - " & CStr(Counter) & " mA" List1.AddItem "LED = 3,4 Volt - " & CStr(Counter) & " mA" Next For Counter = 5 To 20 List2.AddItem "U-Versorgung = " & CStr(Counter) & " Volt" Next List1.Selected(0) = True List2.Selected(0) = True End Sub Private Sub List1_Click() ' Click auf die Liste = Vorwiderstand berechnen r_berechnen End Sub Private Sub List2_Click() ' Click auf die Liste = Vorwiderstand berechnen r_berechnen End Sub Private Sub r_berechnen() ' Vorwiderstand für LED bei der gewählten ' Veersorgungsspannung berechnen Dim E_Count As Integer Dim R_genau As Double Dim Uled As Double Dim Uein As Double Dim Iled As Double Dim ausStr As String Dim einStr As String Dim R_EReihe As Bauteil Dim Last As Double If List1.Text = "" Or List2.Text = "" Then Exit Sub ' Eingabewerte lesen einStr = List1.List(List1.ListIndex) Uled = CDbl(Mid$(einStr, 7, 3)) Iled = CDbl(Mid$(einStr, 18, 2)) einStr = List2.List(List2.ListIndex) Uein = CDbl(Mid$(einStr, 16, 2)) ' Vorwiderstand für die LED genau berechnen R_genau = (Uein - Uled) / Iled * 1000 ausStr = "Vorwiderstand genau: " & Format(R_genau, "0.0") & _ " " & ChrW(217) & vbCrLf & vbCrLf ' Alle E-Reihen durchlaufen E_Count = 3 Do While E_Count <= 192 ' Nächstgelegenen Wert finden R_EReihe = E_Wert_finden(E_Count, R_genau, Omega) ' Tatsächlichen Durchflußstrom für die LED berechnen Iled = ((Uein - Uled) / R_EReihe.dblWert) * 1000 ' Belastung Widerstand berechnen Last = (Uein - Uled) * Iled / 10 ' Ausgabedaten zusammenfassen ausStr = ausStr & "Bester Wert der E" & CStr(E_Count) & "-Reihe:" & vbCrLf & _ R_EReihe.strWert & vbCrLf & "Toleranzklasse Widerstand:" & vbCrLf & _ R_EReihe.eTol & vbCrLf & "Damit I-LED:" & vbCrLf & Format$(Iled, "0.00") & _ " mA" & vbCrLf & "Belastung Widerstand" & vbCrLf & Format$(Last, "0.00") & _ "mW" & vbCrLf & vbCrLf E_Count = E_Count * 2 Loop ' Daten ausgeben Text1.Text = ausStr End Sub Dieser Tipp wurde bereits 10.397 mal aufgerufen. Voriger Tipp | Zufälliger Tipp | Nächster Tipp
Anzeige
Diesen und auch alle anderen Tipps & Tricks finden Sie auch auf unserer aktuellen vb@rchiv Vol.6 (einschl. Beispielprojekt!) Ein absolutes Muss - Geballtes Wissen aus mehr als 8 Jahren vb@rchiv! - nahezu alle Tipps & Tricks und Workshops mit Beispielprojekten - Symbol-Galerie mit mehr als 3.200 Icons im modernen Look Weitere Infos - 4 Entwickler-Vollversionen (u.a. sevFTP für .NET), Online-Update-Funktion u.v.m. |
sevOutBar 4.0 Vertikale Menüleisten á la Outlook Erstellen von Outlook ähnlichen Benutzer- interfaces - mit beliebig vielen Gruppen und Symboleinträgen. Moderner OfficeXP-Style mit Farbverläufen, Balloon-Tips, u.v.m. Tipp des Monats Mai 2024 Hermann Röttger Wochentage eines Datumsbereichs ermitteln Wochentage eines Datumsbereichs ermitteln, optional mit Feiertagsberechnung TOP Entwickler-Paket TOP-Preis!! Mit der Developer CD erhalten Sie insgesamt 24 Entwickler- komponenten und Windows-DLLs. Die Einzelkomponenten haben einen Gesamtwert von 1605.50 EUR... |
||||||||||||||||
Microsoft, Windows und Visual Basic sind entweder eingetragene Marken oder Marken der Microsoft Corporation in den USA und/oder anderen Ländern. Weitere auf dieser Homepage aufgeführten Produkt- und Firmennamen können geschützte Marken ihrer jeweiligen Inhaber sein. |