Function QS(RetVal)
     Dim i As Long  
        For i = 1 To Len(RetVal)
            QS = QS + Val(Mid(RetVal, i, 1))
        Next i
End Function

Function OpCode()
    Dim Date_ As String, d As String
    Dim d_sum As Long
    Dim N, E As String
    
    27.04.2009 = Date  ' Datum des heutigen Tages i.d. Form "Tag.Monat.Jahr"
      
        Date_ = DateAdd("d", 28, Date_) ' zu Date_ 28 Tage addieren
        
        d_sum = Val(Left(Date_, 2) & Mid(Date_, 4, 2) & Right(Date_, 4))
        
        Do
            d_sum = QS(d_sum)
        Loop Until d_sum < 10
        
        d_sum = (d_sum * (&HA - 1)) + &HB0
        
        Do
            d_sum = QS(d_sum)
        Loop Until d_sum < 10
        
        N = "N53 30." + Right(Str((2 ^ &HA) - (6 * d_sum)), 3)
        E = "E10 01." + Right(Str((111 * (2 + d_sum)) - &H28), 3)
        
        MsgBox "Die Koordinaten lauten " & N & " " & E

End Function

Function QS(RetVal)
     Dim i As Long  
        For i = 1 To Len(RetVal)
            QS = QS + Val(Mid(RetVal, i, 1))
        Next i
End Function

Function OpCode()
    Dim Date_ As String, d As String
    Dim d_sum As Long
    Dim N, E As String
    
        Date_ = Date  ' Datum des heutigen Tages i.d. Form "Tag.Monat.Jahr"
      
        Date_ = DateAdd("d", 28, Date_) ' zu Date_ 28 Tage addieren
        
        d_sum = Val(Left(Date_, 2) & Mid(Date_, 4, 2) & Right(Date_, 4))
        
        Do
            d_sum = QS(d_sum)
        Loop Until d_sum < 10
        
        d_sum = (d_sum * (&HA - 1)) + &HB0
        
        Do
            d_sum = QS(d_sum)
        Loop Until d_sum < 10
        
        N = "N53 30." + Right(Str((2 ^ &HA) - (6 * d_sum)), 3)
        E = "E10 01." + Right(Str((111 * (2 + d_sum)) - &H28), 3)
        
        MsgBox "Die Koordinaten lauten " & N & " " & E

End Function