Functies: code

• De controle op de gegevens
  Private Sub Text1_Change()
  On Error Resume Next
  geheugen = Text1.Text
  If IsNumeric(Text1.Text) Then
  cmdAfrEen.Enabled = True
  cmdAfrTien.Enabled = True
  cmdAfrTiende.Enabled = True
  cmdCNVRomeins.Enabled = False
  cmdbreuk.Enabled = True
  cmdDec.Enabled = False
  cmdMail.Enabled = False
  cmdURL.Enabled = False
  Else
  cmdAfrEen.Enabled = False
  cmdAfrTien.Enabled = False
  cmdAfrTiende.Enabled = False
  cmdCNVDec.Enabled = True
  cmdbreuk.Enabled = False
  cmdDec.Enabled = True
  cmdMail.Enabled = True
  cmdURL.Enabled = True
  End If
  End Sub
• Het oproepen van de functies
  Dim geheugen As Variant
  Private Sub cmdAfrEen_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = afronden(Text1.Text, 1)
  End Sub
  
  Private Sub cmdAfrTien_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = afronden(Text1.Text, 10)
  End Sub
  
  Private Sub cmdAfrTiende_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = afronden(Text1.Text, 1 / 10)
  End Sub
  
  Private Sub cmdbreuk_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = breuk(Text1.Text)
  End Sub
  
  Private Sub cmdCNVDec_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = dectorom(Text1.Text)
  End Sub
  
  Private Sub cmdCNVRomeins_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = romtodec(Text1.Text)
  End Sub
  
  Private Sub cmdDec_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = breuktogetal(Text1.Text)
  End Sub
  
  Private Sub cmdInvers_Click()
  On Error Resume Next
  geheugen = Text1.Text
  Text1.Text = Inverteer(Text1.Text)
  End Sub
  
  Private Sub cmdMail_Click()
  On Error Resume Next
  emailanalyse (Text1.Text)
  End Sub
  
  Private Sub cmdURL_Click()
  On Error Resume Next
  URLanalyse (Text1.Text)
  End Sub
  
  Private Sub cmdVorige_Click()
  On Error Resume Next
  Text1.Text = geheugen
  End Sub
  
  Private Sub Command1_Click()
  End
  End Sub
  
