Question calculate inbreeding (1 Viewer)

Public Function ParamInsert(TableName As String, TheFields As String, ParamArray TheValues() As Variant) As String
  Dim qdf As QueryDef
  Dim i As Integer
  Dim MyParams As New Collection
  Dim strMyParams As String
  Dim strSql As String
  For i = 0 To UBound(TheValues)
    MyParams.Add "Param" & i, "Param" & i
    If strMyParams = "" Then
      strMyParams = "[" & MyParams(i + 1) & "]"
    Else
      strMyParams = strMyParams & ", " & "[" & MyParams(i + 1) & "]"
    End If
  Next i
  strSql = "INSERT INTO " & TableName & " " & TheFields & " VALUES ( " & strMyParams & ")"
  ParamInsert = strSql
  Set qdf = CurrentDb.CreateQueryDef("TempQuery", strSql)
   For i = 0 To UBound(TheValues)
    qdf.Parameters(i) = TheValues(i)
  Next i
  qdf.Execute
  CurrentDb.QueryDefs.Delete ("tempquery")
End Function

Public Sub TestParamInsert()
  Dim TheFields As String
  Dim FirstName As Variant
  Dim LastName As Variant
  FirstName = Null  'demo null field
  LastName = "Smith"
  TheFields = InsertFields("FirstName", "LastName", "OrderID", "OrderDate")
  ParamInsert "MyTable", TheFields, FirstName, LastName, 1, Date
End Sub

Public Function GetRelation(bird1ID As Long, bird2ID As Long) As String
  Dim strSql As String
  Dim rs As DAO.Recordset
  
  If GetPairID(bird1ID) = GetPairID(bird2ID) Then
    GetRelation = GetRingNo(bird2ID) & " AND " & (GetRingNo(bird1ID)) & " are siblings."
    Exit Function
  End If
  'Check to see if a parent or higher
  strSql = "Select birdID, AncestorID, Generation from tbl_Pedigree where BirdID = " & bird1ID & " AND ancestorID = " & bird2ID
  Set rs = CurrentDb.OpenRecordset(strSql)
  
  If Not (rs.EOF And rs.BOF) Then
    Select Case rs!Generation
      Case 2
        GetRelation = GetRingNo(bird2ID) & " is the Parent of " & (GetRingNo(bird1ID))
      Case 3
        GetRelation = GetRingNo(bird2ID) & " is the Grand Parent of " & (GetRingNo(bird1ID))
      Case 4
        GetRelation = GetRingNo(bird2ID) & " is the Great Grand Parent of " & (GetRingNo(bird1ID))
      Case 5
        GetRelation = GetRingNo(bird2ID) & " is the Great Great GrandParent of " & (GetRingNo(bird1ID))
    End Select
  Else
   strSql = "Select birdID, AncestorID, Generation from tbl_Pedigree where BirdID = " & bird2ID & " AND ancestorID = " & bird1ID
   Set rs = CurrentDb.OpenRecordset(strSql)
   If Not (rs.EOF And rs.BOF) Then
    Select Case rs!Generation
      Case 2
        GetRelation = GetRingNo(bird1ID) & " is the Parent of " & (GetRingNo(bird2ID))
      Case 3
        GetRelation = GetRingNo(bird1ID) & " is the Grand Parent of " & (GetRingNo(bird2ID))
      Case 4
        GetRelation = GetRingNo(bird1ID) & " is the Great Grand Parent of " & (GetRingNo(bird2ID))
      Case 5
        GetRelation = GetRingNo(bird1ID) & " is the Great Great GrandParent of " & (GetRingNo(bird2ID))
    End Select
   End If
  End If
  
End Function

?getRelation(63,63)
5188 AND 5188 are siblings.

?GetRelation(105,106)
Not directly related.

?getRelation(32,145)
2273 KG is the Great Grand Parent of 4925-H

Private Sub Update_Distance_Click()
    On Error GoTo Update_Distance_Click_Error
    
    Dim vTown
    Dim VarD As String
    Dim Response As Integer
    

'====================================================
    If MsgBox("Do you have Internet Access ", vbYesNo, "You Need Internet Access") = vbYes Then
        Response = DATA_ERRADDED
    
        VarD = Me.Street & " " & Me.Suburb & " " & Me.Town & " " & Me.PostalCode & " " & DLookup("[CoCountry]", "CompanyName")
        Me.ZoneAway = Replace(get_dis_and_time2(DLookup("[Origin]", "CompanyName"), VarD), " Km", "")
    End If

    
    On Error GoTo 0
    Exit Sub

Update_Distance_Click_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure Update_Distance_Click, line " & Erl & "."

End Sub

Public Function get_dis_and_time2(origin_address As String, destination_address As String) As String

'key=************************
I have a Registration with Google and have my own key.
It is free to get.



    Dim surl                As String
    Dim oXH                 As Object
    Dim Bodytxt             As String
    Dim tim_e               As String
    Dim distanc_e           As String
    Dim InFlight            As String
    Dim varStatus           As String

    surl = "https://maps.googleapis.com/maps/api/distancematrix/xml?key=************************&origins=" & _
    Replace(Replace(Replace(origin_address, " ", "+"), ",", "+"), "++", "+") & _
    "&destinations=" & _
    Replace(Replace(Replace(destination_address, " ", "+"), ",", "+"), "++", "+") & _
    "&mode=driving&sensor=false&units=metric"
    ' Debug.Print surl
    ' units=imperial

    Set oXH = CreateObject("msxml2.xmlhttp")

        With oXH
            .Open "get", surl, False
            .send
            Bodytxt = .responseText
            ' Debug.Print (.responseText)
        End With
        
    varStatus = Right(Bodytxt, Len(Bodytxt) - InStr(1, Bodytxt, "<status>") - 7)
    varStatus = Right(varStatus, Len(varStatus) - InStr(1, varStatus, "<status>") - 7)
    varStatus = Left(varStatus, InStr(1, varStatus, "</status>") - 1)
    
    If UCase(varStatus) <> "OK" Then
        MsgBox " There is no Street or town called : " & destination_address
        get_dis_and_time2 = 0
    Else
        Bodytxt = Right(Bodytxt, Len(Bodytxt) - InStr(1, Bodytxt, "<text>") - 5)
        tim_e = Left(Bodytxt, InStr(1, Bodytxt, "</text>") - 1)
        Bodytxt = Right(Bodytxt, Len(Bodytxt) - InStr(1, Bodytxt, "<value>") - 6)
        distanc_e = Round(Left(Bodytxt, InStr(1, Bodytxt, "</value>") - 1) / 1000, 2) & " Km"
    get_dis_and_time2 = distanc_e
    End If

    Set oXH = Nothing

End Function

Private Sub Form_Current()
   
    Dim DadColor, MumColor
    DadColor = DLookup("[RingColour]", "tbl_Birds", "RingNo = " & "'" & Me.**** & "'" ) 
    MumColor = DLookup("[RingColour]", "tbl_Birds", "RingNo = " & "'" & Me.Hen & "'" ) 
    ****.ForeColor = DadColor
    Hen.ForeColor = MumColor


End Sub