Gravity.Net Screen Saver v2.0.1.*
Table des procédures 1 - AssemblyInfo.vb 2 - frmGravityNet.vb 2.1 - Private Function bTraiterModifBooleen 2.2 - Private Function bTraiterModifTexte 2.3 - Private Sub Animer 2.4 - Private Sub ArreterAnimation 2.5 - Private Sub BoucleAnimation 2.6 - Private Sub FrmGravityNet_Click 2.7 - Private Sub frmGravityNet_Load 2.8 - Private Sub FrmVBNetScreenSaver_Closing 2.9 - Private Sub InitialiserEcranDeVeille 2.10 - Private Sub InitialiserListePrm 2.11 - Private Sub InitialiserModeConfiguration 2.12 - Private Sub InitialiserTailleEcran 2.13 - Private Sub InitialiserTimer 2.14 - Private Sub ListViewPrm_AfterLabelEdit 2.15 - Private Sub ListViewPrm_ItemCheck 2.16 - Private Sub ListViewPrm_SelectedIndexChanged 2.17 - Private Sub MAJAnimation 2.18 - Private Sub MAJListePrm 2.19 - Private Sub Quitter 2.20 - Private Sub SauverConfig 2.21 - Private Sub TimerAnimation_Tick 2.22 - Protected Overrides Sub OnKeyDown 2.23 - Protected Overrides Sub OnMouseDown 2.24 - Protected Overrides Sub OnMouseMove 2.25 - Protected Overrides Sub OnPaint 2.26 - Protected Overrides Sub OnPaintBackground 2.27 - Protected Overrides Sub OnSizeChanged 2.28 - Public Sub ControlerParametres 3 - Gravity.vb 3.1 - Private Function iRandomiser% 3.2 - Private Function rLireAngle 3.3 - Private Function rRandomiser 3.4 - Private Sub GererChoc 3.5 - Private Sub ProjeterCoord 3.6 - Public Sub ControlerParametres 3.7 - Public Sub Dessiner 3.8 - Public Sub DessinerFond 3.9 - Public Sub InitialiserImageFond 3.10 - Public Sub InitialiserTailleEcran 3.11 - Public Sub New 3.12 - Public Sub SimulerGravite 3.13 - Public Sub TirageAleatoire 4 - clsSprite.vb 4.1 - Private Sub CalculerTailleImg 4.2 - Public Sub AnimerSpin 4.3 - Public Sub Dessiner 4.4 - Public Sub DiametreApparent 4.5 - Public Sub FixerPosition 4.6 - Public Sub InitialiserImage 4.7 - Public Sub New 5 - modConst.vb 6 - modDepart.vb 6.1 - Private Sub Depart 6.2 - Public Sub Main 7 - modUtil.vb 7.1 - '<System.Diagnostics.DebuggerStepThrough()> Public Function iConv% 7.2 - Public Function bAppliDejaOuverte 7.3 - Public Function bDossierExiste 7.4 - Public Sub AfficherMsgErreur2 7.5 - Public Sub CopierPressePapier AssemblyInfo.vb Imports System.Reflection Imports System.Runtime.InteropServices <Assembly: AssemblyTitle("Gravity.Net Screen Saver")> <Assembly: AssemblyDescription("Gravity.Net : l'écran de veille chaotique en VB.Net")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("Gravity2.scr")> <Assembly: AssemblyCopyright("Copyright © ORS Production 2012")> <Assembly: AssemblyTrademark("")> <Assembly: CLSCompliant(True)> 'The following GUID is for the ID of the typelib if this project is exposed to COM '<Assembly: Guid("01351CCF-7251-4714-9EEB-843EC2AA224C")> <Assembly: AssemblyVersion("2.0.1.*")> frmGravityNet.vb ' Gravity.Net : l'écran de veille chaotique en VB.Net ' http://patrice.dargenton.free.fr/gravity/index.html ' http://patrice.dargenton.free.fr/gravity/GravitySrc.html ' http://www.vbfrance.com/code.aspx?ID=4486 ' Version 2.10 du 11/11/2012 : Version VB 2008 ' Version 2.00 du 03/09/2002 ' Par Patrice Dargenton : patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' Documentation : cf. Gravity.html ' Note : Le fichier Gravity2.exe doit être renommé en .scr pour être ' installé normalement (il est apparemment impossible de créer un .scr ' directement) ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' d pour Date ' u pour Unsigned (non signé : entier positif) ' a pour Array (tableau) : () ' o pour Object : objet instancié localement ' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ Imports System.IO ' Pour Path, FileInfo Public Class frmGravityNet ' : Inherits Form #Region "Constantes" Private Const sTitreFrmConfig$ = _ "Configuration de Gravity.Net Screen Saver" ' Indexe des paramètres dans la zone de liste listViewPrm Private Const iDegreRacine% = 0 Private Const iDegreRacine_bRnd% = 1 Private Const iDegreRacineRndMax% = 2 Private Const iDegreRacine2% = 3 Private Const iDegreRacine2_bRnd% = 4 Private Const iDegreRacine2RndMax% = 5 Private Const ibMasseSym% = 6 Private Const ibMasseSym_bRnd% = 7 Private Const ib3D% = 8 Private Const ib3D_bRnd% = 9 Private Const ib3D_bPlanetesAxeV% = 10 '25 Private Const ib3D_bPlanetesAxeV_bRnd% = 11 '26 Private Const ib3D_iNbPlanetesMaxAxeV% = 12 '27 Private Const ibChocs% = 13 '10 Private Const ibChocs_bRnd% = 14 '11 Private Const iForceGravitation% = 15 '12 Private Const iTxtBanniere% = 16 '13 Private Const iFiltreFichiersImgSprite% = 17 '14 Private Const iFiltreFichiersImgFond% = 18 '15 Private Const ibMAJToutLEcran% = 19 '16 Private Const ibMAJGroupeSprites% = 20 '17 Private Const ibNePasInitFond% = 21 '18 Private Const ibNePasBufferiserGr% = 22 '19 Private Const ibFondUni% = 23 '20 Private Const ibFondDegrade% = 24 '21 Private Const iTempsMaxScenarioSec% = 25 '22 Private Const iDelaiMiliSec% = 26 '23 Private Const ibPauseAnimation% = 27 '24 #End Region #Region "Déclarations" Private m_sTitreAppli$ Private m_bInit As Boolean Private m_iVitesseBanniere% = 5 ' Vitesse de la bannière Private m_iPosBanniereX% ' Position horizontale de la bannière ' Pour déterminer si la souris a bougée Private m_ptPosSouris As New Point(0, 0) Private m_rectEcran As Rectangle Private m_bFondInitialise As Boolean Private m_grFrm As Graphics ' Pour gérer le graphisme dans la Form Private m_bMajListPrm As Boolean ' Booléen pour indiquer si tout est configuré Private m_bDejaConfigure As Boolean = False Private m_bBoucleAnimationEnCours As Boolean = False Private m_bQuitterBoucleAnimation As Boolean = False Private m_rMemDateDepartAnimation As Double Private m_gravity As New SimulteurGravite(Me) ' Structures pour les paramètres de l'écran de veille Structure TParametresEcran Dim sTxtBanniere$ Dim bAffichageBanniere As Boolean Dim bNePasBufferiserGr As Boolean Dim bMAJGroupeSprites As Boolean Dim bMAJToutLEcran As Boolean Dim iTempsMaxScenarioSec% Dim iDelaiMiliSec% ' Cela permet de dépasser les 100 fps si le tracé est simple, ' car le timer est limité à 1 ms au min., ce qui correspond à 100 fps ! Dim bBoucleAnimation As Boolean End Structure Public m_prmE As TParametresEcran #End Region #Region "Initialisations" Private Sub frmGravityNet_Load(ByVal sender As Object, ByVal e As EventArgs) _ Handles Me.Load Me.Text = sTitreFrmConfig Dim sVersion$ = " - V" & sVersionAppli & " (" & sDateVersionAppli & ")" Dim sDebug$ = " - Debug" Dim sTxt$ = Me.Text & sVersion If bDebug Then sTxt &= sDebug Me.Text = sTxt m_sTitreAppli = sTxt End Sub Private Sub InitialiserEcranDeVeille() m_prmE.sTxtBanniere = My.Settings.TxtBanniere m_prmE.bAffichageBanniere = My.Settings.bAffichageBanniere m_prmE.bMAJToutLEcran = My.Settings.bMAJToutLEcran m_prmE.bNePasBufferiserGr = My.Settings.bNePasBufferiserGr m_prmE.iTempsMaxScenarioSec = My.Settings.TempsMaxScenarioSec m_prmE.iDelaiMiliSec = My.Settings.DelaiMiliSec If glb_bModeConfiguration Then Me.Text = m_sTitreAppli Me.ListViewPrm.Visible = True ' Positionnement de la fenêtre par le code : mode manuel Me.StartPosition = FormStartPosition.Manual Me.Location = My.Settings.frmGravityNetPos Me.Size = My.Settings.frmGravityNetTaille ' Le ListView n'est pas sizable (sinon ancrer) 'Me.ListViewPrm.Location = My.Settings.frmConfigPos 'Me.ListViewPrm.Size = My.Settings.frmConfigTaille InitialiserModeConfiguration() Else If Not bDebug Then Cursor.Hide() Me.TopMost = True End If Me.FormBorderStyle = FormBorderStyle.None Me.WindowState = FormWindowState.Maximized InitialiserTimer() End If End Sub Private Sub InitialiserModeConfiguration() InitialiserListePrm() Application.DoEvents() m_gravity.InitialiserTailleEcran(Me.ClientSize) m_bDejaConfigure = True MAJAnimation(bTirageAleatoire:=False, bInitialiserFond:=True, _ bControlerPrm:=True) End Sub Private Sub InitialiserTimer() m_prmE.bBoucleAnimation = False If m_bBoucleAnimationEnCours And m_prmE.iDelaiMiliSec > 0 And _ (TimerAnimation.Interval <> m_prmE.iDelaiMiliSec Or _ m_prmE.iDelaiMiliSec = 1) Then SauverConfig() MsgBox("Ce réglage ne prendra effet qu'au prochain lancement", _ MsgBoxStyle.OkOnly Or MsgBoxStyle.Information, _ m_sTitreApplication) End If If m_prmE.iDelaiMiliSec > 0 Then TimerAnimation.Interval = m_prmE.iDelaiMiliSec Else TimerAnimation.Interval = 1 m_prmE.bBoucleAnimation = True End If End Sub Private Sub InitialiserListePrm() Me.SuspendLayout() ' Set the view to show details. Me.ListViewPrm.View = View.Details ' Allow the user to edit item text. Me.ListViewPrm.LabelEdit = True ' Display check boxes. Me.ListViewPrm.CheckBoxes = True ' Display grid lines. Me.ListViewPrm.GridLines = True ' On peut le faire avec l'éditeur en mode design ' mais ça bug pas mal quand même Me.ColumnHeader1 = New Windows.Forms.ColumnHeader() Me.ColumnHeader2 = New Windows.Forms.ColumnHeader() Me.ColumnHeader3 = New Windows.Forms.ColumnHeader() Me.ColumnHeader2.Text = "Valeur" Me.ColumnHeader2.Width = 130 Me.ColumnHeader1.Text = "Paramètre" Me.ColumnHeader1.Width = 150 Me.ColumnHeader3.Text = "Explication" Me.ColumnHeader3.Width = 0 Me.ListViewPrm.Columns.AddRange( _ New System.Windows.Forms.ColumnHeader() { _ Me.ColumnHeader2, Me.ColumnHeader1, Me.ColumnHeader3}) ' Create three items and three sets of subitems for each item. Dim aString$(2) Const iColNomPrm% = 0 Const iColExplic% = 2 Dim sValDegreRacine$ = m_gravity.m_prm.iDegreRacine.ToString ' 1 Dim item0 As New ListViewItem(CStr(sValDegreRacine)) aString(iColNomPrm) = sDegreRacine aString(iColExplic) = "Degré du système 1 (système principal)" item0.SubItems.AddRange(aString) Dim bBool As Boolean = m_gravity.m_prm.bDegreRacine_bRnd ' Idée : MAJ de la valeur du booléen dans le label Dim sChaineVide$ = "" Dim item1 As New ListViewItem(sChaineVide) item1.Checked = bBool aString(iColNomPrm) = sDegreRacine_bRnd aString(iColExplic) = "Cochez pour choisir au hasard le degré du système 1" item1.SubItems.AddRange(aString) Dim iDegreRacineRndMax% = m_gravity.m_prm.iDegreRacineRndMax ' 4 Dim item2 As New ListViewItem(CStr(iDegreRacineRndMax)) aString(iColNomPrm) = sDegreRacineRndMax aString(iColExplic) = "Degré max. du système 1 si son tirage est aléatoire" item2.SubItems.AddRange(aString) Dim iDegreRacine2% = m_gravity.m_prm.iDegreRacine2 ' 1 Dim item3 As New ListViewItem(CStr(iDegreRacine2)) aString(iColNomPrm) = sDegreRacine2 aString(iColExplic) = _ "Degré du système 2 (système secondaire imbriqué dans le système 1)" item3.SubItems.AddRange(aString) bBool = m_gravity.m_prm.bDegreRacine2_bRnd Dim item4 As New ListViewItem(sChaineVide) item4.Checked = bBool aString(iColNomPrm) = sDegreRacine2_bRnd aString(iColExplic) = "Cochez pour choisir au hasard le degré du système 2" item4.SubItems.AddRange(aString) Dim iDegreRacine2RndMax% = m_gravity.m_prm.iDegreRacine2RndMax ' 4 Dim item5 As New ListViewItem(CStr(iDegreRacine2RndMax)) aString(iColNomPrm) = sDegreRacine2RndMax aString(iColExplic) = "Degré max. du système 2 si son tirage est aléatoire" item5.SubItems.AddRange(aString) bBool = m_gravity.m_prm.bMasseSym Dim item6 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbMasseSym aString(iColExplic) = "Cochez pour que les planètes soient symétriques" item6.SubItems.AddRange(aString) item6.Checked = bBool bBool = m_gravity.m_prm.bMasseSym_bRnd Dim item7 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbMasseSym_bRnd aString(iColExplic) = _ "Cochez pour choisir au hasard si les planètes doivent être symétriques" item7.SubItems.AddRange(aString) item7.Checked = bBool bBool = m_gravity.m_prm.b3D Dim item8 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sb3D aString(iColExplic) = "Cochez pour afficher l'animation en 3 dimensions" item8.SubItems.AddRange(aString) item8.Checked = bBool bBool = m_gravity.m_prm.b3D_bRnd Dim item9 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sb3D_bRnd aString(iColExplic) = "Cochez pour choisir au hasard si l'animation doit être en 3D" item9.SubItems.AddRange(aString) item9.Checked = bBool bBool = m_gravity.m_prm.b3D_bPlanetesAxeV Dim item25 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sb3D_bPlanetesAxeV aString(iColExplic) = "Cocher pour ajouter des planètes dans l'axe vertical (3D)" item25.SubItems.AddRange(aString) item25.Checked = bBool bBool = m_gravity.m_prm.b3D_bPlanetesAxeV_bRnd Dim item26 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sb3D_bPlanetesAxeV_bRnd aString(iColExplic) = _ "Cochez pour choisir au hasard pour ajouter des planètes dans l'axe vertical (3D)" item26.SubItems.AddRange(aString) item26.Checked = bBool Dim iNbPlanetesAxeV% = m_gravity.m_prm.b3D_iNbPlanetesMaxAxeV Dim item27 As New ListViewItem(CStr(iNbPlanetesAxeV)) aString(iColNomPrm) = sb3D_iNbPlanetesMaxAxeV aString(iColExplic) = "Nombre max. de planètes à ajouter dans l'axe vertical (3D)" item27.SubItems.AddRange(aString) bBool = m_gravity.m_prm.bChocs Dim item10 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbChocs aString(iColExplic) = "Cochez pour indiquer que les planètes doivent se percuter" item10.SubItems.AddRange(aString) item10.Checked = bBool bBool = m_gravity.m_prm.bChocs_bRnd Dim item11 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbChocs_bRnd aString(iColExplic) = "Cochez pour choisir au hasard si les planètes doivent se percuter" item11.SubItems.AddRange(aString) item11.Checked = bBool Dim iForceGravitation% = CInt(m_gravity.m_prm.rForceGravitation) ' 100 Dim item12 As New ListViewItem(CStr(iForceGravitation)) aString(iColNomPrm) = sForceGravitation aString(iColExplic) = "Paramètre proportionnel à la force de gravitation" item12.SubItems.AddRange(aString) Dim sValTxtBanniere$ = m_prmE.sTxtBanniere Dim item13 As New ListViewItem(sValTxtBanniere) aString(iColNomPrm) = sTxtBanniere aString(iColExplic) = "Texte de la bannière à afficher (si la case est cochée)" item13.SubItems.AddRange(aString) ' La case à cocher et le label sont utilisés tous les 2 dans ce cas bBool = m_prmE.bAffichageBanniere item13.Checked = bBool Dim sValFiltreFichiersImgSprite$ = m_gravity.m_prm.sFiltreFichiersImgSprite Dim item14 As New ListViewItem(sValFiltreFichiersImgSprite) aString(iColNomPrm) = sFiltreFichiersImgSprite aString(iColExplic) = "Filtre pour choisir les fichiers images des planètes (si coché)" item14.SubItems.AddRange(aString) bBool = m_gravity.m_prm.bCercle item14.Checked = Not bBool Dim sValFiltreFichiersImgFond$ = m_gravity.m_prm.sFiltreFichiersImgFond Dim item15 As New ListViewItem(sValFiltreFichiersImgFond) aString(iColNomPrm) = sFiltreFichiersImgFond aString(iColExplic) = "Filtre pour choisir les fichiers images du fond (si coché)" item15.SubItems.AddRange(aString) bBool = m_gravity.m_prm.bImageFond item15.Checked = bBool bBool = m_prmE.bMAJToutLEcran Dim item16 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbMAJToutLEcran aString(iColExplic) = _ "Cochez pour mettre à jour tout l'écran à chaque image (frame) de l'animation" item16.SubItems.AddRange(aString) item16.Checked = bBool bBool = m_gravity.m_prm.bMAJGroupeSprites Dim item17 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbMAJGroupeSprites aString(iColExplic) = _ "Cochez pour mettre à jour la zone autour des sprites afin de faire une jolie transition" item17.SubItems.AddRange(aString) item17.Checked = bBool bBool = m_gravity.m_prm.bNePasInitFond Dim item18 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbNePasInitFond aString(iColExplic) = _ "Cochez pour ne pas initialiser l'image du fond afin de faire une jolie transistion" item18.SubItems.AddRange(aString) item18.Checked = bBool bBool = m_prmE.bNePasBufferiserGr Dim item19 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbNePasBufferiserGr aString(iColExplic) = _ "Cochez pour ne pas buffériser le graphisme afin de conserver la trace des sprites" item19.SubItems.AddRange(aString) item19.Checked = bBool bBool = m_gravity.m_prm.bFondUni Dim item20 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbFondUni aString(iColExplic) = _ "Cochez pour que le fond soit uni (si les autres options du fond sont désactivées)" item20.SubItems.AddRange(aString) item20.Checked = bBool bBool = m_gravity.m_prm.bFondDegrade Dim item21 As New ListViewItem(sChaineVide) aString(iColNomPrm) = sbFondDegrade aString(iColExplic) = _ "Cochez pour que le fond soit un dégradé de couleur (s'il n'y a pas d'image de fond)" item21.SubItems.AddRange(aString) item21.Checked = bBool Dim iTempsMaxScenarioSec% = m_prmE.iTempsMaxScenarioSec Dim item22 As New ListViewItem(CStr(iTempsMaxScenarioSec)) aString(iColNomPrm) = sTempsMaxScenarioSec aString(iColExplic) = "Temps max. de l'animation en secondes avant un autre tirage au hasard" item22.SubItems.AddRange(aString) Dim iDelaiMiliSec% = m_prmE.iDelaiMiliSec ' 0 Dim item23 As New ListViewItem(CStr(iDelaiMiliSec)) aString(iColNomPrm) = sDelaiMiliSec aString(iColExplic) = _ "Délai en millisecondes entre chaque image de l'animation (0 pour une boucle continue)" item23.SubItems.AddRange(aString) Dim item24 As New ListViewItem(sChaineVide) aString(iColNomPrm) = "Pause" aString(iColExplic) = "Cochez pour faire une pause de l'animation" item24.SubItems.AddRange(aString) item24.Checked = False ' Attention : ne pas changer l'ordre des items ' car on utilise les index correspondants Me.ListViewPrm.Items.AddRange(New ListViewItem() { _ item0, item1, item2, item3, item4, item5, item6, _ item7, item8, item9, item25, item26, item27, _ item10, item11, item12, item13, _ item14, item15, item16, item17, item18, item19, item20, _ item21, item22, item23, item24}) Me.ResumeLayout(False) End Sub #End Region #Region "Gestion configuration" Private Sub ListViewPrm_SelectedIndexChanged(ByVal sender As Object, _ ByVal e As System.EventArgs) Handles ListViewPrm.SelectedIndexChanged Dim iNbItemsSelect% = Me.ListViewPrm.SelectedItems.Count If iNbItemsSelect = 0 Then Exit Sub Dim itemLignePrm As ListViewItem.ListViewSubItemCollection itemLignePrm = Me.ListViewPrm.SelectedItems.Item(0).SubItems ' Affichage de la description du paramètre dans la barre de titre Me.Text = itemLignePrm(1).Text & " : " & itemLignePrm(2).Text glb_rDateMessageTitre = DateAndTime.Timer End Sub Private Sub ListViewPrm_ItemCheck(ByVal sender As Object, _ ByVal e As Windows.Forms.ItemCheckEventArgs) _ Handles ListViewPrm.ItemCheck If Not m_bDejaConfigure Then Exit Sub Dim bTirageAleatoire, bInitialiserFond As Boolean m_bMajListPrm = True If Not bTraiterModifBooleen(e.Index, e.NewValue, _ bTirageAleatoire, bInitialiserFond) Then Exit Sub MAJAnimation(bTirageAleatoire, bInitialiserFond, _ bControlerPrm:=True) End Sub Private Sub ListViewPrm_AfterLabelEdit(ByVal sender As Object, _ ByVal e As Windows.Forms.LabelEditEventArgs) _ Handles ListViewPrm.AfterLabelEdit If Not m_bDejaConfigure Then Exit Sub Dim bTirageAleatoire, bInitialiserFond As Boolean Dim sValeur$ ' Cela ce produit lorsque le contenu du label n'a pas changé ! If e.Label Is Nothing Then e.CancelEdit = True : Exit Sub sValeur = e.Label If Not bTraiterModifTexte(e.Item, sValeur, _ bTirageAleatoire, bInitialiserFond) Then _ e.CancelEdit = True : Exit Sub ' Correction éventuelle des arrondis : ' ne marche pas dans cet evenement 'Me.ListViewPrm.Items.Item(e.Item).Text = sValeur MAJAnimation(bTirageAleatoire, bInitialiserFond, _ bControlerPrm:=True) m_bMajListPrm = True End Sub Private Function bTraiterModifBooleen(ByVal iIndexPrm%, _ ByVal CSEtat As CheckState, _ ByRef bTirageAleatoire As Boolean, _ ByRef bInitialiserFond As Boolean) As Boolean Dim bVal As Boolean = CBool(CSEtat) bTraiterModifBooleen = True Select Case iIndexPrm Case iDegreRacine_bRnd m_gravity.m_prm.bDegreRacine_bRnd = bVal : bTirageAleatoire = True Case iDegreRacine2_bRnd m_gravity.m_prm.bDegreRacine2_bRnd = bVal : bTirageAleatoire = True Case ibMasseSym m_gravity.m_prm.bMasseSym = bVal : bTirageAleatoire = True If Not bVal Then m_gravity.m_prm.bMasseSym_bRnd = False Case ibMasseSym_bRnd m_gravity.m_prm.bMasseSym_bRnd = bVal : bTirageAleatoire = True If bVal Then m_gravity.m_prm.bMasseSym = True Case ib3D m_gravity.m_prm.b3D = bVal : bTirageAleatoire = True If Not bVal Then m_gravity.m_prm.b3D_bRnd = False Case ib3D_bRnd : m_gravity.m_prm.b3D_bRnd = bVal : bTirageAleatoire = True Case ib3D_bPlanetesAxeV m_gravity.m_prm.b3D_bPlanetesAxeV = bVal : bTirageAleatoire = True If Not bVal Then m_gravity.m_prm.b3D_bPlanetesAxeV_bRnd = False Case ib3D_bPlanetesAxeV_bRnd m_gravity.m_prm.b3D_bPlanetesAxeV_bRnd = bVal : bTirageAleatoire = True If bVal Then m_gravity.m_prm.b3D_bPlanetesAxeV = True Case ibChocs m_gravity.m_prm.bChocs = bVal If Not bVal Then m_gravity.m_prm.bChocs_bRnd = False Case ibChocs_bRnd m_gravity.m_prm.bChocs_bRnd = bVal : bTirageAleatoire = True If bVal Then m_gravity.m_prm.bChocs = True Case iFiltreFichiersImgSprite m_gravity.m_prm.bCercle = (CSEtat = CheckState.Unchecked) ' Pour initialiser les images des sprites If Not m_gravity.m_prm.bCercle And m_gravity.m_bMembCercle Then _ bTirageAleatoire = True Case iTxtBanniere : m_prmE.bAffichageBanniere = bVal Case iFiltreFichiersImgFond m_gravity.m_prm.bImageFond = bVal : bInitialiserFond = True If bVal Then m_gravity.m_prm.bFondUni = False : m_gravity.m_prm.bFondDegrade = False Case ibMAJToutLEcran : m_prmE.bMAJToutLEcran = bVal Case ibMAJGroupeSprites : m_gravity.m_prm.bMAJGroupeSprites = bVal Case ibNePasInitFond m_gravity.m_prm.bNePasInitFond = bVal : bInitialiserFond = True Case ibNePasBufferiserGr m_prmE.bNePasBufferiserGr = bVal : bInitialiserFond = True Case ibFondUni m_gravity.m_prm.bFondUni = bVal If bVal Then m_gravity.m_prm.bImageFond = False : m_gravity.m_prm.bFondDegrade = False Case ibFondDegrade m_gravity.m_prm.bFondDegrade = bVal If bVal Then m_gravity.m_prm.bImageFond = False : m_gravity.m_prm.bFondUni = False Case ibPauseAnimation : m_gravity.m_prm.bPauseAnimation = bVal Case Else bTraiterModifBooleen = False End Select If bTirageAleatoire Then bInitialiserFond = True End Function Private Function bTraiterModifTexte(ByVal iIndexPrm%, _ ByRef sValeur$, ByRef bTirageAleatoire As Boolean, _ ByRef bInitialiserFond As Boolean) As Boolean bTraiterModifTexte = True Dim bContinuer As Boolean Select Case iIndexPrm ' Saisie d'un texte Case iTxtBanniere If sValeur = "" Then m_prmE.bAffichageBanniere = False Else m_prmE.sTxtBanniere = sValeur End If Case iFiltreFichiersImgFond m_gravity.m_prm.sFiltreFichiersImgFond = sValeur : bInitialiserFond = True Case iFiltreFichiersImgSprite m_gravity.m_prm.sFiltreFichiersImgSprite = sValeur : bTirageAleatoire = True Case Else bContinuer = True End Select If bTirageAleatoire Then bInitialiserFond = True If Not bContinuer Then Exit Function ' Saisie d'un entier Dim iVal% Try 'iVal = Integer.Parse(sValeur, Globalization.NumberStyles.Integer) iVal = CInt(sValeur) ' Identique dans ce cas Catch bTraiterModifTexte = False Exit Function End Try sValeur = CStr(iVal) ' Application de l'éventuel arrondi au label Select Case iIndexPrm Case iDegreRacine m_gravity.m_prm.iDegreRacine = CInt(sValeur) : bTirageAleatoire = True Case iDegreRacineRndMax m_gravity.m_prm.iDegreRacineRndMax = CInt(sValeur) : bTirageAleatoire = True Case iDegreRacine2 m_gravity.m_prm.iDegreRacine2 = CInt(sValeur) : bTirageAleatoire = True Case iDegreRacine2RndMax m_gravity.m_prm.iDegreRacine2RndMax = CInt(sValeur) : bTirageAleatoire = True Case iForceGravitation : m_gravity.m_prm.rForceGravitation = CDec(sValeur) Case iDelaiMiliSec : m_prmE.iDelaiMiliSec = CInt(sValeur) Case iTempsMaxScenarioSec : m_prmE.iTempsMaxScenarioSec = CInt(sValeur) Case ib3D_iNbPlanetesMaxAxeV m_gravity.m_prm.b3D_iNbPlanetesMaxAxeV = CInt(sValeur) : bTirageAleatoire = True Case Else bTraiterModifTexte = False End Select If bTirageAleatoire Then bInitialiserFond = True End Function Public Sub ControlerParametres() m_gravity.ControlerParametres() If m_prmE.iDelaiMiliSec < 0 Then m_prmE.iDelaiMiliSec = 0 If m_prmE.iDelaiMiliSec > 1000 Then m_prmE.iDelaiMiliSec = 1000 m_prmE.bBoucleAnimation = False If m_prmE.iDelaiMiliSec = 0 Then m_prmE.bBoucleAnimation = True If m_prmE.iTempsMaxScenarioSec < 1 Then m_prmE.iTempsMaxScenarioSec = 1 If m_prmE.iTempsMaxScenarioSec > 1000 Then m_prmE.iTempsMaxScenarioSec = 1000 End Sub #End Region #Region "Traitements" Private Sub MAJAnimation(ByVal bTirageAleatoire As Boolean, _ ByVal bInitialiserFond As Boolean, ByVal bControlerPrm As Boolean) If bControlerPrm Then ControlerParametres() InitialiserTimer() End If If bInitialiserFond Then Dim bVal As Boolean = Not m_prmE.bNePasBufferiserGr SetStyle(ControlStyles.DoubleBuffer, bVal) SetStyle(ControlStyles.AllPaintingInWmPaint, bVal) SetStyle(ControlStyles.UserPaint, bVal) m_gravity.InitialiserImageFond(Me.ClientSize) If Not m_gravity.m_prm.bNePasInitFond Then If m_prmE.bNePasBufferiserGr Then m_bFondInitialise = False Else Me.Invalidate() End If End If End If If bTirageAleatoire Then m_gravity.TirageAleatoire() If bTirageAleatoire And SimulteurGravite.bDebugPosEtVitInitiales Then _ Me.ListViewPrm.Items.Item(ibPauseAnimation).Checked = True m_rMemDateDepartAnimation = DateAndTime.Timer End Sub Private Sub MAJListePrm() ' Correction éventuelle des arrondis et autres incohérences With Me.ListViewPrm.Items .Item(iDegreRacine).Text = CStr(m_gravity.m_prm.iDegreRacine) .Item(iDegreRacine).Checked = False .Item(iDegreRacine_bRnd).Text = "" .Item(iDegreRacine_bRnd).Checked = m_gravity.m_prm.bDegreRacine_bRnd .Item(iDegreRacineRndMax).Text = CStr(m_gravity.m_prm.iDegreRacineRndMax) .Item(iDegreRacineRndMax).Checked = False .Item(iDegreRacine2).Text = CStr(m_gravity.m_prm.iDegreRacine2) .Item(iDegreRacine2).Checked = False .Item(iDegreRacine2_bRnd).Text = "" .Item(iDegreRacine2_bRnd).Checked = m_gravity.m_prm.bDegreRacine2_bRnd .Item(iDegreRacine2RndMax).Text = CStr(m_gravity.m_prm.iDegreRacine2RndMax) .Item(iDegreRacine2RndMax).Checked = False .Item(ibMasseSym).Text = "" .Item(ibMasseSym).Checked = m_gravity.m_prm.bMasseSym .Item(ibMasseSym_bRnd).Text = "" .Item(ibMasseSym_bRnd).Checked = m_gravity.m_prm.bMasseSym_bRnd .Item(ib3D).Text = "" .Item(ib3D).Checked = m_gravity.m_prm.b3D .Item(ib3D_bRnd).Text = "" .Item(ib3D_bRnd).Checked = m_gravity.m_prm.b3D_bRnd .Item(ib3D_bPlanetesAxeV).Text = "" .Item(ib3D_bPlanetesAxeV).Checked = m_gravity.m_prm.b3D_bPlanetesAxeV .Item(ib3D_bPlanetesAxeV_bRnd).Text = "" .Item(ib3D_bPlanetesAxeV_bRnd).Checked = m_gravity.m_prm.b3D_bPlanetesAxeV_bRnd .Item(ib3D_iNbPlanetesMaxAxeV).Text = CStr(m_gravity.m_prm.b3D_iNbPlanetesMaxAxeV) .Item(ib3D_iNbPlanetesMaxAxeV).Checked = False .Item(ibChocs).Text = "" .Item(ibChocs).Checked = m_gravity.m_prm.bChocs .Item(ibChocs_bRnd).Text = "" .Item(ibChocs_bRnd).Checked = m_gravity.m_prm.bChocs_bRnd .Item(iForceGravitation).Text = CStr(m_gravity.m_prm.rForceGravitation) .Item(iForceGravitation).Checked = False .Item(iDelaiMiliSec).Text = CStr(m_prmE.iDelaiMiliSec) .Item(iDelaiMiliSec).Checked = False .Item(iTempsMaxScenarioSec).Text = CStr(m_prmE.iTempsMaxScenarioSec) .Item(iTempsMaxScenarioSec).Checked = False .Item(ibMAJToutLEcran).Text = "" .Item(ibMAJToutLEcran).Checked = m_prmE.bMAJToutLEcran .Item(ibMAJGroupeSprites).Text = "" .Item(ibMAJGroupeSprites).Checked = m_gravity.m_prm.bMAJGroupeSprites .Item(ibNePasInitFond).Text = "" .Item(ibNePasInitFond).Checked = m_gravity.m_prm.bNePasInitFond .Item(ibNePasBufferiserGr).Text = "" .Item(ibNePasBufferiserGr).Checked = m_prmE.bNePasBufferiserGr .Item(ibFondUni).Text = "" .Item(ibFondUni).Checked = m_gravity.m_prm.bFondUni .Item(ibFondDegrade).Text = "" .Item(ibFondDegrade).Checked = m_gravity.m_prm.bFondDegrade .Item(ibPauseAnimation).Text = "" .Item(ibPauseAnimation).Checked = m_gravity.m_prm.bPauseAnimation If m_gravity.m_prm.bFondUni OrElse _ m_gravity.m_prm.bFondDegrade Then .Item(iFiltreFichiersImgFond).Checked = False End With m_bMajListPrm = False Me.ListViewPrm.Refresh() ' Utile lorsque le délai des frames diminue End Sub Private Sub SauverConfig() My.Settings.frmGravityNetPos = Me.Location My.Settings.frmGravityNetTaille = Me.Size With Me.ListViewPrm.Items My.Settings.TxtBanniere = .Item(iTxtBanniere).Text My.Settings.bAffichageBanniere = .Item(iTxtBanniere).Checked My.Settings.FiltreFichiersImgSprite = .Item(iFiltreFichiersImgSprite).Text My.Settings.FiltreFichiersImgFond = .Item(iFiltreFichiersImgFond).Text ' Ne pas sauver cette option, elle n'est pas proposée 'My.Settings.bCercle = .Item(ibCercle).Checked My.Settings.DegreRacine = iConv( _ .Item(iDegreRacine).Text, iDegreRacineDef) '.Item(iDegreRacine).Text = CStr(m_gravity.m_prm.iDegreRacine) '.Item(iDegreRacine).Checked = False My.Settings.DegreRacine_bRnd = .Item(iDegreRacine_bRnd).Checked '.Item(iDegreRacine_bRnd).Checked = m_gravity.m_prm.bDegreRacine_bRnd My.Settings.DegreRacineRndMax = iConv( _ .Item(iDegreRacineRndMax).Text, iDegreRacineMaxDef) '.Item(iDegreRacineRndMax).Text = CStr(m_gravity.m_prm.iDegreRacineRndMax) '.Item(iDegreRacineRndMax).Checked = False My.Settings.DegreRacine2 = iConv( _ .Item(iDegreRacine2).Text, iDegreRacineDef) '.Item(iDegreRacine2).Text = CStr(m_gravity.m_prm.iDegreRacine2) '.Item(iDegreRacine2).Checked = False My.Settings.DegreRacine2_bRnd = .Item(iDegreRacine2_bRnd).Checked '.Item(iDegreRacine2_bRnd).Checked = m_gravity.m_prm.bDegreRacine2_bRnd My.Settings.DegreRacine2RndMax = iConv( _ .Item(iDegreRacine2RndMax).Text, iDegreRacineMaxDef) '.Item(iDegreRacine2RndMax).Text = CStr(m_gravity.m_prm.iDegreRacine2RndMax) '.Item(iDegreRacine2RndMax).Checked = False My.Settings.bMasseSym = .Item(ibMasseSym).Checked '.Item(ibMasseSym).Checked = m_gravity.m_prm.bMasseSym My.Settings.bMasseSym_bRnd = .Item(ibMasseSym_bRnd).Checked '.Item(ibMasseSym_bRnd).Checked = m_gravity.m_prm.bMasseSym_bRnd My.Settings.b3D = .Item(ib3D).Checked '.Item(ib3D).Checked = m_gravity.m_prm.b3D My.Settings.b3D_bRnd = .Item(ib3D_bRnd).Checked '.Item(ib3D_bRnd).Checked = m_gravity.m_prm.b3D_bRnd My.Settings.b3D_bPlanetesAxeV = .Item(ib3D_bPlanetesAxeV).Checked My.Settings.b3D_bPlanetesAxeV_bRnd = .Item(ib3D_bPlanetesAxeV_bRnd).Checked My.Settings.b3D_iNbPlanetesMaxAxeV = iConv( _ .Item(ib3D_iNbPlanetesMaxAxeV).Text, 1) My.Settings.bChocs = .Item(ibChocs).Checked '.Item(ibChocs).Checked = m_gravity.m_prm.bChocs My.Settings.bChocs_bRnd = .Item(ibChocs_bRnd).Checked '.Item(ibChocs_bRnd).Checked = m_gravity.m_prm.bChocs_bRnd My.Settings.ForceGravitation = iConv( _ .Item(iForceGravitation).Text, iForceGravitationDef) '.Item(iForceGravitation).Checked = False My.Settings.DelaiMiliSec = iConv( _ .Item(iDelaiMiliSec).Text, iDelaiMiliSecDef) '.Item(iDelaiMiliSec).Text = CStr(m_prm.iDelaiMiliSec) '.Item(iDelaiMiliSec).Checked = False My.Settings.TempsMaxScenarioSec = iConv( _ .Item(iTempsMaxScenarioSec).Text, iTempsMaxScenarioSecDef) '.Item(iTempsMaxScenarioSec).Text = CStr(m_prm.iTempsMaxScenarioSec) '.Item(iTempsMaxScenarioSec).Checked = False My.Settings.bMAJToutLEcran = .Item(ibMAJToutLEcran).Checked '.Item(ibMAJToutLEcran).Checked = m_prm.bMAJToutLEcran My.Settings.bMAJGroupeSprites = .Item(ibMAJGroupeSprites).Checked '.Item(ibMAJGroupeSprites).Checked = m_gravity.m_prm.bMAJGroupeSprites My.Settings.bNePasInitFond = .Item(ibNePasInitFond).Checked '.Item(ibNePasInitFond).Checked = m_gravity.m_prm.bNePasInitFond My.Settings.bNePasBufferiserGr = .Item(ibNePasBufferiserGr).Checked '.Item(ibNePasBufferiserGr).Checked = m_prm.bNePasBufferiserGr My.Settings.bFondUni = .Item(ibFondUni).Checked '.Item(ibFondUni).Checked = m_gravity.m_prm.bFondUni My.Settings.bFondDegrade = .Item(ibFondDegrade).Checked '.Item(ibFondDegrade).Checked = m_gravity.m_prm.bFondDegrade ' Ne pas sauver cette option '.Item(ibPauseAnimation).Checked = m_gravity.m_prm.bPauseAnimation End With My.Settings.Save() End Sub Private Sub TimerAnimation_Tick(ByVal sender As Object, _ ByVal e As EventArgs) Handles TimerAnimation.Tick If m_prmE.bBoucleAnimation Then TimerAnimation.Enabled = False BoucleAnimation() Exit Sub End If Animer() End Sub Private Sub BoucleAnimation() If m_bBoucleAnimationEnCours Then Exit Sub m_bBoucleAnimationEnCours = True Do Animer() Application.DoEvents() Loop While Not m_bQuitterBoucleAnimation End Sub Private Sub Animer() If glb_bModeConfiguration Then If m_bMajListPrm Then MAJListePrm() ' Calcul du nombre de Frames Par Seconde Static iNbFrames% Static rMemDate As Double Dim rFps As Double Dim rDate As Double Const iNbFramesCalculMoy% = 30 iNbFrames = iNbFrames + 1 If iNbFrames = iNbFramesCalculMoy Then rDate = DateAndTime.Timer If rDate <> rMemDate Then rFps = iNbFramesCalculMoy / (rDate - rMemDate) ' Ne pas effacer tout de suite l'explication du prm If rMemDate <> 0 And rDate - glb_rDateMessageTitre > 5 Then _ Me.Text = m_sTitreAppli & " - Frames/s : " & _ rFps.ToString("####.0") & _ ", RAM : " & GC.GetTotalMemory(False) & _ " octets utilisés, " & _ CInt(m_prmE.iTempsMaxScenarioSec - _ (DateAndTime.Timer - m_rMemDateDepartAnimation)) rMemDate = rDate iNbFrames = 0 End If End If End If ' Utile seulement pour déplacer plusieurs contrôles de la frm ' d'un seul coup (LblBanniere par exemple), ce n'est pas utile ' pour le tracé dans la frm 'Me.SuspendLayout() If m_gravity.m_bToutesPlanetesHorsEcran Or _ DateAndTime.Timer - m_rMemDateDepartAnimation > _ m_prmE.iTempsMaxScenarioSec Then MAJAnimation(bTirageAleatoire:=True, bInitialiserFond:=True, _ bControlerPrm:=False) End If m_gravity.SimulerGravite() If m_prmE.bNePasBufferiserGr Then ' Si on ne bufférise pas le graphisme, ' on trace directement dans la form If m_grFrm Is Nothing Then m_grFrm = Me.CreateGraphics If Not m_bFondInitialise Then If Not m_gravity.m_prm.bNePasInitFond Then _ m_gravity.DessinerFond(m_grFrm) m_bFondInitialise = True End If m_gravity.Dessiner(m_grFrm, m_prmE.bNePasBufferiserGr) Else If m_prmE.bMAJToutLEcran Then Me.Invalidate() Else If m_gravity.m_prm.bMAJGroupeSprites Then Me.Invalidate(m_gravity.m_rectMAJGroupeSprites) Else Dim i% For i = 0 To m_gravity.m_iNbSprites - 1 Me.Invalidate(m_gravity.m_aSprites(i).m_rectMAJ) Next i End If End If End If If m_prmE.bAffichageBanniere Then If LblBanniere.Text <> m_prmE.sTxtBanniere Then LblBanniere.Text = m_prmE.sTxtBanniere LblBanniere.Height = LblBanniere.Font.Height LblBanniere.Width = CInt(LblBanniere.Text.Length * LblBanniere.Font.Size) End If LblBanniere.Visible = True Else LblBanniere.Visible = False End If If Not m_prmE.bAffichageBanniere Then GoTo Fin ' Gestion de la bannière ' ---------------------- Dim pt As Point pt.X = m_rectEcran.Width - m_iPosBanniereX pt.Y = LblBanniere.Location.Y '//Increment the label distance based on the speed set by the user. m_iPosBanniereX += m_iVitesseBanniere '//If the label is offscreen, then we want to reposition it to the right. If pt.X <= -LblBanniere.Width Then m_iPosBanniereX = 0 '//Reset the distance to 0. If pt.Y = 0 Then '//If the label is at the top, move it to the middle. pt.Y = m_rectEcran.Height \ 2 ElseIf pt.Y = CInt(m_rectEcran.Height / 2) Then '// If label is in the middle of the screen move it to the bottom. pt.Y = m_rectEcran.Height - LblBanniere.Height Else pt.Y = 0 '//Move the label back to the top. End If End If LblBanniere.Location = pt ' Pour éviter d'afficher la bannière avant le départ If Not LblBanniere.Visible Then LblBanniere.Visible = True Fin: 'Me.ResumeLayout(False) End Sub Protected Overrides Sub OnPaintBackground(ByVal pevent As PaintEventArgs) If Not m_gravity.m_prm.bNePasInitFond Then _ MyBase.OnPaintBackground(pevent) End Sub Protected Overrides Sub OnPaint(ByVal e As PaintEventArgs) ' Appel de la fonction de base du tracé MyBase.OnPaint(e) ' Si on trace directement depuis l'animation, c'est déjà fait If m_prmE.bNePasBufferiserGr Then Exit Sub m_gravity.Dessiner(e.Graphics, bNePasBufferiserGr:=False) End Sub Protected Overrides Sub OnMouseMove(ByVal e As MouseEventArgs) '//Determine if the mouse cursor position has been stored previously. If m_ptPosSouris.X = 0 And m_ptPosSouris.Y = 0 Then '//Store the mouse cursor coordinates. m_ptPosSouris.X = e.X m_ptPosSouris.Y = e.Y Exit Sub ElseIf e.X <> m_ptPosSouris.X Or e.Y <> m_ptPosSouris.Y Then '//Has the mouse cursor moved since the screen saver was started? If Not glb_bModeConfiguration Then Quitter() End If End Sub Protected Overrides Sub OnKeyDown(ByVal e As KeyEventArgs) If Not glb_bModeConfiguration Then Quitter() End Sub Protected Overrides Sub OnMouseDown(ByVal e As MouseEventArgs) If Not glb_bModeConfiguration Then Quitter() End Sub Private Sub FrmGravityNet_Click(ByVal sender As Object, ByVal e As EventArgs) _ Handles MyBase.Click If glb_bModeConfiguration Then _ MAJAnimation(bTirageAleatoire:=True, bInitialiserFond:=True, _ bControlerPrm:=False) End Sub Protected Overrides Sub OnSizeChanged(ByVal e As System.EventArgs) InitialiserTailleEcran() End Sub Private Sub InitialiserTailleEcran() If m_prmE.bNePasBufferiserGr Then If Not (m_grFrm Is Nothing) Then m_grFrm.Dispose() m_grFrm = Me.CreateGraphics End If m_gravity.InitialiserTailleEcran(Me.ClientSize) m_rectEcran = New Rectangle(0, 0, Me.ClientSize.Width, Me.ClientSize.Height) m_iPosBanniereX = m_rectEcran.Width \ 2 LblBanniere.Location = New Point(m_rectEcran.Width \ 2, _ m_rectEcran.Height \ 2) If Not m_gravity.m_prm.bNePasInitFond Then Me.Invalidate() End Sub Private Sub ArreterAnimation() Cursor.Show() TimerAnimation.Enabled = False m_bQuitterBoucleAnimation = True End Sub Private Sub Quitter() ArreterAnimation() Me.Close() End Sub Private Sub FrmVBNetScreenSaver_Closing(ByVal sender As Object, _ ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing ArreterAnimation() If glb_bModeConfiguration Then SauverConfig() End Sub #End Region End Class Gravity.vb Imports System.IO ' Pour Path, FileInfo Imports System.Drawing.Drawing2D ' Pour LinearGradientBrush Public Class SimulteurGravite #Region "Constantes" Public Const bDebugPosEtVitInitiales As Boolean = False ' Booléen pour annuler la gravité (debug choc) Private Const bGravite As Boolean = True 'Private Const bTestOrb3D As Boolean = False Private Const bDebugChoc As Boolean = False Private Const bDebugRectMAJ As Boolean = False Private Const bChocsMoyennes As Boolean = False ' Pour regler la vitesse initiale Private Const rRapportVitesse As Decimal = 5 Private Const iDegreRacineMax% = 6 Private Const iDegreRacineMin% = 1 #End Region #Region "Déclarations" ' Pour savoir s'il faut initialiser les img de sprites Public m_bMembCercle As Boolean Public m_bToutesPlanetesHorsEcran As Boolean Public m_szTailleFenetre As Size Public m_rectMAJGroupeSprites As Rectangle ' Rectangle de mise à jour Public m_iNbSprites% = 0 Public m_aSprites() As Sprite Public m_prm As TParametres ' Etat effectif après tirage (ne pas changer la case à cocher selon le tirage) Private m_b3D, m_bChocs, m_b3D_bPlanetesAxeV As Boolean Private m_aff As TAffichage Private m_iNbPtsTot% Private m_pt() As TPoint Private m_aCoordZ!() Private m_aIndexCoordZ%() Private m_bSystemeInitialise As Boolean ' Booléen pour indiquer si l'écran de veille est configuré Private m_bImgFondInitialisee As Boolean = False Private m_bImageFondTrouve As Boolean = False Private m_imgFond As Bitmap ' Bitmap au lieu d'Image pour GetHbitmap Private m_rectEcran As Rectangle Private m_rectImgFond As Rectangle Private m_lgbFondDegrade As LinearGradientBrush Private m_frm As Form #End Region #Region "Structures" ' Structure pour gérer les coordonnées des planètes Private Structure TPoint Dim rX, rY, rZ As Decimal ' Positions Dim rM As Decimal ' Masse Dim rVx, rVy, rVz As Decimal ' Vitesses Dim rAx, rAy, rAz As Decimal ' Accélérations Dim iNbChocs% Dim rSomX, rSomY As Decimal ' Test infructueux Dim rSomVX, rSomVY As Decimal ' Positions corrigées à l'instant précis du choc Dim rXC, rYC, rZC As Decimal Dim rAngleChoc As Decimal Dim rDx, rDy As Decimal End Structure Private Structure TAffichage Dim rMaxx As Decimal ' Amplitude horizontale de tracé Dim rMaxy As Decimal ' Amplitude verticale de tracé Dim rMaxz As Decimal ' Amplitude en profondeur du tracé Dim rMaxH As Decimal ' Taille horizontale de l'écran Dim rMaxV As Decimal ' Taille verticale de l'écran Dim rZoom As Decimal ' Pour zoomer le dessin au besoin End Structure ' Structure des propriétés d'une planète pour gérer les symétries Private Structure TProprietesPlanete Dim rMasse As Decimal ' masse de la planète Dim iNumImg% ' n° de l'image de la planète Dim rSpin As Decimal ' Spin (rotation sur elle-même) de la planète End Structure ' Structure pour le calcul initial des orbites (vitesses et positions) ' des planètes des systèmes principal et secondaire Private Structure TSysteme ' Angle pour le calcul initial des positions et vitesses Dim rAngle As Decimal Dim iNbPts% ' Nombre de planètes du système Dim iNbPtsMin% ' Nombre min. de planètes du système ' Degré de la racine unitaire complexe du système ' = Nombre de planètes (ou sous-sytèmes) du système Dim iDegreRacine% Dim iDegreRacineMin% ' Degré min. pour le tirage aléatoire Dim iDegreRacineMax% ' Degré max. pour le tirage aléatoire Dim iDegreRacineFin% ' Degré final pour le tirage aléatoire Dim rAmplitPos As Decimal ' Amplitude de la position ' (=rayon de l'orbite) Dim rAmplitPosMin As Decimal ' Amplitude minimale de la position Dim rAmplitPosMax As Decimal ' Amplitude maximale de la position Dim rAmplitVit As Decimal ' Amplitude de la vitesse initiale Dim rAmplitVitMin As Decimal ' Amplitude minimale de la vitesse initiale Dim rAmplitVitMax As Decimal ' Amplitude maximale de la vitesse initiale Dim aPlanete() As TProprietesPlanete Dim aPlaneteSym() As TProprietesPlanete Dim rAxz As Decimal ' Angles pour le calcul initial des positions Dim rAxy As Decimal ' et vitesses dans le cas 3D. Dim rAxyP As Decimal End Structure ' Structures pour les paramètres de gravity Structure TParametres Dim bSystemeFixe As Boolean Dim bMasseSym As Boolean Dim bMasseSym_bRnd As Boolean Dim iDegreRacine% ' Voir la structure TSysteme Dim iDegreRacineRndMax% Dim iDegreRacine2% Dim iDegreRacine2RndMax% Dim bDegreRacine_bRnd As Boolean ' Choix au hasard du degré Dim bDegreRacine2_bRnd As Boolean Dim bChocs As Boolean Dim bChocs_bRnd As Boolean Dim b3D As Boolean Dim b3D_bRnd As Boolean Dim b3D_bPlanetesAxeV As Boolean ' A la fois pour Oui/Non et aussi pour le nombre de planètes à ajouter Dim b3D_bPlanetesAxeV_bRnd As Boolean Dim b3D_iNbPlanetesMaxAxeV% Dim bCercle As Boolean Dim rForceGravitation As Decimal Dim bMAJGroupeSprites As Boolean Dim bImageFond As Boolean Dim bNePasInitFond As Boolean Dim bNePasDecentrerImgFond As Boolean ' On gagne 5 à 10 % en vitesse Dim bNePasAgrandirImgFond As Boolean Dim bClipping As Boolean Dim bFondUni As Boolean Dim bFondDegrade As Boolean Dim bPauseAnimation As Boolean Dim sFiltreFichiersImgSprite$ Dim sFiltreFichiersImgFond$ End Structure #End Region #Region "Initialisations" Public Sub New(ByRef FrmGravityNet As Form) m_frm = FrmGravityNet ' Pour afficher un msg dans la barre de titre m_bSystemeInitialise = False m_bToutesPlanetesHorsEcran = True m_prm.bImageFond = My.Settings.bImageFond m_prm.bMAJGroupeSprites = My.Settings.bMAJGroupeSprites m_prm.bNePasInitFond = My.Settings.bNePasInitFond m_prm.bFondDegrade = My.Settings.bFondDegrade m_prm.bFondUni = My.Settings.bFondUni m_prm.bSystemeFixe = True ' Pour centrer l'ensemble des planètes m_prm.bMasseSym = My.Settings.bMasseSym m_prm.bMasseSym_bRnd = My.Settings.bMasseSym_bRnd m_prm.bCercle = My.Settings.bCercle m_prm.iDegreRacine = My.Settings.DegreRacine m_prm.iDegreRacineRndMax = My.Settings.DegreRacineRndMax m_prm.bDegreRacine_bRnd = My.Settings.DegreRacine_bRnd m_prm.iDegreRacine2 = My.Settings.DegreRacine2 m_prm.iDegreRacine2RndMax = My.Settings.DegreRacine2RndMax m_prm.bDegreRacine2_bRnd = My.Settings.DegreRacine2_bRnd m_prm.rForceGravitation = My.Settings.ForceGravitation m_prm.b3D = My.Settings.b3D m_prm.b3D_bRnd = My.Settings.b3D_bRnd m_prm.bChocs = My.Settings.bChocs m_prm.bChocs_bRnd = My.Settings.bChocs_bRnd m_prm.b3D_bPlanetesAxeV = My.Settings.b3D_bPlanetesAxeV m_prm.b3D_bPlanetesAxeV_bRnd = My.Settings.b3D_bPlanetesAxeV_bRnd m_prm.b3D_iNbPlanetesMaxAxeV = My.Settings.b3D_iNbPlanetesMaxAxeV If bDebugChoc Then m_prm.bMasseSym = True m_prm.bMasseSym_bRnd = False m_prm.bCercle = True m_prm.bDegreRacine_bRnd = False m_prm.iDegreRacine2 = 1 m_prm.bDegreRacine2_bRnd = False End If m_prm.sFiltreFichiersImgFond = My.Settings.FiltreFichiersImgFond m_prm.sFiltreFichiersImgSprite = My.Settings.FiltreFichiersImgSprite ControlerParametres() End Sub Public Sub ControlerParametres() 'If m_prm.bFondUni OrElse m_prm.bFondDegrade Then m_prm.bImageFond = False If m_prm.bImageFond Then m_prm.bFondUni = False : m_prm.bFondDegrade = False If m_prm.bFondDegrade Then m_prm.bFondUni = False : m_prm.bImageFond = False If m_prm.bFondUni Then m_prm.bFondDegrade = False : m_prm.bImageFond = False If m_prm.iDegreRacineRndMax <= m_prm.iDegreRacine Then _ m_prm.iDegreRacineRndMax = m_prm.iDegreRacine + 1 If m_prm.iDegreRacineRndMax < iDegreRacineMin Then _ m_prm.iDegreRacineRndMax = iDegreRacineMin If m_prm.iDegreRacineRndMax > iDegreRacineMax Then _ m_prm.iDegreRacineRndMax = iDegreRacineMax If m_prm.iDegreRacine2RndMax <= m_prm.iDegreRacine2 Then _ m_prm.iDegreRacine2RndMax = m_prm.iDegreRacine2 + 1 If m_prm.iDegreRacine2RndMax < iDegreRacineMin Then _ m_prm.iDegreRacine2RndMax = iDegreRacineMin If m_prm.iDegreRacine2RndMax > iDegreRacineMax Then _ m_prm.iDegreRacine2RndMax = iDegreRacineMax If m_prm.iDegreRacine < iDegreRacineMin Then _ m_prm.iDegreRacine = iDegreRacineMin If m_prm.iDegreRacine > iDegreRacineMax Then _ m_prm.iDegreRacine = iDegreRacineMax If m_prm.iDegreRacine2 < iDegreRacineMin Then _ m_prm.iDegreRacine2 = iDegreRacineMin If m_prm.iDegreRacine2 > iDegreRacineMax Then _ m_prm.iDegreRacine2 = iDegreRacineMax If Not m_prm.bDegreRacine_bRnd And m_prm.iDegreRacine = 1 _ And m_prm.iDegreRacine2 = 1 Then m_prm.iDegreRacine = 2 If m_prm.rForceGravitation <= 0 Then m_prm.rForceGravitation = 0 If m_prm.b3D_bRnd Then m_prm.b3D = True If m_prm.b3D_bPlanetesAxeV_bRnd Then m_prm.b3D_bPlanetesAxeV = True If m_prm.bChocs_bRnd Then m_prm.bChocs = True ' Si on active les chocs, on désactive la 3D, car je n'arrive ' pas à faire coincider précisément l'instant du choc avec ' le graphisme (le système de projection est trop simpliste) If m_prm.bChocs And Not bDebugChoc Then m_prm.b3D = False : m_prm.b3D_bRnd = False End Sub Private Function iRandomiser%(ByVal iMin%, ByVal iMax%, _ Optional ByVal rRnd As Decimal = -1D) If iMin = iMax Then iRandomiser = iMin : Exit Function If rRnd = -1D Then rRnd = CDec(Rnd()) iRandomiser = CInt(rRnd * (iMax - iMin)) + iMin If iRandomiser > iMax Then Stop iRandomiser = iMax End If End Function Private Function rRandomiser(ByVal rMin As Decimal, _ ByVal rMax As Decimal) As Decimal If rMin = rMax Then rRandomiser = rMin : Exit Function rRandomiser = CDec(Rnd() * (rMax - rMin)) + rMin End Function Public Sub TirageAleatoire() m_bSystemeInitialise = False If bDebugPosEtVitInitiales Then m_prm.bPauseAnimation = True ' Imbrication de deux systèmes en rotation Dim sys1, sys2 As TSysteme sys2.aPlaneteSym = Nothing ' Pour éviter Warning Dim k, i, j, l As Integer Dim rAmplitMasseMin, rAmplitMasseMax As Decimal Dim rSpinMaxDeg As Decimal Dim iNbPts2Sur2% Dim bMasseSym As Boolean ' Numéro de chaque constante du tirage ' pour faciliter une future sauvegarde de la session, ' il suffit de sauver chaque Rnd(0 à iNbRnd) ' avec un format de précision Const iRndDeg1% = 0 'Const iRndPlanete1% = 1 Const iRndAmplitOrb1% = 2 Const iRndAmplitVit1% = 3 Const iRndAngleDepart1% = 4 Const iRndNbPts2% = 5 'Const iRndPlanete2% = 6 Const iRndbMasseSym2% = 7 'Const iRndMasse2% = 8 Const iRndAmplitOrb2% = 9 Const iRndAmplitVit2% = 10 Const iRndAngleDepart2% = 11 Const iRndNumImgSym2% = 12 Const iRndSpinImgSym2% = 13 Const iRndb3D% = 14 Const iRndbChocs% = 15 Const iRndb3D_bPlanetesAxeV_bRnd% = 16 Const iNbRnd% = 16 Dim arRnd(iNbRnd) As Decimal Dim asFichiersImg$() = Nothing Dim iNbFichiersPlanetes% = 0 Dim sFiltre$ = m_prm.sFiltreFichiersImgSprite If sFiltre = "" Then GoTo Nouveau_Tirage Dim sRepertoire$ = Application.StartupPath Dim sRepertoireImgSprite$ = sRepertoire Dim iPos% = sFiltre.IndexOf("\") If iPos > 0 Then sRepertoireImgSprite = sRepertoire & "\" & _ sFiltre.Substring(0, iPos) sFiltre = sFiltre.Substring(iPos + 1) End If If Not bDossierExiste(sRepertoireImgSprite) Then GoTo Nouveau_Tirage Try asFichiersImg = Directory.GetFiles(sRepertoireImgSprite, sFiltre) '"star_*.*") iNbFichiersPlanetes = asFichiersImg.Length Catch iNbFichiersPlanetes = 0 End Try Nouveau_Tirage: m_bMembCercle = m_prm.bCercle Randomize() ' Initialise le générateur de nombres aléatoires. For i = 0 To iNbRnd arRnd(i) = CDec(Rnd()) Next i m_bChocs = m_prm.bChocs If m_prm.bChocs_bRnd Then _ m_bChocs = (arRnd(iRndbChocs) > 0.5) ' 1 chance sur 2 m_b3D = m_prm.b3D If m_prm.b3D_bRnd Then _ m_b3D = (arRnd(iRndb3D) > 0.5) ' Si on active les chocs, on désactive la 3D If m_bChocs And Not bDebugChoc Then m_b3D = False m_b3D_bPlanetesAxeV = m_prm.b3D_bPlanetesAxeV If m_b3D And m_prm.b3D_bPlanetesAxeV_bRnd Then _ m_b3D_bPlanetesAxeV = (arRnd(iRndb3D_bPlanetesAxeV_bRnd) > 0.5) ' Définition des tailles d'écran m_aff.rMaxH = m_szTailleFenetre.Width m_aff.rMaxV = m_szTailleFenetre.Height m_aff.rMaxx = m_aff.rMaxH m_aff.rMaxy = m_aff.rMaxV If m_b3D Then 'Or bTestOrb3D Then ' Définition de la perspective 3D m_aff.rMaxx = 0.66D * m_aff.rMaxH m_aff.rMaxy = 0.66D * m_aff.rMaxV m_aff.rMaxz = 0.33D * m_aff.rMaxH If 0.33 * m_aff.rMaxV < m_aff.rMaxz Then _ m_aff.rMaxz = 0.33D * m_aff.rMaxV End If m_aff.rZoom = m_aff.rMaxH / m_aff.rMaxx If m_aff.rMaxV / m_aff.rMaxy < m_aff.rZoom Then _ m_aff.rZoom = m_aff.rMaxV / m_aff.rMaxy If m_b3D Then 'Or bTestOrb3D Then If m_aff.rMaxH / m_aff.rMaxz < m_aff.rZoom Then _ m_aff.rZoom = m_aff.rMaxH / m_aff.rMaxz If m_aff.rMaxV / m_aff.rMaxz < m_aff.rZoom Then _ m_aff.rZoom = m_aff.rMaxV / m_aff.rMaxz End If sys1.iDegreRacineMin = m_prm.iDegreRacine If m_prm.bDegreRacine_bRnd Then sys1.iDegreRacineMax = m_prm.iDegreRacineRndMax Else sys1.iDegreRacineMax = m_prm.iDegreRacine End If sys2.iNbPtsMin = m_prm.iDegreRacine2 If m_prm.bDegreRacine2_bRnd Then sys2.iDegreRacineMax = m_prm.iDegreRacine2RndMax Else sys2.iDegreRacineMax = m_prm.iDegreRacine2 End If rSpinMaxDeg = 7 rAmplitMasseMax = 70 '150 rAmplitMasseMin = 5 '10 sys1.rAmplitVitMin = 0 sys1.rAmplitVitMax = 1.5D sys2.rAmplitVitMin = 0 sys2.rAmplitVitMax = 1 ' Test d'une autre représentation 3D Const bTest3D As Boolean = False ' Angles des plans xz et xy du système 2 If bTest3D Then sys2.rAxz = 0 sys2.rAxy = CDec(Math.PI / 2) sys2.rAxyP = CDec(Math.PI / 2) rAmplitMasseMin = 20 '5 sys1.rAmplitVitMin = 0.5D sys2.rAmplitVitMin = 0.5D sys1.rAmplitVitMax = sys1.rAmplitVitMin rAmplitMasseMax = rAmplitMasseMin sys2.rAmplitVitMax = sys2.rAmplitVitMin End If ' Détermination du nombre de planètes (=pt) de chaque système sys2.iNbPts = sys2.iNbPtsMin + _ CInt((sys2.iDegreRacineMax - sys2.iNbPtsMin) * arRnd(iRndNbPts2)) ' S'il n'y a qu'un pt dans le système secondaire, ' pas de rotation autour d'un axe If sys2.iNbPts <= 1 Then sys2.rAmplitPos = 0 : sys2.rAmplitVit = 0 sys1.iDegreRacineFin = sys1.iDegreRacineMin + _ CInt((sys1.iDegreRacineMax - sys1.iDegreRacineMin) * arRnd(iRndDeg1)) sys1.iNbPts = sys1.iDegreRacineFin m_iNbPtsTot = sys2.iNbPts * sys1.iNbPts If m_iNbPtsTot = 1 Then GoTo Nouveau_Tirage ' Test Orbites 3D Dim planeteAxeZ As TSysteme planeteAxeZ.aPlanete = Nothing ' Pour éviter Warning Dim iNbPlanetesZ% 'If bTestOrb3D Then If m_b3D And m_b3D_bPlanetesAxeV Then ' Ajout de planètes dans l'axe vertical 3D : ' Cela ne pertube pas l'équilibre du plan horizontal 'Const iNbPlanetesZMax% = 5 Dim iNbPlanetesZMax% = m_prm.b3D_iNbPlanetesMaxAxeV If m_prm.b3D_bPlanetesAxeV_bRnd Then iNbPlanetesZ = iRandomiser(0, iNbPlanetesZMax) Else iNbPlanetesZ = iNbPlanetesZMax End If ' ToDo : faire une fonction : code dupliqué For j = 0 To iNbPlanetesZ - 1 m_iNbPtsTot += 1 ReDim Preserve planeteAxeZ.aPlanete(j) planeteAxeZ.aPlanete(j).rMasse = _ rRandomiser(rAmplitMasseMin, rAmplitMasseMax) If iNbFichiersPlanetes > 0 Then planeteAxeZ.aPlanete(j).iNumImg = _ iRandomiser(0, iNbFichiersPlanetes - 1) End If planeteAxeZ.aPlanete(j).rSpin = rRandomiser(-rSpinMaxDeg, rSpinMaxDeg) Next j End If ' Détermination des amplitudes max. et min. des orbites ' Relatif à maxx sys1.rAmplitPosMin = 0.1D ' 50% de l'espace Horiz. pour le rayon orbitale max. du système 1 : sys1.rAmplitPosMax = 0.5D ' L'amplitude du système 2 est relatif à l'amplitude du système primaire choisit ' sauf si celui ci est de degré 1 (c.a.d. système 2 seulement) If sys1.iDegreRacineFin = 1 Then sys2.rAmplitPosMin = 0.1D sys2.rAmplitPosMax = 0.5D Else sys2.rAmplitPosMin = sys1.rAmplitPosMin / 2 sys2.rAmplitPosMax = sys1.rAmplitPosMax / 2 End If sys1.rAmplitPos = m_aff.rMaxx * (sys1.rAmplitPosMin + _ (sys1.rAmplitPosMax - sys1.rAmplitPosMin) * arRnd(iRndAmplitOrb1)) If sys1.iDegreRacineFin = 1 Then sys2.rAmplitPos = CDec(0.5 * m_aff.rMaxx * (sys2.rAmplitPosMin + _ (sys2.rAmplitPosMax - sys2.rAmplitPosMin) * arRnd(iRndAmplitOrb2))) Else sys2.rAmplitPos = m_aff.rMaxx * sys2.rAmplitPosMin + _ (sys2.rAmplitPosMax - sys2.rAmplitPosMin) * _ sys1.rAmplitPos * arRnd(iRndAmplitOrb2) End If ' Détermination des vitesses initiales des planètes sys1.rAmplitVit = sys1.rAmplitVitMin + _ (sys1.rAmplitVitMax - sys1.rAmplitVitMin) * arRnd(iRndAmplitVit1) sys2.rAmplitVit = sys2.rAmplitVitMin + _ (sys2.rAmplitVitMax - sys2.rAmplitVitMin) * arRnd(iRndAmplitVit2) sys1.rAmplitVit = CDec(sys1.rAmplitVit * _ Math.Sqrt(m_prm.rForceGravitation / rRapportVitesse)) sys2.rAmplitVit = CDec(sys2.rAmplitVit * _ Math.Sqrt(m_prm.rForceGravitation / rRapportVitesse)) If bTest3D Then sys1.rAmplitPos = m_aff.rMaxx * 0.5D sys2.rAmplitPos = sys1.rAmplitPos / 6 If sys2.iNbPts <= 1 Then sys2.rAmplitPos = 0 : sys2.rAmplitVit = 0 End If m_iNbSprites = 0 ReDim m_aSprites(0) ReDim m_aCoordZ(0) ReDim m_aIndexCoordZ(0) 'GC.Collect() ' Récuperer tout de suite la mémoire allouée des sprites ReDim sys2.aPlanete(sys2.iNbPts - 1) ReDim m_pt(m_iNbPtsTot - 1) If m_b3D Then 'Or bTestOrb3D Then ReDim m_aCoordZ(m_iNbPtsTot - 1) ReDim m_aIndexCoordZ(m_iNbPtsTot - 1) End If ' Recherche des multiples de 2 pour le système secondaire ' (la symétrie n'est possible que s'il y a un nombre pair de planètes) Dim iDivNbPts2% iDivNbPts2 = sys2.iNbPts Mod 2 bMasseSym = m_prm.bMasseSym If m_prm.bMasseSym_bRnd Then _ bMasseSym = (arRnd(iRndbMasseSym2) > 0.5) ' 1 chance sur 2 For i = 0 To sys2.iNbPts - 1 sys2.aPlanete(i).rMasse = _ rRandomiser(rAmplitMasseMin, rAmplitMasseMax) If iNbFichiersPlanetes > 0 Then sys2.aPlanete(i).iNumImg = iRandomiser(0, iNbFichiersPlanetes - 1) End If sys2.aPlanete(i).rSpin = rRandomiser(0, 1) 'CDec(Rnd()) 'sys2.aPlanete(i).rSpin = rRandomiser(-rSpinMaxDeg, rSpinMaxDeg) Next i If bMasseSym Then iNbPts2Sur2 = sys2.iNbPts \ 2 If sys2.iNbPts = 1 Then iNbPts2Sur2 = 1 ReDim sys2.aPlaneteSym(iNbPts2Sur2) For i = 0 To iNbPts2Sur2 - 1 sys2.aPlaneteSym(i).rMasse = _ rRandomiser(rAmplitMasseMin, rAmplitMasseMax) If iNbFichiersPlanetes > 0 Then sys2.aPlaneteSym(i).iNumImg = _ iRandomiser(0, iNbFichiersPlanetes - 1, arRnd(iRndNumImgSym2)) End If sys2.aPlaneteSym(i).rSpin = arRnd(iRndSpinImgSym2) Next i End If ' Calcul des racines unitaires complexes : Z^n = 1 ' avec Z un nombre complexe et n = degré ou nombre de planètes par système Dim rAngleDepart1 As Decimal '= 0 'Math.PI / 2 Dim rAngleDepart2 As Decimal '= 0 'Math.PI / 2 rAngleDepart1 = CDec(arRnd(iRndAngleDepart1) * Math.PI * 2) rAngleDepart2 = CDec(arRnd(iRndAngleDepart2) * Math.PI * 2) i = 0 : j = 0 For l = 0 To sys1.iNbPts - 1 For k = 0 To sys2.iNbPts - 1 i = l * sys2.iNbPts sys1.rAngle = CDec(rAngleDepart1 + 2D * Math.PI * l / sys1.iNbPts) sys2.rAngle = CDec(rAngleDepart2 + sys1.rAngle + _ 2D * Math.PI * k / sys2.iNbPts) m_pt(i + k).rX = CDec(m_aff.rMaxx * 0.5 + _ sys1.rAmplitPos * Math.Cos(sys1.rAngle) + _ sys2.rAmplitPos * Math.Cos(sys2.rAngle)) m_pt(i + k).rY = CDec(m_aff.rMaxy * 0.5 + _ sys1.rAmplitPos * Math.Sin(sys1.rAngle) + _ sys2.rAmplitPos * Math.Sin(sys2.rAngle)) m_pt(i + k).rZ = 0 If m_b3D Then If bTest3D Then sys2.rAngle = CDec(2D * Math.PI * k / sys2.iNbPts) m_pt(i + k).rX = CDec(m_aff.rMaxx * 0.5 + _ sys2.rAmplitPos * Math.Sin(sys2.rAngle + sys2.rAxz) * _ Math.Sin(sys1.rAngle + sys2.rAxyP) + _ sys1.rAmplitPos * Math.Cos(sys1.rAngle)) m_pt(i + k).rY = CDec(m_aff.rMaxy * 0.5 + _ sys2.rAmplitPos * Math.Sin(sys2.rAngle + sys2.rAxz) * _ Math.Cos(sys1.rAngle + sys2.rAxyP) + _ sys1.rAmplitPos * Math.Sin(sys1.rAngle)) m_pt(i + k).rZ = CDec(m_aff.rMaxz * 0.5 + _ sys2.rAmplitPos * Math.Cos(sys2.rAngle + sys2.rAxz)) Else m_pt(i + k).rX = CDec(m_aff.rMaxx * 0.5 + _ sys1.rAmplitPos * Math.Cos(sys1.rAngle) + _ sys2.rAmplitPos * Math.Cos(sys2.rAngle)) m_pt(i + k).rY = m_aff.rMaxy * 0.5D m_pt(i + k).rZ = CDec(m_aff.rMaxz * 0.5 + _ sys1.rAmplitPos * Math.Sin(sys1.rAngle) + _ sys2.rAmplitPos * Math.Sin(sys2.rAngle)) End If End If ' Déphasage des vecteurs vitesses par rapport aux positions sys1.rAngle = CDec(rAngleDepart1 + _ Math.PI * (2D * l / sys1.iNbPts - 0.5D)) sys2.rAngle = CDec(rAngleDepart2 + sys1.rAngle + _ 2D * Math.PI * k / sys2.iNbPts) m_pt(i + k).rVx = CDec(sys1.rAmplitVit * Math.Cos(sys1.rAngle) + _ sys2.rAmplitVit * Math.Cos(sys2.rAngle)) m_pt(i + k).rVy = CDec(sys1.rAmplitVit * Math.Sin(sys1.rAngle) + _ sys2.rAmplitVit * Math.Sin(sys2.rAngle)) m_pt(i + k).rVz = 0 If m_b3D Then If bTest3D Then sys1.rAngle = CDec(2D * Math.PI * l / sys1.iNbPts) sys2.rAngle = CDec(2D * Math.PI * k / sys2.iNbPts) m_pt(i + k).rVx = CDec(-sys2.rAmplitVit * _ Math.Cos(sys2.rAngle + sys2.rAxz) * _ Math.Sin(sys1.rAngle + sys2.rAxy) - _ sys1.rAmplitVit * Math.Sin(sys1.rAngle)) m_pt(i + k).rVy = CDec(-sys2.rAmplitVit * _ Math.Cos(sys2.rAngle + sys2.rAxz) * _ Math.Cos(sys1.rAngle + sys2.rAxy) + _ sys1.rAmplitVit * Math.Cos(sys1.rAngle)) m_pt(i + k).rVz = CDec(sys2.rAmplitVit * Math.Sin(sys2.rAngle + sys2.rAxz)) Else m_pt(i + k).rVy = 0 m_pt(i + k).rVz = CDec( _ sys1.rAmplitVit * Math.Sin(sys1.rAngle) + _ sys2.rAmplitVit * Math.Sin(sys2.rAngle)) End If End If m_pt(i + k).rM = sys2.aPlanete(k).rMasse If bMasseSym Then m_pt(i + k).rM = sys2.aPlaneteSym(j).rMasse If bDebugChoc Then m_pt(i + k).rVx = 0 m_pt(i + k).rVy = 0 m_pt(i + k).rVz = 0 'If i + k = 0 Then m_pt(i + k).rVy = 1 'If i + k = 0 Then m_pt(i + k).rVx = 1 m_pt(i + k).rM = 50 '+ i * 50 End If If m_iNbSprites = 0 Then ReDim m_aSprites(0) Else ReDim Preserve m_aSprites(m_iNbSprites) End If m_iNbSprites += 1 ' Diametre du cercle : il dépend du zoom, car la détection ' des chocs est basée sur les positions qui sont zoomées Dim iDiametre% = CInt(m_aff.rZoom * m_pt(i + k).rM * 2) ' En 3D le diamètre est proportionnel à la moitié du zoom 'Or bTestOrb3D Then _ If m_b3D Then _ iDiametre = CInt(0.5 * m_aff.rZoom * m_pt(i + k).rM * 2) Dim rRnd! = sys2.aPlanete(k).rSpin If bMasseSym Then rRnd = sys2.aPlaneteSym(j).rSpin Dim rDeltaAngleRotImg! = CSng(2 * rSpinMaxDeg * (rRnd - 0.5)) ' Raffinement : tentative d'équilibrage des moments d'inertie If bMasseSym Then rDeltaAngleRotImg *= CSng(Math.Pow(-1, i + k)) m_aSprites(i + k) = New Sprite(iDiametre, rDeltaAngleRotImg) If m_prm.bCercle Or iNbFichiersPlanetes = 0 Then m_aSprites(i + k).m_bCercle = True Else m_aSprites(i + k).m_bCercle = False Dim iNumImg% = sys2.aPlanete(k).iNumImg If bMasseSym Then iNumImg = sys2.aPlaneteSym(j).iNumImg Dim sFichierImagePlanete$ = asFichiersImg(iNumImg) m_aSprites(i + k).InitialiserImage(sFichierImagePlanete) End If If bMasseSym Then j = j + 1 If j >= iNbPts2Sur2 Then j = 0 End If Next k Next l 'If Not bTestOrb3D Then Exit Sub If Not (m_b3D And m_b3D_bPlanetesAxeV) Then Exit Sub ' Test Orbites 3D ' ToDo : faire une fonction pour l'ajout d'un sprite For i = m_iNbPtsTot - iNbPlanetesZ To m_iNbPtsTot - 1 If m_b3D Then m_pt(i).rX = CDec(m_aff.rMaxx * 0.5) m_pt(i).rY = CDec(m_aff.rMaxy * (2 * Rnd() - 1)) m_pt(i).rZ = CDec(m_aff.rMaxz * 0.5) Else ' ??? m_pt(i).rX = CDec(m_aff.rMaxx * 0.5) m_pt(i).rY = CDec(m_aff.rMaxy * 0.5) m_pt(i).rZ = CDec(m_aff.rMaxz * (2 * Rnd() - 1)) End If m_pt(i).rVx = 0 m_pt(i).rVy = 0 m_pt(i).rVz = 0 j = i - (m_iNbPtsTot - iNbPlanetesZ) m_pt(i).rM = planeteAxeZ.aPlanete(j).rMasse If m_pt(i).rM = 0 Then Stop Dim iDiametre0% = CInt(m_aff.rZoom * m_pt(i).rM * 2) 'Or bTestOrb3D Then _ If m_b3D Then _ iDiametre0 = CInt(0.5 * m_aff.rZoom * m_pt(i).rM * 2) ReDim Preserve m_aSprites(m_iNbSprites) m_iNbSprites += 1 Dim rSpin! = planeteAxeZ.aPlanete(j).rSpin m_aSprites(i) = New Sprite(iDiametre0, rSpin) If m_prm.bCercle Or iNbFichiersPlanetes = 0 Then m_aSprites(i).m_bCercle = True Else m_aSprites(i).m_bCercle = False Dim iNumImg% = planeteAxeZ.aPlanete(j).iNumImg 'If bMasseSym Then iNumImg = planeteAxeZ.aPlaneteSym(j).iNumImg Dim sFichierImagePlanete$ = asFichiersImg(iNumImg) m_aSprites(i).InitialiserImage(sFichierImagePlanete) End If Next i End Sub Private Function rLireAngle(ByVal rAbscisse As Decimal, _ ByVal rOrdonnee As Decimal) As Decimal Dim rInterm As Decimal If (rAbscisse <> 0) Then rInterm = CDec(Math.Atan(Math.Abs(rOrdonnee / rAbscisse))) Else If (rOrdonnee < 0) Then rInterm = CDec(0.5D * Math.PI) Else rInterm = CDec(1.5D * Math.PI) End If End If If (rAbscisse > 0 And rOrdonnee > 0) Then _ rInterm = CDec(2D * Math.PI - rInterm) If (rAbscisse < 0 And rOrdonnee <= 0) Then _ rInterm = CDec(Math.PI - rInterm) If (rAbscisse < 0 And rOrdonnee >= 0) Then _ rInterm = CDec(Math.PI + rInterm) rLireAngle = rInterm End Function #End Region #Region "Traitements" Public Sub SimulerGravite() Dim i%, j% Dim rDy, rFacteurGravtitation, rNorme2, rMinNorme, rNorme, rDx, rDz As Decimal Dim rMVy, rMFG, rSFGy, rSFGx, rSFGz, rMVx, rMVz As Decimal Dim rSM As Decimal ' Somme des masses Dim rCMy, rCMx, rCMz As Decimal ' Centres de masse ' Détermination de la stabilité de la vitesse totale du système If Not m_bSystemeInitialise Then m_bSystemeInitialise = True If (m_prm.bSystemeFixe) Then rMVx = 0 : rMVy = 0 : rMVz = 0 rCMx = 0 : rCMy = 0 : rCMz = 0 For i = 0 To m_iNbPtsTot - 1 rMVx += m_pt(i).rM * m_pt(i).rVx rMVy += m_pt(i).rM * m_pt(i).rVy rMVz += m_pt(i).rM * m_pt(i).rVz rSM = rSM + m_pt(i).rM rCMx += m_pt(i).rM * m_pt(i).rX rCMy += m_pt(i).rM * m_pt(i).rY rCMz += m_pt(i).rM * m_pt(i).rZ Next i ' Stabilisation du système au centre de l'écran For i = 0 To m_iNbPtsTot - 1 m_pt(i).rVx -= rMVx / rSM ' Vitesses m_pt(i).rVy -= rMVy / rSM m_pt(i).rVz -= rMVz / rSM m_pt(i).rX += m_aff.rMaxx / 2 - rCMx / rSM ' Positions m_pt(i).rY += m_aff.rMaxy / 2 - rCMy / rSM m_pt(i).rZ += m_aff.rMaxz / 2 - rCMz / rSM Next i End If End If For i = 0 To m_iNbPtsTot - 1 Dim rX! = m_pt(i).rX Dim rY! = m_pt(i).rY Dim rZ! = m_pt(i).rZ Dim rVX! = m_pt(i).rVx Dim rVY! = m_pt(i).rVy Dim rVZ! = m_pt(i).rVz m_pt(i).iNbChocs = 0 m_pt(i).rSomX = 0 : m_pt(i).rSomY = 0 m_pt(i).rSomVX = 0 : m_pt(i).rSomVY = 0 m_pt(i).rAx = 0 : m_pt(i).rAy = 0 : m_pt(i).rAz = 0 Next i For i = 0 To m_iNbPtsTot - 1 For j = i + 1 To m_iNbPtsTot - 1 ' Analyse de la distance entre chaque planète 2 à 2 ' afin d'en évaluer l'attraction gravitationnelle rDx = m_pt(j).rX - m_pt(i).rX rDy = m_pt(j).rY - m_pt(i).rY rDz = m_pt(j).rZ - m_pt(i).rZ rNorme2 = rDx * rDx + rDy * rDy 'Or bTestOrb3D If m_b3D Then rNorme2 += rDz * rDz rNorme = CDec(Math.Sqrt(rNorme2)) ' La masse est représentée par le rayon, ' l'instant du choc correpond au 2 rayons rMinNorme = (m_pt(i).rM + m_pt(j).rM) If (rNorme >= rMinNorme) Then _ rFacteurGravtitation = 1 / rNorme2 : GoTo Suite If Not m_bChocs Then ' Au lieu de simuler un choc lorsque les planètes se touchent, ' on annule progressivement la gravité comme si les ' planètes se superposaient en 3D. On imagine que les planètes ' s'attirent sans jamais se toucher : fantômes ' La norme passe du coté supérieur de la fraction pour ' inverser la gravité ! ' On divise par rMinNorme3 afin que la force gravitationnelle ' soit continue au point de contact ! rFacteurGravtitation = rNorme / (rMinNorme * rMinNorme * rMinNorme) ' Minoration de la norme pour minorer l'attraction rNorme = rMinNorme GoTo Suite End If GererChoc(i, j, rDx, rDy, rDz, _ rNorme, rMinNorme, rNorme2, rFacteurGravtitation) Suite: ' Loi de la gravitation ' rMFG = module de la force gravitationnelle rMFG = m_prm.rForceGravitation * m_pt(i).rM * m_pt(j).rM * _ rFacteurGravtitation ' [rDx, rDy] / rNorme = vecteur unitaire ' rSFG = somme des forces gravitationnelles rSFGx = rMFG * rDx / rNorme rSFGy = rMFG * rDy / rNorme rSFGz = rMFG * rDz / rNorme ' Transformation de la force de gravité en accélération m_pt(i).rAx += rSFGx / m_pt(i).rM m_pt(i).rAy += rSFGy / m_pt(i).rM m_pt(i).rAz += rSFGz / m_pt(i).rM m_pt(j).rAx -= rSFGx / m_pt(j).rM m_pt(j).rAy -= rSFGy / m_pt(j).rM m_pt(j).rAz -= rSFGz / m_pt(j).rM Next j : Next i ' Vérification si tous les points sont sortis de l'écran m_bToutesPlanetesHorsEcran = True ' Détermination de la nouvelle position de chaque planète : (iH, iV) m_rectMAJGroupeSprites = New Rectangle(0, 0, 0, 0) Dim iV%, iH%, iRayon%, iDiametre%, rZoomDA! Const iRayonMinAffichage% = 3 For i = 0 To m_iNbPtsTot - 1 If m_pt(i).iNbChocs > 0 And bChocsMoyennes Then m_pt(i).rVx = m_pt(i).rSomVX / m_pt(i).iNbChocs m_pt(i).rVy = m_pt(i).rSomVY / m_pt(i).iNbChocs m_pt(i).rX = m_pt(i).rSomX / m_pt(i).iNbChocs m_pt(i).rY = m_pt(i).rSomY / m_pt(i).iNbChocs End If If bGravite And Not m_prm.bPauseAnimation Then ' m_bGravite : Booléen pour annuler la gravité (debug choc) m_pt(i).rVx += m_pt(i).rAx m_pt(i).rVy += m_pt(i).rAy m_pt(i).rVz += m_pt(i).rAz End If ' Transformation des vitesses en mouvement effectif If Not m_prm.bPauseAnimation Then m_pt(i).rX += m_pt(i).rVx m_pt(i).rY += m_pt(i).rVy m_pt(i).rZ += m_pt(i).rVz End If ProjeterCoord(iH, iV, rZoomDA, _ m_pt(i).rX, m_pt(i).rY, m_pt(i).rZ) m_aSprites(i).FixerPosition(New Point(iH, iV)) m_aSprites(i).DiametreApparent(rZoomDA, iRayonMinAffichage) m_aSprites(i).m_bCercle = m_prm.bCercle m_aSprites(i).m_bPositionInitialisee = True iRayon = CInt(m_pt(i).rM * m_aff.rZoom) If m_b3D Then 'Or bTestOrb3D Then ' En 3D le diametre est 2 fois + faible, ' car il est projeté 50-50 sur x et z / y et z iDiametre = CInt(iRayon * rZoomDA) Else iDiametre = CInt(iRayon * 2 * rZoomDA) End If ' Il faut une marge à cause de la rotation iDiametre = CInt(iDiametre * 1.2) iRayon = iDiametre \ 2 If iRayon < iRayonMinAffichage Then _ iRayon = iRayonMinAffichage If iDiametre < 2 * iRayonMinAffichage Then _ iDiametre = 2 * iRayonMinAffichage ' Méthode de MAJ précise : on invalide chaque rectangle : ' c'est + rapide car la zone de MAJ est + petite m_aSprites(i).m_rectPos = New Rectangle( _ iH - iRayon - 1, iV - iRayon - 1, _ iDiametre + 2, iDiametre + 2) If m_aSprites(i).m_rectMemPos.Width = 0 Then m_aSprites(i).m_rectMAJ = m_aSprites(i).m_rectPos Else m_aSprites(i).m_rectMAJ = Rectangle.Union( _ m_aSprites(i).m_rectPos, _ m_aSprites(i).m_rectMemPos) End If ' Méthode de MAJ en groupe : jolie pour les transitions ' bMAJGroupeSprites = True If m_rectMAJGroupeSprites.Width = 0 Then m_rectMAJGroupeSprites = m_aSprites(i).m_rectPos Else m_rectMAJGroupeSprites = Rectangle.Union( _ m_rectMAJGroupeSprites, _ m_aSprites(i).m_rectPos) End If If m_aSprites(i).m_rectMemPos.Width <> 0 Then _ m_rectMAJGroupeSprites = Rectangle.Union( _ m_rectMAJGroupeSprites, _ m_aSprites(i).m_rectMemPos) m_aSprites(i).m_rectMemPos = m_aSprites(i).m_rectPos If iH + iRayon >= 0 And iH - iRayon <= m_aff.rMaxH And _ iV + iRayon >= 0 And iV - iRayon <= m_aff.rMaxV Then _ m_bToutesPlanetesHorsEcran = False Next i End Sub Private Sub GererChoc(ByVal i%, ByVal j%, _ ByRef rDx As Decimal, ByRef rDy As Decimal, ByRef rDz As Decimal, _ ByRef rNorme As Decimal, ByRef rMinNorme As Decimal, _ ByRef rNorme2 As Decimal, ByRef rFacteurGravtitation As Decimal) ' Gestion des chocs, merci à Alcys : ' CHOCS ENTRE BILLES DE MASSES DIFFERENTES : ' http://www.flashkod.com/article.aspx?Val=118 ' J'ai ajouté une correction de position au point précis du choc ' ainsi qu'une tentative de moyennage des chocs (cf. + loin) Const rAmortissement As Decimal = 1D ' Choc élastique Dim xi, yi, vxi, vyi, ri, mi As Decimal Dim xj, yj, vxj, vyj, rj, mj As Decimal Dim a, b, cc, c As Decimal xi = m_pt(i).rX vxi = m_pt(i).rVx ri = m_pt(i).rM ' Rayon mi = m_pt(i).rM xj = m_pt(j).rX vxj = m_pt(j).rVx rj = m_pt(j).rM mj = m_pt(j).rM ' Distance entre les centres des 2 boules Dim Dxu, Dyu As Decimal ' u pour unitaire : normé Dim rAngleChoc As Decimal ' rAngleChoc : angle de l'axe du choc Dxu = rDx / rNorme If m_b3D Then yi = m_pt(i).rZ vyi = m_pt(i).rVz yj = m_pt(j).rZ vyj = m_pt(j).rVz Dyu = rDz / rNorme Else yi = m_pt(i).rY vyi = m_pt(i).rVy yj = m_pt(j).rY vyj = m_pt(j).rVy Dyu = rDy / rNorme End If rAngleChoc = rLireAngle(Dxu, Dyu) m_pt(i).rAngleChoc = rAngleChoc m_pt(j).rAngleChoc = rAngleChoc Dim rCosAngleChoc, rSinAngleChoc As Decimal rCosAngleChoc = CDec(Math.Cos(rAngleChoc)) rSinAngleChoc = CDec(Math.Sin(rAngleChoc)) ' Distances de correction : ' véritable position du cercle au moment du choc Dim rDistCorrection_i, rDistCorrection_j As Decimal Dim rDistCorrection As Decimal rDistCorrection = rMinNorme - rNorme rDistCorrection_i = rDistCorrection * mi / (mi + mj) rDistCorrection_j = rDistCorrection * mj / (mi + mj) xi -= rDistCorrection_i * rCosAngleChoc yi += rDistCorrection_i * rSinAngleChoc xj += rDistCorrection_j * rCosAngleChoc yj -= rDistCorrection_j * rSinAngleChoc If bDebugChoc Then ' Droite liant les centres 'm_pt(j).rDx = -Dxu * 100 'm_pt(j).rDy = -Dyu * 100 m_pt(j).rDx = -100 * rCosAngleChoc m_pt(j).rDy = -100 * -rSinAngleChoc m_pt(i).rXC = xi m_pt(j).rXC = xj If m_b3D Then m_pt(i).rYC = m_pt(i).rY ' Inchangé m_pt(j).rYC = m_pt(j).rY ' Inchangé m_pt(i).rZC = yi m_pt(j).rZC = yj Else m_pt(i).rYC = yi m_pt(j).rYC = yj m_pt(i).rZC = m_pt(i).rZ ' Inchangé m_pt(j).rZC = m_pt(j).rZ ' Inchangé End If End If a = xi - xj b = yi - yj cc = CDec(Math.Sqrt(a * a + b * b)) c = ri + rj 'dis = a * a + b * b - c * c ' Quantité de mouvement avant et après le choc Dim q1, q2 As Decimal If bDebugChoc Then Dim qx1, qy1 As Decimal qx1 = vxi * mi + vxj * mj qy1 = vyi * mi + vyj * mj q1 = CDec(Math.Sqrt(qx1 * qx1 + qy1 * qy1)) End If Dim nx, ny, tx, ty, rm, e As Decimal Dim xx, yy, xx1, yy1 As Decimal nx = a / cc ny = b / cc tx = -ny ty = nx rm = mj / mi ' Rapport des masses e = rAmortissement xx = (1 - rm * e) / (1 + rm) * (vxi * nx + vyi * ny) + _ rm * (1 + e) / (1 + rm) * (vxj * nx + vyj * ny) yy = vxi * tx + vyi * ty xx1 = (1 + e) / (1 + rm) * (vxi * nx + vyi * ny) + _ (rm - e) / (1 + rm) * (vxj * nx + vyj * ny) yy1 = vxj * tx + vyj * ty vxi = xx * nx + yy * tx vyi = xx * ny + yy * ty vxj = xx1 * nx + yy1 * tx vyj = xx1 * ny + yy1 * ty xi = xj + (c + 1) * nx yi = yj + (c + 1) * ny ' Ce n'est pas juste : par contre l'idée est à tester ' avec les centres de masse oppposés If bChocsMoyennes Then m_pt(i).iNbChocs += 1 m_pt(i).rSomX += xi m_pt(i).rSomY += yi m_pt(i).rSomVX += vxi m_pt(i).rSomVY += vyi m_pt(j).iNbChocs += 1 m_pt(j).rSomX += xj m_pt(j).rSomY += yj m_pt(j).rSomVX += vxj m_pt(j).rSomVY += vyj ' On utilise les positions corrigées pour refaire ' le calcul de l'accélération m_pt(i).rX = xi m_pt(i).rY = yi m_pt(j).rX = xj m_pt(j).rY = yj Else m_pt(i).iNbChocs += 1 ' Pour débug choc m_pt(j).iNbChocs += 1 ' Ne marche pas très bien avec plus de 2 chocs simultanés ' car l'ordre des chocs est subjectif m_pt(i).rX = xi m_pt(i).rVx = vxi m_pt(j).rX = xj m_pt(j).rVx = vxj If m_b3D Then m_pt(i).rZ = yi m_pt(i).rVz = vyi m_pt(j).rZ = yj m_pt(j).rVz = vyj Else m_pt(i).rY = yi m_pt(i).rVy = vyi m_pt(j).rY = yj m_pt(j).rVy = vyj End If End If ' Correction des positions, donc de l'accélarion max. rDx = xj - xi If m_b3D Then 'rDy est inchangé rDz = yj - yi Else rDy = yj - yi 'rDz = 0 inchangé End If rNorme2 = rDx * rDx + rDy * rDy If m_b3D Then rNorme2 = rNorme2 + rDz * rDz rNorme = CDec(Math.Sqrt(rNorme2)) rFacteurGravtitation = 1 / rNorme2 If bDebugChoc Then ' Vérification de la conservation de la quantité de mouvement Dim qx2, qy2 As Decimal qx2 = vxi * mi + vxj * mj qy2 = vyi * mi + vyj * mj q2 = CDec(Math.Sqrt(qx2 * qx2 + qy2 * qy2)) m_frm.Text = "Qté de mvt q2-q1 = " & q2 & " - " & q1 & " = " & q2 - q1 & _ ", Angle Choc = " & rAngleChoc glb_rDateMessageTitre = DateAndTime.Timer End If End Sub Private Sub ProjeterCoord(ByRef iH%, ByRef iV%, ByRef rZoomDA!, _ ByVal rX!, ByVal rY!, ByVal rZ!) rZoomDA = 1 If m_b3D Then 'Or bTestOrb3D Then iH = CInt(0.5 * m_aff.rMaxH + m_aff.rZoom * 0.5 * _ (rX - 0.5 * m_aff.rMaxx + rZ - 0.5 * m_aff.rMaxz)) iV = CInt(0.5 * m_aff.rMaxV - m_aff.rZoom * 0.5 * _ (rY - 0.5 * m_aff.rMaxy + rZ - 0.5 * m_aff.rMaxz)) ' Fixer le diamètre apparent de la planète en fonction ' de sa coordonnée de profondeur Z ' sauf si Choc en 3D : ce n'est pas consistant ' car on ne peut pas déterminer la position du choc If m_bChocs Then Exit Sub Dim rMinZ! = -m_aff.rMaxz Dim rMaxZ! = m_aff.rMaxz rZoomDA = CSng(1 - 0.5 * (rZ - rMinZ) / (rMaxZ - rMinZ)) Else iH = CInt(0.5 * m_aff.rMaxH + _ m_aff.rZoom * (rX - 0.5 * m_aff.rMaxx)) iV = CInt(0.5 * m_aff.rMaxV - _ m_aff.rZoom * (rY - 0.5 * m_aff.rMaxy)) End If End Sub Public Sub Dessiner(ByRef dc As Graphics, ByVal bNePasBufferiserGr As Boolean) ' Dessin général If dc.SmoothingMode <> SmoothingMode.HighSpeed Then _ dc.SmoothingMode = SmoothingMode.HighSpeed ' Fonctionnalité du GDI+ pas encore disp. en .Net : ' InterpolationModeNearestNeighbor is the lowest-quality mode and ' InterpolationModeHighQualityBicubic is the highest-quality mode. 'dc.SetInterpolationMode(InterpolationModeNearestNeighbor) If Not bNePasBufferiserGr Then DessinerFond(dc) Dim i% If m_b3D Then 'Or bTestOrb3D Then If m_iNbPtsTot = 0 Then Exit Sub ' Tri des planètes dans l'ordre des Z décroissants For i = 0 To m_iNbPtsTot - 1 m_aCoordZ(i) = -m_pt(i).rZ m_aIndexCoordZ(i) = i Next i Array.Sort(m_aCoordZ, m_aIndexCoordZ) Dim iIndexZDec% For i = 0 To m_iNbSprites - 1 iIndexZDec = m_aIndexCoordZ(i) ' On ne peut voir les traces que si l'on ne bufférise pas m_aSprites(iIndexZDec).m_bLaisserTraceCercleGris = bNePasBufferiserGr m_aSprites(iIndexZDec).AnimerSpin() m_aSprites(iIndexZDec).Dessiner(dc) If bDebugRectMAJ Then _ dc.DrawRectangle(New Pen(Color.Blue, 2), _ m_aSprites(i).m_rectMAJ) If m_pt(i).iNbChocs > 0 And bDebugChoc Then Dim iH1%, iH2%, iV1%, iV2%, rZoomDA! ProjeterCoord(iH1, iV1, rZoomDA, _ m_pt(i).rX, m_pt(i).rY, m_pt(i).rZ) ProjeterCoord(iH2, iV2, rZoomDA, _ m_pt(i).rX + m_pt(i).rDx, m_pt(i).rY, _ m_pt(i).rZ + m_pt(i).rDy) dc.DrawLine(New Pen(Color.Blue, 2), iH1, iV1, iH2, iV2) Dim iH%, iV% ProjeterCoord(iH, iV, rZoomDA, m_pt(i).rXC, m_pt(i).rYC, m_pt(i).rZC) Dim iRayon% = CInt(m_pt(i).rM * m_aff.rZoom * 0.5 * rZoomDA) Dim iDiam% = 2 * iRayon dc.DrawEllipse(New Pen(Color.Blue, 2), _ iH - iRayon, iV - iRayon, iDiam, iDiam) End If If bDebugPosEtVitInitiales Then Dim iH1%, iH2%, iV1%, iV2%, rZoomDA! ProjeterCoord(iH1, iV1, rZoomDA, _ m_pt(i).rX, m_pt(i).rY, m_pt(i).rZ) ProjeterCoord(iH2, iV2, rZoomDA, _ m_pt(i).rX + m_pt(i).rVx * 20, _ m_pt(i).rY + m_pt(i).rVy * 20, _ m_pt(i).rZ + m_pt(i).rVz * 20) dc.DrawLine(New Pen(Color.Yellow, 2), iH1, iV1, iH2, iV2) End If Next i Else ' 2D For i = 0 To m_iNbSprites - 1 'm_aSprites(i).m_bCercle = m_prm.bCercle m_aSprites(i).m_bLaisserTraceCercleGris = bNePasBufferiserGr m_aSprites(i).AnimerSpin() m_aSprites(i).Dessiner(dc) If bDebugRectMAJ Then _ dc.DrawRectangle(New Pen(Color.Blue, 2), _ m_aSprites(i).m_rectMAJ) If m_pt(i).iNbChocs > 0 And bDebugChoc Then Dim iH1%, iH2%, iV1%, iV2%, rZoomDA! ProjeterCoord(iH1, iV1, rZoomDA, _ m_pt(i).rX, m_pt(i).rY, m_pt(i).rZ) ProjeterCoord(iH2, iV2, rZoomDA, _ m_pt(i).rX + m_pt(i).rDx, _ m_pt(i).rY + m_pt(i).rDy, m_pt(i).rZ) dc.DrawLine(New Pen(Color.Blue, 2), iH1, iV1, iH2, iV2) Dim iH%, iV% ProjeterCoord(iH, iV, rZoomDA, _ m_pt(i).rXC, m_pt(i).rYC, m_pt(i).rZC) Dim iRayon% = CInt(m_pt(i).rM * m_aff.rZoom) Dim iDiam% = 2 * iRayon dc.DrawEllipse(New Pen(Color.Blue, 2), _ iH - iRayon, iV - iRayon, iDiam, iDiam) End If If bDebugPosEtVitInitiales Then Dim iH1%, iH2%, iV1%, iV2%, rZoomDA! ProjeterCoord(iH1, iV1, rZoomDA, _ m_pt(i).rX, m_pt(i).rY, m_pt(i).rZ) ProjeterCoord(iH2, iV2, rZoomDA, _ m_pt(i).rX + m_pt(i).rVx * 20, _ m_pt(i).rY + m_pt(i).rVy * 20, m_pt(i).rZ) dc.DrawLine(New Pen(Color.Yellow, 2), iH1, iV1, iH2, iV2) End If Next i End If If bDebugRectMAJ Then _ dc.DrawRectangle(New Pen(Color.Blue, 2), m_rectMAJGroupeSprites) End Sub Public Sub DessinerFond(ByRef dc As Graphics) If Not m_prm.bFondUni And Not m_prm.bFondDegrade And Not m_bImageFondTrouve Then Exit Sub ' Ne pas utiliser les variables images avant leur initialisation If Not m_bImgFondInitialisee Then Exit Sub Dim rectFondLocal As Rectangle rectFondLocal = m_rectEcran If m_prm.bFondUni Then dc.Clear(Color.Navy) ' Créer un fond avec un dégradé de couleur If m_prm.bFondDegrade Then _ dc.FillRectangle(m_lgbFondDegrade, rectFondLocal) If Not m_bImageFondTrouve Then Exit Sub If m_prm.bNePasAgrandirImgFond Then ' Ne pas agrandir pour optimiser la vitesse dc.DrawImage(m_imgFond, 0, 0, m_imgFond.Width, m_imgFond.Height) Exit Sub End If If m_prm.bNePasDecentrerImgFond Then ' Ok pour le clipping, mais ne marche pas avec le décentrage Dim rectDest As Rectangle = rectFondLocal Dim rectSrc As Rectangle = rectFondLocal dc.DrawImage(m_imgFond, rectDest, rectSrc, GraphicsUnit.Pixel) Exit Sub End If ' Ok avec le décentrage mais ne marche pas avec le clipping ' (les rectangles sont plus compliqués à calculer dans ce cas) 'dc.DrawImage(m_imgFond, m_rectEcran, m_rectImgFond, GraphicsUnit.Pixel) ' Sinon, tracé de toute l'image de fond sans optimisation ' Pb : Ratio H/V non préservé 'dc.DrawImage(m_imgFond, 0, 0, m_rectEcran.Width, m_rectEcran.Height) ' Ok : pas d'optimisation, mais le décentrage marche et ' le ration H/V est préservé : cf. calcul de m_rectImgFond dc.DrawImage(m_imgFond, m_rectImgFond) End Sub Public Sub InitialiserImageFond(ByVal szClientSize As Size) m_bImageFondTrouve = False If Not m_prm.bImageFond Then GoTo Fin Dim sRepertoire$ = Application.StartupPath Dim sFichierImageFond$ 'sFichierImagePlanete$, ' Recherche des fichiers images Dim asFichiersImg() As String = Nothing Dim iNbFichiersImg% = 0 Dim sFiltre$ = m_prm.sFiltreFichiersImgFond Dim sRepertoireImgFond$ = sRepertoire If sFiltre = "" Then _ m_bImageFondTrouve = False : GoTo Fin Dim iPos% = sFiltre.IndexOf("\") If iPos > 0 Then sRepertoireImgFond = sRepertoire & "\" & _ sFiltre.Substring(0, iPos) sFiltre = sFiltre.Substring(iPos + 1) End If If Not bDossierExiste(sRepertoireImgFond) Then GoTo Fin Try asFichiersImg = Directory.GetFiles(sRepertoireImgFond, sFiltre) ' "space_*.jpg") iNbFichiersImg = asFichiersImg.Length Catch iNbFichiersImg = 0 End Try If iNbFichiersImg = 0 Then _ m_bImageFondTrouve = False : GoTo Fin m_bImageFondTrouve = True Dim iNumImg% = CInt(Rnd() * iNbFichiersImg) If iNumImg >= iNbFichiersImg Then iNumImg = iNumImg - 1 sFichierImageFond = asFichiersImg(iNumImg) 'MsgBox("Fichier choisi : " & sFichierImageFond) If Not m_imgFond Is Nothing Then m_imgFond.Dispose() 'm_imgFond = Image.FromFile(sFichierImageFond) m_imgFond = CType(Image.FromFile(sFichierImageFond), Bitmap) If m_prm.bNePasDecentrerImgFond Then m_rectImgFond = New Rectangle(0, 0, m_imgFond.Width, m_imgFond.Height) Else ' Décentrage de l'image à gauche et en Haut, ' ainsi qu'à droite et en bas, ' ceci afin de ne jamais afficher une image au même endroit ' (un écran de veille sert justement à éviter cela) m_rectEcran = New Rectangle(0, 0, _ szClientSize.Width, szClientSize.Height) Dim rZoomV! = CSng(m_rectEcran.Height / m_imgFond.Height) Dim rZoomH! = CSng(m_rectEcran.Width / m_imgFond.Width) Dim rMaxZoom! = rZoomV If rZoomH > rMaxZoom Then rMaxZoom = rZoomH Dim rAg! = 1 + 1 * Rnd() Dim rDec! = Rnd() 'rAg = 1 : rDec = 0 : Centrée 'rAg = 2 : rDec = 1 : Quart GH 'rAg = 1 : rDec = 1 : Quart DB Dim rZoomDeb! = rMaxZoom * rDec Dim rZoomFin! = rMaxZoom * (rAg + rDec) m_rectImgFond = New Rectangle( _ CInt(-m_imgFond.Width * rZoomDeb), _ CInt(-m_imgFond.Height * rZoomDeb), _ CInt(m_imgFond.Width * rZoomFin), _ CInt(m_imgFond.Height * rZoomFin)) End If Fin: m_bImgFondInitialisee = True End Sub Public Sub InitialiserTailleEcran(ByVal szClientSize As Size) m_rectEcran = New Rectangle(0, 0, _ szClientSize.Width, szClientSize.Height) m_szTailleFenetre = szClientSize m_lgbFondDegrade = New LinearGradientBrush(m_rectEcran, _ Color.Red, Color.Yellow, LinearGradientMode.BackwardDiagonal) End Sub #End Region End Class clsSprite.vb Imports System.IO ' Pour Path, FileInfo Public Class Sprite ' Petite image en mouvement Public m_bCercle As Boolean = False Public m_bLaisserTraceCercleGris As Boolean = False Private Const m_bTransparenceImg As Boolean = True Private Const m_bRotationImg As Boolean = True Public m_rectMAJ, m_rectPos, m_rectMemPos As Rectangle Private m_szTailleImg As Size Private m_iGdCoteImg% Private m_rZoomImg! = 1 Public m_bPositionInitialisee As Boolean = False Public m_ptPos As New Point(0, 0) Private m_ptMemPos As New Point(0, 0) Private m_iRayon%, m_iMemRayon%, m_iMemDiam% ' Tracé d'un cercle Private m_iDiametreCercle% = 100 Private m_iDiametreApparentCercle% Private Const m_iLargPinceauCercle% = 2 ' Couleur du cercle Private m_penCercle As New Pen(Color.Cyan, m_iLargPinceauCercle) ' Laisser une trace du cercle Private m_penCercleGris As New Pen(Color.DarkGray, m_iLargPinceauCercle) ' Pour avoir la méthode MakeTransparent (non disp. dans la classe Image) Private m_imgSprite As Bitmap Private m_rAngleRotImg! ' Variation de l'angle de rotation de l'image Private m_rDeltaAngleRotImg! = 2 Private m_graphicsContainer As Drawing2D.GraphicsContainer ' Constructeur de la classe Public Sub New(ByVal iDiametre%, ByVal rDeltaAngleRotImg0!) m_bPositionInitialisee = False m_ptPos.X = 0 : m_ptPos.Y = 0 m_iDiametreCercle = iDiametre m_iDiametreApparentCercle = m_iDiametreCercle m_iRayon = iDiametre \ 2 m_rZoomImg = iDiametre m_rDeltaAngleRotImg = rDeltaAngleRotImg0 m_iMemRayon = 0 End Sub Public Sub InitialiserImage(ByVal sCheminImage$) m_bPositionInitialisee = False If Not m_bCercle Then m_imgSprite = CType(Image.FromFile(sCheminImage), Bitmap) m_iGdCoteImg = m_imgSprite.Width If m_imgSprite.Height > m_iGdCoteImg Then _ m_iGdCoteImg = m_imgSprite.Height CalculerTailleImg(m_rZoomImg) ' Définir la couleur de transparence du Bitmap If m_bTransparenceImg Then _ m_imgSprite.MakeTransparent(m_imgSprite.GetPixel(1, 1)) End If End Sub Private Sub CalculerTailleImg(ByVal rZoom!) m_szTailleImg.Width = CInt(m_imgSprite.Width * _ rZoom / m_iGdCoteImg - 1) m_szTailleImg.Height = CInt(m_imgSprite.Height * _ rZoom / m_iGdCoteImg - 1) m_iRayon = m_szTailleImg.Width \ 2 If 0.5 * m_szTailleImg.Height > m_iRayon Then _ m_iRayon = m_szTailleImg.Height \ 2 End Sub Public Sub AnimerSpin() m_rAngleRotImg = m_rAngleRotImg + m_rDeltaAngleRotImg End Sub Public Sub DiametreApparent(ByVal rZoomPosition!, _ ByVal iRayonMinAffichage%) If m_bCercle Or m_imgSprite Is Nothing Then If m_bPositionInitialisee Then m_iMemRayon = m_iRayon m_iMemDiam = m_iDiametreApparentCercle End If m_iDiametreApparentCercle = CInt(m_iDiametreCercle * rZoomPosition) m_iRayon = m_iDiametreApparentCercle \ 2 Else Dim rZoomImg0! = m_rZoomImg * rZoomPosition CalculerTailleImg(rZoomImg0) End If If m_iRayon < iRayonMinAffichage Then _ m_iRayon = iRayonMinAffichage If m_iDiametreApparentCercle < 2 * iRayonMinAffichage Then _ m_iDiametreApparentCercle = 2 * iRayonMinAffichage End Sub Public Sub FixerPosition(ByVal ptPosition As Point) m_ptMemPos = m_ptPos m_ptPos = ptPosition If Not m_bPositionInitialisee Then m_ptMemPos = m_ptPos End Sub Public Sub Dessiner(ByRef dc As Graphics) If Not m_bPositionInitialisee Then Exit Sub If m_bCercle Or m_imgSprite Is Nothing Then Dim iRayon% = m_iMemRayon - m_iLargPinceauCercle \ 2 Dim iDiam% = m_iMemDiam - m_iLargPinceauCercle - 1 ' Effacer la position précédente du cercle If m_bLaisserTraceCercleGris And m_iMemRayon <> 0 Then _ dc.DrawEllipse(m_penCercleGris, _ m_ptMemPos.X - iRayon, m_ptMemPos.Y - iRayon, _ iDiam, iDiam) iRayon = m_iRayon - m_iLargPinceauCercle \ 2 iDiam = m_iDiametreApparentCercle - m_iLargPinceauCercle - 1 dc.DrawEllipse(m_penCercle, _ m_ptPos.X - iRayon, m_ptPos.Y - iRayon, _ iDiam, iDiam) Exit Sub End If If m_bRotationImg Then ' Déplacement des coordonnées au centre de l'image en rotation dc.TranslateTransform(m_ptPos.X, m_ptPos.Y) ' Définition d'un "container" de transformation m_graphicsContainer = dc.BeginContainer() dc.RotateTransform(m_rAngleRotImg) dc.DrawImage(m_imgSprite, _ -CInt(m_szTailleImg.Width / 2), _ -CInt(m_szTailleImg.Height / 2), _ m_szTailleImg.Width, m_szTailleImg.Height) dc.EndContainer(m_graphicsContainer) ' Restauration des coordonnées normales dc.TranslateTransform(-m_ptPos.X, -m_ptPos.Y) Exit Sub End If dc.DrawImage(m_imgSprite, _ m_ptPos.X - m_iRayon, m_ptPos.Y - m_iRayon, _ m_szTailleImg.Width, m_szTailleImg.Height) End Sub End Class modConst.vb Module modConst Public Const m_bDebugModeEcranVeille As Boolean = False ' Nom des paramètres du fichier de configuration Public Const sFiltreFichiersImgFond$ = "FiltreFichiersImgFond" Public Const sFiltreFichiersImgSprite$ = "FiltreFichiersImgSprite" Public Const sTxtBanniere$ = "TxtBanniere" 'Public Const sbAffichageBanniere$ = "bAffichageBanniere" Public Const iDegreRacineDef% = 2 Public Const iDegreRacineMaxDef% = 4 Public Const sDegreRacine$ = "DegreRacine" Public Const sDegreRacine_bRnd$ = "DegreRacine_bRnd" Public Const sDegreRacineRndMax$ = "DegreRacineRndMax" Public Const sDegreRacine2$ = "DegreRacine2" Public Const sDegreRacine2_bRnd$ = "DegreRacine2_bRnd" Public Const sDegreRacine2RndMax$ = "DegreRacine2RndMax" Public Const sbMasseSym$ = "bMasseSym" Public Const sbMasseSym_bRnd$ = "bMasseSym_bRnd" Public Const sb3D$ = "b3D" Public Const sb3D_bRnd$ = "b3D_bRnd" Public Const sb3D_bPlanetesAxeV$ = "b3D_bPlanetesAxeV" Public Const sb3D_bPlanetesAxeV_bRnd$ = "b3D_bPlanetesAxeV_bRnd" Public Const sb3D_iNbPlanetesMaxAxeV$ = "b3D_iNbPlanetesMaxAxeV" Public Const sbChocs$ = "bChocs" Public Const sbChocs_bRnd$ = "bChocs_bRnd" 'Public Const sbCercle$ = "bCercle" Public Const iForceGravitationDef% = 100 Public Const sForceGravitation$ = "ForceGravitation" Public Const iDelaiMiliSecDef% = 0 Public Const sDelaiMiliSec$ = "DelaiMiliSec" Public Const iTempsMaxScenarioSecDef% = 180 Public Const sTempsMaxScenarioSec$ = "TempsMaxScenarioSec" 'Public Const sbImageFond$ = "bImageFond" Public Const sbMAJToutLEcran$ = "bMAJToutLEcran" Public Const sbMAJGroupeSprites$ = "bMAJGroupeSprites" Public Const sbNePasInitFond$ = "bNePasInitFond" Public Const sbNePasBufferiserGr$ = "bNePasBufferiserGr" Public Const sbFondUni$ = "bFondUni" Public Const sbFondDegrade$ = "bFondDegrade" End Module modDepart.vb Imports System.IO ' Pour Path, FileInfo Module modDepart #If DEBUG Then Public Const bDebug As Boolean = True 'Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False 'Public Const bRelease As Boolean = True #End If Public ReadOnly sNomAppli$ = My.Application.Info.Title Public ReadOnly sTitreMsg$ = sNomAppli Private Const sDateVersionGravity$ = "11/11/2012" Public Const sDateVersionAppli$ = sDateVersionGravity Public ReadOnly sVersionAppli$ = _ My.Application.Info.Version.Major & "." & _ My.Application.Info.Version.Minor & _ My.Application.Info.Version.Build Public ReadOnly m_sTitreApplication$ = sNomAppli '"Gravity.Net Screen Saver" ' Variables globales : à utiliser avec modération Public glb_bModeConfiguration As Boolean ' Pas d'autre choix ici ! Public glb_rDateMessageTitre As Double ' Pour debugger seulement Public Sub Main() If bDebug Then Depart() : Exit Sub ' Attention : En mode Release il faut un Try Catch ici ' car sinon il n'y a pas de gestion d'erreur ! ' (.Net renvoie un message d'erreur équivalent ' à un plantage complet sans explication) Try Depart() Catch ex As Exception AfficherMsgErreur2(ex, "Main " & sTitreMsg) End Try End Sub Private Sub Depart() If bAppliDejaOuverte() Then Exit Sub 'Dim asArgs$() = asArgLigneCmd(sArg0) ' Vérification de l'existence du fichier de configuration : ' son nom est toujours basé sur le nom de l'assemblage, ' mais comme celui-ci change lorsque l'écran de veille est ' installé sous Windows 2000 (il est converti en nom DOS 8.3), ' ça complique un peu ! Dim sRepertoire$ = Application.StartupPath ' Solution + simple Dim sCheminExe$ = Application.ExecutablePath ' = Asm.Location Dim sExtension$ = Path.GetExtension(sCheminExe) sExtension = sExtension.ToLower() Dim sNomAppli$ = Path.GetFileNameWithoutExtension(sCheminExe) Dim sFichierConfig$ = sRepertoire & "\" & sNomAppli & _ sExtension & ".config" If Not File.Exists(sFichierConfig) And sExtension = ".scr" Then If m_bDebugModeEcranVeille Then _ MsgBox("Le fichier " & sFichierConfig & vbCrLf & _ "n'existe pas", _ MsgBoxStyle.OkOnly Or MsgBoxStyle.Information, _ m_sTitreApplication) ' Si l'extension est .scr et que le fichier .exe.config ' existe, on le renomme en .scr.config Dim sFichierConfigTrouve$ = "" Dim sFichierConfigCherche$ sFichierConfigCherche = sRepertoire & "\" & sNomAppli & ".exe.config" If File.Exists(sFichierConfigCherche) Then _ sFichierConfigTrouve = sFichierConfigCherche : GoTo Suite sFichierConfigCherche = sRepertoire & "\Gravity2.scr.config" If File.Exists(sFichierConfigCherche) Then _ sFichierConfigTrouve = sFichierConfigCherche : GoTo Suite sFichierConfigCherche = sRepertoire & "\Gravity2.exe.config" If File.Exists(sFichierConfigCherche) Then _ sFichierConfigTrouve = sFichierConfigCherche ': GoTo Suite ' Lorsque l'écran de veille est installé, le nom ' de l'assemblage est tronqué en nom DOS 8.3 !!! ' au lieu de GravityNet.scr mieux vaut donc Gravity2.scr 'sFichierConfigCherche = sRepertoire & "\GRAVIT~1.scr.config" 'If File.Exists(sFichierConfigCherche) Then _ ' sFichierConfigTrouve = sFichierConfigCherche : GoTo Suite Suite: If sFichierConfigTrouve <> "" Then Dim oFileInfo As New FileInfo(sFichierConfigTrouve) oFileInfo.MoveTo(sFichierConfig) If m_bDebugModeEcranVeille Then _ MsgBox("Le fichier " & sFichierConfigTrouve & vbCrLf & _ "a été renommé en " & sFichierConfig, _ MsgBoxStyle.OkOnly Or MsgBoxStyle.Information, _ m_sTitreApplication) End If End If Dim sSeparators$ = " " Dim sCommands$ = Microsoft.VisualBasic.Command() Dim asArgs$() = sCommands.Split(sSeparators.ToCharArray) Dim sArgument$ = "" ' Extraire l'option passée en argument de la ligne de commande If asArgs.Length > 0 Then sArgument = asArgs(0) ' Un handle est parfois passé après l'option, ' par ex.: /C:5833086 d'où le Left de 2 If sArgument <> "" Then _ sArgument = sArgument.Substring(0, 2) ' Autre solution : 'sArgument = Microsoft.VisualBasic.Left(sArgument, 2) ' Les arguments sont parfois en minuscules, ' parfois en majuscules sArgument = sArgument.ToUpper() 'sArgument = UCase(sArgument) ' Autre solution ' Lancement depuis VisualSudio.Net : pas d'argument ' Le menu Configurer avec le bouton droit de la souris ' sur le fichier .scr ne renvoie pas d'argument non plus ' Dans ce cas, on choisit donc /C sauf pour debugger ' le mode écran de veille (pas le mode configuration) If Not m_bDebugModeEcranVeille Then _ If sArgument = "" Then sArgument = "/C" ' Autre solution : passer "/C" dans les arguments ' de VisualSudio.Net en mode Release seulement ' mais cela ne gère pas le menu Configurer avec le ' bouton droit de la souris sur le fichier .scr 'MsgBox("Argument : [" & sArgument & "]") glb_bModeConfiguration = False ' Options des Propriétés de l'Affichage, onglet "Ecran de veille" If sArgument = "/C" Then ' Bouton "Paramètre..." glb_bModeConfiguration = True ' Il n'y a plus de Form spéciale pour la configuration ElseIf sArgument = "/S" Then ' Bouton "Aperçu" et aussi avec le bouton droit ' de la souris : Menu Aperçu '//Start the screen saver normally. ElseIf sArgument = "/A" Then ' Case à cocher "Protégé par mot de passe" ' La gestion des mots de passe pour les écrans de veille ' marchent aussi pour Windows 2000 mais pas de la même façon : ' on ne passe pas par l'écran de veille et le mot de passe ' ne doit pas être nul '//Display the password dialog '"Passwords are not available for this screen saver" MsgBox("Cet écran de veille ne gère pas les mots de passe", _ MsgBoxStyle.OkOnly Or MsgBoxStyle.Information, _ m_sTitreApplication) Exit Sub ElseIf sArgument = "/P" Then ' Mini-aperçu dans l'onglet "Ecran de veille" ' Non géré pour le moment, car il faut sous-classer la ' fenêtre des propriétés de l'affichage, voir en VB6 : ' GRAVITY SCREEN SAVER : UN ÉCRAN DE VEILLE CHAOTIQUE ' http://www.vbfrance.com/code.aspx?ID=1743 Exit Sub End If ' Lancer l'écran de veille pour tous les autres arguments '//For any other args --> start 'Dim frm As New FrmGravityNet() 'Application.Run(frm) 'clsUtil.JolieTransitionTaDaaa(frm) Application.Run(New frmGravityNet()) End Sub End Module modUtil.vb Module modUtil ' Attribut pour éviter que l'IDE s'interrompt en cas d'exception '<System.Diagnostics.DebuggerStepThrough()> _ Public Function iConv%(ByVal sVal$, Optional ByVal iValDef% = -1) If String.IsNullOrEmpty(sVal) Then iConv = iValDef : Exit Function Try iConv = CInt(sVal) Catch iConv = iValDef End Try End Function Public Function bDossierExiste(ByVal sCheminDossier$, _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un dossier correspondant au filtre sFiltre est trouvé 'Dim di As New IO.DirectoryInfo(sCheminDossier) 'bDossierExiste = di.Exists() bDossierExiste = IO.Directory.Exists(sCheminDossier) If Not bDossierExiste And bPrompt Then _ MsgBox("Impossible de trouver le dossier :" & vbLf & sCheminDossier, _ MsgBoxStyle.Critical, sTitreMsg & " - Dossier introuvable") End Function Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _ Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(ByVal sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub Public Function bAppliDejaOuverte(Optional ByVal bMemeExe As Boolean = True) As Boolean ' Détecter si l'application est déja lancée : ' - depuis n'importe quelle copie de l'exécutable (bMemeExe=False), ou bien seulement : ' - depuis le même emplacement du fichier exécutable sur le disque dur (bMemeExe=True : par défaut) Dim sExeProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.ModuleName Dim sNomProcessAct$ = IO.Path.GetFileNameWithoutExtension(sExeProcessAct) If Not bMemeExe Then ' Détecter si l'application est déja lancée depuis n'importe quel exe If Process.GetProcessesByName(sNomProcessAct).Length > 1 Then _ bAppliDejaOuverte = True Exit Function End If ' Détecter si l'application est déja lancée depuis le même exe Dim sCheminProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.FileName Dim aProcessAct As Diagnostics.Process() = Process.GetProcessesByName(sNomProcessAct) Dim processAct As Diagnostics.Process Dim iNbApplis% = 0 For Each processAct In aProcessAct Dim sCheminExe$ = processAct.MainModule.FileName If sCheminExe = sCheminProcessAct Then iNbApplis += 1 Next If iNbApplis > 1 Then bAppliDejaOuverte = True End Function End Module