• De eigenlijke functies
  Function max(a As Double, b As Double) As Double
  Select Case b > a
  Case True
  max = b
  Case Else
  max = a
  End Select
  End Function
  Function min(a As Double, b As Double) As Double
  Select Case b < a
  Case True
  min = b
  Case Else
  min = a
  End Select
  End Function
  Function zonderaccent(accentstring As String) As String
  Dim buffer As String
  Dim teken As String * 1
  Dim nr As Integer
  For nr = 1 To Len(accentstring)
  teken = Mid(accentstring, nr, 1)
  Select Case teken
  Case "à", "á", "â", "ä"
  buffer = buffer & "a"
  Case "ç"
  buffer = buffer & "c"
  Case "è", "é", "ê", "ë"
  buffer = buffer & "e"
  Case "ì", "í", "î", "ï"
  buffer = buffer & "i"
  Case "ò", "ó", "ô", "ö"
  buffer = buffer & "o"
  Case "ù", "ú", "û", "ü"
  buffer = buffer & "u"
  Case Else
  buffer = buffer & teken
  End Select
  Next nr
  zonderaccent = buffer
  End Function
  Function breuktogetal(breuk As String) As Double
  Dim geheel As Integer
  Dim teller As Integer
  Dim noemer As Integer
  Dim buffer1 As String
  Dim buffer2 As String
  Dim buffer3 As String
  Dim scheiding1 As Integer
  Dim scheiding2 As Integer
  Dim p As Integer
  For p = 1 To Len(breuk)
  If Mid(breuk, p, 1) = " " Then scheiding1 = p
  If Mid(breuk, p, 1) = "/" Then scheiding2 = p
  Next p
  If scheiding1 < scheiding2 Then
  geheel = CInt(Mid(breuk, 1, scheiding1 - 1))
  teller = CInt(Mid(breuk, scheiding1 + 1, scheiding2 - scheiding1 - 1))
  noemer = CInt(Mid(breuk, scheiding2 + 1, p - scheiding2))
  End If
  breuktogetal = geheel + teller / noemer
  End Function
  Function breuk(decgetal As Double) As String
  Dim geheel As Integer
  Dim teller As Integer
  Dim noemer As Integer
  Dim rest As Double
  Dim p As Long
  geheel = Int(decgetal)
  rest = decgetal - geheel
  For p = 2 To 100000
  If Int(rest * p + 0.000001) = rest * p Then
  noemer = p
  teller = rest * noemer
  Exit For
  End If
  Next p
  If noemer = 0 Then
  MsgBox "Niet gevonden"
  Exit Function
  End If
  breuk = CStr(geheel & " " & teller & "/" & noemer)
  End Function
  Function romtodec(roman As String) As Integer
  Dim buffer As Integer
  Dim thisnumber As String * 1
  Dim nextnumber As String * 1
  Dim number As Integer
  Dim p As Integer
  For p = Len(roman) To 1 Step -1
  thisnumber = UCase(Mid$(roman, p, 1))
  Select Case thisnumber
  Case "M"
  buffer = buffer + 1000
  Case "D"
  buffer = buffer + 500
  Case "C"
  If UCase(nextnumber) = "M" Then
  buffer = buffer - 100
  Else
  buffer = buffer + 100
  End If
  Case "L"
  buffer = buffer + 50
  
  Case "X"
  If UCase(nextnumber) = "C" Then
  buffer = buffer - 10
  Else
  buffer = buffer + 10
  End If
  Case "V"
  buffer = buffer + 5
  Case "I"
  If UCase(nextnumber) = "V" Or UCase(nextnumber) = "X" Then
  buffer = buffer - 1
  Else
  buffer = buffer + 1
  End If
  Case Else
  MsgBox "Dit is geen Romeins cijfer"
  Exit Function
  End Select
  nextnumber = thisnumber
  Next p
  romtodec = buffer
  End Function
  Function dectorom(decgetal As Integer) As String
  Dim buffer As String
  Dim restgetal As Integer
  Dim test As Integer
  If decgetal > 5000 Or decgetal < 1 Then
  dectorom = "FOUT"
  Exit Function
  End If
  restgetal = decgetal
  'Duizentallen
  Do
  test = restgetal - 1000
  If Not test < 0 Then
  buffer = buffer & "M"
  restgetal = restgetal - 1000
  End If
  Loop Until test < 1000
  'Negenhonderd
  test = restgetal - 900
  If Not test < 0 Then
  buffer = buffer & "CM"
  restgetal = restgetal - 900
  End If
  'Vijfhonderd
  test = restgetal - 500
  If Not test < 0 Then
  buffer = buffer & "D"
  restgetal = restgetal - 500
  End If
  'Honderd
  Do
  test = restgetal - 100
  If Not test < 0 Then
  buffer = buffer & "C"
  restgetal = restgetal - 100
  End If
  Loop Until test < 100
  'Vijftig
  test = restgetal - 50
  If Not test < 0 Then
  buffer = buffer & "L"
  restgetal = restgetal - 50
  End If
  'Tientallen
  Do
  test = restgetal - 10
  If Not test < 0 Then
  buffer = buffer & "X"
  restgetal = restgetal - 10
  End If
  Loop Until test < 10
  'Negen
  test = restgetal - 9
  If Not test < 0 Then
  buffer = buffer & "IX"
  restgetal = restgetal - 9
  End If
  'Vijf
  test = restgetal - 5
  If Not test < 0 Then
  buffer = buffer & "V"
  restgetal = restgetal - 5
  End If
  'Vier
  test = restgetal - 4
  If Not test < 0 Then
  buffer = buffer & "IV"
  restgetal = restgetal - 4
  End If
  'Eenheden
  Do
  test = restgetal - 1
  If Not test < 0 Then
  buffer = buffer & "I"
  restgetal = restgetal - 1
  End If
  Loop Until test < 0
  'Stop
  dectorom = buffer
  End Function
  Function Inverteer(te_inverteren_string As String) As String
  Dim buffer As String
  Dim p As Integer
  For p = Len(te_inverteren_string) To 1 Step -1
  buffer = buffer & Mid$(te_inverteren_string, p, 1)
  Next p
  Inverteer = buffer
  End Function
  Function afronden(getal As Double, precisie As Double) As Double
  Dim buffer As Double
  buffer = Int(getal / precisie + 1 / 2) * precisie
  afronden = buffer
  End Function
  
  Function ispriem(getal As Long) As Boolean
  Dim x As Long
  Dim deelbaar As Boolean
  For x = 3 To Sqr(Sqr(getal * getal))
  If (getal \ x) * x = getal Then deelbaar = True
  Next x
  ispriem = Not deelbaar
  End Function
  Function voorslash(instring As String) As String
  Dim temp As String
  Dim buffer As String
  Dim pos As Integer
  For pos = 1 To Len(instring)
  temp = Mid(instring, pos, 1)
  If Not temp = "/" Then
  buffer = buffer & temp
  Else
  Exit For
  End If
  Next pos
  voorslash = buffer
  End Function
  Function naslash(instring As String) As String
  Dim temp As String
  Dim buffer As String
  Dim pos As Integer
  For pos = Len(instring) To 1 Step -1
  temp = Mid(instring, pos, 1)
  If Not temp = "/" Then
  buffer = temp & buffer
  Else
  Exit For
  End If
  Next pos
  naslash = buffer
  End Function
  Function voorpunt(instring As String) As String
  Dim temp As String
  Dim buffer As String
  Dim pos As Integer
  For pos = 1 To Len(instring)
  temp = Mid(instring, pos, 1)
  If Not temp = "." Then
  buffer = buffer & temp
  Else
  Exit For
  End If
  Next pos
  voorpunt = buffer
  End Function
  Function napunt(instring As String) As String
  Dim temp As String
  Dim buffer As String
  Dim pos As Integer
  For pos = Len(instring) To 1 Step -1
  temp = Mid(instring, pos, 1)
  If Not temp = "." Then
  buffer = temp & buffer
  Else
  Exit For
  End If
  Next pos
  napunt = buffer
  End Function
  Sub URLanalyse(URL As String)
  Dim temp As String
  Dim server As String
  Dim domein As String
  Dim bestand As String
  Dim msg As String
  If napunt(URL) = "htm" Or napunt(URL) = "html" Or napunt(URL) = "gif" Or napunt(URL) = "jpg" Or napunt(URL) = "jpeg" Then
  bestand = naslash(URL)
  msg = vbCrLf & "bestand: " & bestand
  End If
  If napunt(voorslash(URL)) = "com" Or napunt(voorslash(URL)) = "be" Or napunt(voorslash(URL)) = "nl" Then
  server = voorslash(URL)
  domein = napunt(server)
  msg = "server: " & server & vbCrLf & "domein: " & domein & msg
  End If
  If Not msg = "" Then MsgBox msg, , URL
  End Sub
  Sub emailanalyse(emailadres As String)
  Dim x As Integer
  Dim ID As String
  Dim server As String
  Dim domein As String
  Dim msg As String
  For x = 1 To Len(emailadres)
  If Mid(emailadres, x, 1) = "@" Then
  ID = Mid(emailadres, 1, x - 1)
  server = Mid(emailadres, x + 1, Len(emailadres) - x)
  End If
  If Mid(emailadres, x, 1) = "." Then
  domein = Mid(emailadres, x + 1, Len(emailadres) - x)
  End If
  Next x
  MsgBox "ID: " & ID & vbCrLf & "Server: " & server & vbCrLf & "Domein: " & domein
  End Sub
  

[VB Web] - [hlrnet] - [copyright]