Questo è un buon listato eseguito da Punto&Virgola, su mia richiesta d'aiuto,
ottimo scrippter d'altra sede ( 21/12/2018 )
'Option Explicit
'CERCHIO MILLIONDAY CON DETTAGLIO COMPLETO by Punto&Virgola
Class clsCerchioCiclometrico
Dim aPos(55,02) ' memorizza le coordinate relative ai 99 Numeri
Dim aNumeri(55) ' 55 Numeri
Private CollCorde
Sub DisegnaCerchioCiclometricoX(aNumeri,aCorde)
Dim nRaggio ' raggio ddel cerchio
Dim cX,cY ' centro del cerchio x e y
Dim Base,Altezza ' dimensioni area disegno
Dim Angolo ' gestisce il ciclo per disegnare il cerchio
Dim pi ' pigreco
Dim x1,y1,x2,y2 ' coordinate generiche pr i segmenti
Dim cLung ' distanza per stampare i gradi
Dim k ' ciclo generico
Dim n
Dim z
Call PicClear()
Set CollCorde = GetNewCollection
cLung = 2
pi = 3.14
Base = 150
Altezza = 150
nRaggio = 60
' preimposto le dimensioni dell'area
Call PicSetDimensioni(Base,Altezza,Base,Altezza)
' calcolo il centro del cerchio
cX = Base / 2
cY = Altezza / 2
Call PicCerchio(cX,cY,nRaggio)
Angolo = 90
n = 56
For z = 1 To 55
n = n - 01
x1 = cX +((nRaggio) * Cos(- Angolo *(pi / 180)))
y1 = cY +((nRaggio) * Sin(- Angolo *(pi / 180)))
' memorizzo nell'array globale le coordinate appena calcolate
' cosi potranno essere riusate per disegnare le corde
aPos(n,1) = x1
aPos(n,2) = y1
If n Mod 5 = 00 Then
x2 = cX +((nRaggio + cLung * 03) * Cos(- Angolo *(pi / 180)))
y2 = cY +((nRaggio + cLung * 03) * Sin(- Angolo *(pi / 180)))
Call PicLinea(x1,y1,x2,y2)
x2 = cX +((nRaggio + cLung * 04) * Cos(-(Angolo + 02) *(pi / 180)))
y2 = cY +((nRaggio + cLung * 04) * Sin(-(Angolo + 02) *(pi / 180)))
Call PicStampaTestoRT(x2,y2,n,Angolo,,,,,10)
Else
' disegno il semiraggio
x2 = cX +((nRaggio + cLung) * Cos(- Angolo *(pi / 180)))
y2 = cY +((nRaggio + cLung) * Sin(- Angolo *(pi / 180)))
Call PicLinea(x1,y1,x2,y2)
x2 = cX +((nRaggio + cLung) * Cos(-(Angolo + 02) *(pi / 180)))
y2 = cY +((nRaggio + cLung) * Sin(-(Angolo + 02) *(pi / 180)))
Call PicStampaTestoRT(x2,y2,n,Angolo)
End If
Angolo = FuoriX(90 + Int(360 -((360/55)*(n - 1))),360)
Next
Call DisegnaFigura(aNumeri)
Call DisegnaDistanze(aCorde)
' mostro la figura in output
Call PicEsegui
End Sub
Private Sub DisegnaFigura(aNum)
Dim k
For k = 01 To UBound(aNum)
Call DisegnaCorda(aNum(k),aNum(FuoriX(k + 01,UBound(aNum))),vbRed,True,False)
Next
End Sub
Private Sub DisegnaDistanze(aCorde)
Dim k
For k = 01 To UBound(aCorde)
Call DisegnaCorda(aCorde(k,01),aCorde(k,02),vbBlue,True,True)
Next
End Sub
Private Sub DisegnaCorda(p1,p2,colore,bDisegnaDist,bLineaTratt)
Dim nX,nY,sDist
If AddCorda(p1,p2) Then
If bLineaTratt Then
Call PicLineaTratteggiata(aPos(p1,01),aPos(p1,02),aPos(p2,01),aPos(p2,02),colore,2)
Else
Call PicLinea(aPos(p1,01),aPos(p1,02),aPos(p2,01),aPos(p2,02),colore,2)
End If
Call PicPunto(aPos(p1,01),aPos(p1,02),06,colore)
Call PicPunto(aPos(p2,01),aPos(p2,02),06,colore)
If bDisegnaDist Then
If aPos(p1,01) > aPos(p2,01) Then
nX =(aPos(p1,01) - aPos(p2,01)) / 02 + aPos(p2,01)
Else
nX =(aPos(p2,01) - aPos(p1,01)) / 02 + aPos(p1,01)
End If
If aPos(p1,02) > aPos(p2,02)Then
nY =(aPos(p1,02) - aPos(p2,02)) / 02 + aPos(p2,02)
Else
nY =(aPos(p2,02) - aPos(p1,02)) / 02 + aPos(p1,02)
End If
Call PicCerchio(nX,nY,03,vbWhite,,True,vbWhite)
nX = nX - 1.5
nY = nY - 1.5
sDist = Format2(DiffCiclometrica55(p1,p2))
Call PicStampaTesto(nX,nY,sDist)
End If
End If
End Sub
Function DiffCiclometrica55(NumA,NumB)
Dim r
If NumA > NumB Then
r = NumA - NumB
Do While r >= 28
r = 55 - r
Loop
ElseIf NumB > NumA Then
r = NumB - NumA
Do While r >= 28
r = 55 - r
Loop
End If
DiffCiclometrica55 = r
End Function
Private Function AddCorda(n01,n02)
Dim sKey
If n01 <= n02 Then
sKey = "k" & Format2(n01) & Format2(n02)
Else
sKey = "k" & Format2(n02) & Format2(n01)
End If
On Error Resume Next
CollCorde.Add sKey,sKey
If Err = 00 Then
AddCorda = True
End If
End Function
End Class
Sub Main
Dim clsCerchio
Dim k
Dim aCorde
'Dim TipoEsempio
ReDim aNum(00)
Dim sfile
Dim est,fin,Ini,dr(5),db(5),d(5),a(5),T,V,posta(2)
posta(2) = 1
Ini = CInt(InputBox("QUANTE ESTRAZIONI VUOI VISUALLIZZARE"," N° ESTRAZIONI ",1))
sfile = GetDirectoryAppData & "ArchiviTx ........... inserire propria stringa........."
Call ApriBaseDatiFT(sfile,5,",",55)
Ini =(EstrazioniArchivioFT - Ini + 1)
fin = EstrazioniArchivioFT
For est = Ini To fin
T = Array(T,"Data Estrazione.","Estratti","Somma( F55 )","1-2","2-3","3-4","4-5","5-1","Dr1","Dr2","Dr3","Dr4","Dr5","Db1","Db2","Db3","Db4","Db5")
Call InitTabella(T)
Call GetEstrazioneCompletaFT(est,aNum)
'--------------------------------------
a(1) = aNum(1): a(2) = aNum(2) : a(3) = aNum(3): a(4) = aNum(4) : a(5) = aNum(5) ' <-- Estratti
'---------------------------------------
d(1) = Dista55(aNum(1),aNum(2)): d(2) = Dista55(aNum(2),aNum(3)): d(3) = Dista55(aNum(3),aNum(4)): d(4) = Dista55(aNum(4),aNum(5)): d(5) = Dista55(aNum(5),aNum(1))' <-- Distanza estratti
Call OrdinaMatrice(aNum,01)
'--------------------------------------
dr(1) = Dista55(aNum(1),aNum(2)): dr(2) = Dista55(aNum(2),aNum(3)): dr(3) = Dista55(aNum(3),aNum(4)): dr(4) = Dista55(aNum(4),aNum(5)): dr(5) = Dista55(aNum(5),aNum(1))' <-- Distanza rosse
'--------------------------------------
db(1) = Dista55(aNum(1),aNum(3)): db(2) = Dista55(aNum(1),aNum(4)): db(3) = Dista55(aNum(2),aNum(5)): db(4) = Dista55(aNum(2),aNum(4)) : db(5) = Dista55(aNum(3),aNum(5))' <-- Distanza blu
'-------------------------------------
se = SommaEstrattiFT(est) : sef = FuoriX(se,55) '<-- Somma estratti e fuori55
'--------------------------------------
Scrivi : Scrivi
' le corde sono le distanze interne e sono
' considerate tutte le coppie di vertic
V = Array(V,GetInfoEstrazioneFT(est),StringaNumeri(a,,1),se & " ( " & sef & " )",d(1),d(2),d(3),d(4),d(5),dr(1),dr(2),dr(3),dr(4),dr(5),db(1),db(2),db(3),db(4),db(5))
Call AddRigaTabella(V)
Call SetColoreCella(9,,2)
Call SetColoreCella(10,,2)
Call SetColoreCella(11,,2)
Call SetColoreCella(12,,2)
Call SetColoreCella(13,,2)
'----------------------------
Call SetColoreCella(14,,1)
Call SetColoreCella(15,,1)
Call SetColoreCella(16,,1)
Call SetColoreCella(17,,1)
Call SetColoreCella(18,,1)
ImpostaGiocataFT 1,dr,posta,5
Call CreaTabella
Scrivi "Estratti estrazione " & a(1) & " " & a(2) & " " & a(3) & " " & a(4) & " " & a(5) & String(6," "),0,0
Scrivi "Distanze estrazione " & d(1) & " " & d(2) & " " & d(3) & " " & d(4) & " " & d(5) & String(6," "),0,0
Scrivi "Somma estratti e [F55] " & se & " [" & sef & "]"
Scrivi
Scrivi "Estratti ordinati " & aNum(1) & " " & aNum(2) & " " & aNum(3) & " " & aNum(4) & " " & aNum(5) & String(7," "),0,0
Scrivi "Distanze corde rosse " & dr(1) & " " & dr(2) & " " & dr(3) & " " & dr(4) & " " & dr(5) & String(6," "),0,0,,2
Scrivi "Distanze corde Blu " & db(1) & " " & db(2) & " " & db(3) & " " & db(4) & " " & db(5),,,,1
Scrivi : Scrivi
aCorde = SviluppoIntegrale(aNum,02)
Set clsCerchio = New clsCerchioCiclometrico
Call clsCerchio.DisegnaCerchioCiclometricoX(aNum,aCorde)
GiocaFT est
Next
End Sub
Function Dista55(numa,numb)
Dim r
If numa > numb Then
r = numa - numb
Do While r >= 28
r = 55 - r
Loop
ElseIf numb > numa Then
r = numb - numa
Do While r >= 28
r = 55 - r
Loop
End If
Dista55 = r
End Function