Bekijk de onderstaande video om te zien hoe je onze site als een web app op je startscherm installeert.
Opmerking: Deze functie is mogelijk niet beschikbaar in sommige browsers.
Privacywetgeving
Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.
#If VBA7 And Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Public sJSON As String
#If VBA7 And Win64 Then
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
Private Sub CommandButton1_Click()
Dim rRange As Range
With Range("A1").CurrentRegion
Set rRange = .Offset(1, 1).Resize(.Rows.Count - 1, .Columns.Count - 1)
End With
With CreateObject("InternetExplorer.Application")
.Visible = True
.Navigate "http://www.nabssar.org/coi_calculator/index.html"
Do
DoEvents
Loop While .Busy And .ReadyState <> 4
Sleep 200
For Each oRow In rRange.Rows
oRow.Cells(4) = "Error"
sChild = oRow.Cells(1)
sJSON = "{" & vbCrLf
SireDamJSON rRange, sChild
sJSON = Mid(sJSON, 1, Len(sJSON) - 3)
With .Document
.getElementById("textarea").Value = sJSON
Sleep 200
Set mouseDownEvent = .createEvent("MouseEvent")
mouseDownEvent.initEvent "mousedown", True, False
.getElementById("populate").dispatchEvent mouseDownEvent
Sleep 200
.getElementById("calculate").dispatchEvent mouseDownEvent
Sleep 400
oRow.Cells(4) = Split(.getElementById("result").innertext, "=")(1)
Sleep 200
End With
Next
.Quit
End With
End Sub
Private Sub SireDamJSON(rRange As Range, ByVal sChild As String) 'am_2022
lChildRow = Application.Match(sChild, rRange.Columns(1), 0)
If Not IsError(lChildRow) Then
sChildSire = rRange.Rows(lChildRow).Cells(2)
sJSON = sJSON & Chr(34) & "s" & Chr(34) & ": {" & vbCrLf
SireDamJSON rRange, sChildSire
sChildDam = rRange.Rows(lChildRow).Cells(3)
sJSON = sJSON & Chr(34) & "d" & Chr(34) & ": {" & vbCrLf
SireDamJSON rRange, sChildDam
End If
sJSON = sJSON & Chr(34) & "name" & Chr(34) & ": " & Chr(34) & sChild & Chr(34) & vbCrLf
sJSON = sJSON & " }," & vbCrLf
End Sub
Alleen internet explorer werkt samen met VBA.waw, en ik die dacht dat internet explorer niet meer mocht, wegens niet meer ondersteunt ???
Mag altijd wat langzamer dus betrouwbaarder, is altijd sneller dan met de hand knippen en plakkenHet werkt wel netjes en razend snel.
1e opmerking, indien een voorouder "onbekend" is, dan geef je die niet mee of voeg je er een indexnummer aan toe, Onbekend1, Onbekend2, etc. Anders gaat die site er van uit dat het dezelfde gemeenschappelijke voorouder is en wordt er voor die "onbekende" een percentage inteelt toegekend.
2e opmerking, ik kan zo snel niet meelezen, maar ik dacht soms hetzelfde dier zowel als vader en als moeder staan, dat zou wel straf zijn, dus dat zal wel ergens onderweg fout opgegeven zijn.
is mogelijk, wacht op de updateMaar anders netjes ...
Zou het moeilijk zijn om uit je ("result").innertext vanaf een F>3% het aandeel van de strafste voorouder mee te geven, dus de 1e lijn onder die F (in het scherm hierboven 0.24% van Bold Ruler)
na een nachtje slapen ga ik dit wijzigen inVerdere vragen staan in bladen Dieren_Bib en Nesten
We gebruiken essentiële cookies om deze site te laten werken, en optionele cookies om de ervaring te verbeteren.