'//////////////////////////////////// ((((((())))))) \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ' ScienSolar v. 1.51 MAIN MODULE 1. Updated 09-2024 ' ScienSolar package for modeling physics and mathematics in MS Excel (tested on MS Excel 2013-2019 for Windows and Mac). ' The package is distributed in five text files and must be integrated into an Excel file. ' This package is protected by copyright law. © PhD Ariel R. Becerra B., 2022. ' By downloading the package you agree to the terms and conditions under the license GNU General Public License v.3.0 (https://www.gnu.org/licenses/gpl-3.0.html). ' You may use the ScienSolar package for free only under the terms of this license. ' For modeling, you do not need to program in VBA, it is enough with the Excel functions. ' TO MAKE IT WORK: ' 1. In a new Excel file, open the VBA Editor (Alt + F11 in Windows or Fn + Option + F11 in macOS). ' 2. In the VBAProject insert modules. Add six modules. ' 3. Copy and paste all the ScienSolar package code into the modules (the content of each file into a different module). ' 4. Add a button in a new sheet. To do this, in Excel, go to the DEVELOPER tab and in the Controls group click Insert a Button. ' 5. Click a location on the worksheet to place the button. ' 6. Assign the NewSheet macro to the button. ' 7. Click the button to start a new project. ' 8. To load a sample project, select it from the list and click the +Vector button. ' 9. Save the file in your desired folder, save it as Macro-Enabled Workbook (*. xlsm). ' 10. Some projects use objects (3D objects, formulas) found in the 3D Models spreadsheet. This spreadsheet can be downloaded and moved to this workbook (if not present). ' 11.Visit www.sciensolar.com to download updates and documentation. '//////////////////////////////////// ((((((())))))) \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ ''Set variables Dim Y_abs As Single ' Excel horizontal point of origin of XYZ Dim Z_abs As Single ' Excel vertical point of origin of XYZ Dim A As Double ' Rotation angle about X Dim B As Double ' Rotation angle about Y Dim C As Double ' Rotation angle about Z Dim L As Double ' Axis lenght Dim Lx As Double 'The x component of a vector (that is, the value in cell A12 for the first vector) Dim Ly As Double 'The y component of a vector (that is, the value in cell B12 for the first vector) Dim Lz As Double 'The z component of a vector (that is, the value in cell C12 for the first vector) Dim Lox As Double 'The initial position in x of a vector (that is, the value in cell A10 for the first vector) Dim Loy As Double 'The initial position in y of a vector (that is, the value in cell A10 for the first vector) Dim Loz As Double 'The initial position in z of a vector (that is, the value in cell A10 for the first vector) Dim i As Double 'updated 07-2024 'Definition of general units of measurement Dim PatronW As Double ' The width of a cell will be taken as measure patron for other objects Dim PatronH As Double ' The height of a cell will be taken as measure patron for other objects Dim PatronT As Double ' The top of a cell will be taken as measure patron for other objects Sub Init() '© 2022 A Becerra. ScienSolar.com ' Procedure aim: Create a new sheet with the ScienSolar interface. ' Segment Init-01. Command to avoid updating the sheet during execution. Application.ScreenUpdating = False ActiveWindow.DisplayGridlines = False 'Segment Init-02. Define coordinates relative to INICIO. The variables m and n relative to the initial position of the control board are introduced. Dim fila As Range ' This name will be a reference in the CONFIG sheet Dim m As Integer ' This is a reference number for starting point of rows in ScienSolar Dim n As Integer ' This is a reference number for starting point of columns in ScienSolar Set fila = ActiveSheet.Cells.Find(What:="INICIO") m = fila.Offset(1, 0).Row n = fila.Offset(1, 1).Column 'Segment Init-03. Define coordinates relative to LANGUAGE. Added 03.2024. Set fila = Sheets("CONFIG").Cells.Find(What:="(LENGUAJE)") If ActiveSheet.Cells(m - 1, n + 18).Value = "" Then ActiveSheet.Cells(m - 1, n + 18).Value = Sheets("CONFIG").Cells(fila.Row + 1, fila.Column).Value End If Sheets("CONFIG").Cells(fila.Row + 1, fila.Column).Value = ActiveSheet.Cells(m - 1, n + 18).Value Set fila = Nothing 'Segment Init-04. Clean the worksheet Cells.Delete DeleteObjects (8) DeleteObjects (17) 'Segment Init-05. Establish a general unit of length measurement within the sheet: PatronW = ActiveSheet.Cells(1, 1).Width PatronH = ActiveSheet.Cells(1, 2).Height 'Segment Init-06. Vector cell parameters and project title: Cells(m + 1, n + 1).Select With Selection .Value = "A" .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With 'Segment Init-07. Add a project list: Dim lista As Range Set lista = Sheets("CONFIG").Cells.Find(What:="(LISTA)") m2 = lista.Offset(2, 0).Row n2 = lista.Column Set lista = Nothing ActiveSheet.DropDowns.Add(PatronW * (n + 14), PatronH * (m + 1), PatronW * 3, PatronH).Select With Selection .name = "List1" .LinkedCell = Cells(m + 1, n - 1).Address .DropDownLines = 20 .Display3DShading = True .AddItem " " ' valor 1 i = 0 Do While Sheets("CONFIG").Cells(m2 + i, n2) <> "" .AddItem Sheets("CONFIG").Cells(m2 + i, n2 + 1).Value & " " & Sheets("CONFIG").Cells(m2 + i, n2).Value i = i + 1 Loop End With 'Segment Init-08. Add a language list. 03.2024: Set lista = Sheets("CONFIG").Cells.Find(What:="LENGUAJE") m2 = lista.Offset(2, 0).Row n2 = lista.Column Set lista = Nothing ActiveSheet.DropDowns.Add(PatronW * (n + 17), PatronH * (m - 2), PatronW + 15, PatronH + 3).Select With Selection .name = "LangList" .LinkedCell = Cells(m - 1, n + 18).Address .DropDownLines = 20 .Display3DShading = True i = 0 Do While Sheets("CONFIG").Cells(m2 + i, n2) <> "" .AddItem Sheets("CONFIG").Cells(m2 + i, n2).Value i = i + 1 Loop End With ActiveSheet.Cells(m - 1, n + 18).Value = Sheets("CONFIG").Cells(m2 - 1, n2).Value 'Segment Init-09. Add buttons to modify the view angles of the coordinate system: ActiveSheet.Spinners.Add(PatronW * (n + 4), PatronH * (m), PatronW / 4, PatronH).Select With Selection .Value = 0 .SmallChange = 1 .LinkedCell = Cells(m + 1, n + 5).Address .Display3DShading = True End With Selection.OnAction = "Rotate" ActiveSheet.Spinners.Add(PatronW * (n + 4), PatronH * (m + 1), PatronW / 4, PatronH).Select With Selection .Value = 0 .SmallChange = 1 .LinkedCell = Cells(m + 2, n + 5).Address .Display3DShading = True End With Selection.OnAction = "Rotate" ActiveSheet.Spinners.Add(PatronW * (n + 4), PatronH * (m + 2), PatronW / 4, PatronH).Select With Selection .Value = 0 .SmallChange = 1 .LinkedCell = Cells(m + 3, n + 5).Address .Display3DShading = True End With Selection.OnAction = "Rotate" 'Segment Init-10. Button to hide/show the control panel and help ActiveSheet.Buttons.Add(PatronW * (n + 15 / 2), PatronH * (m - 2), PatronW * 0.5, PatronH).Select Selection.name = Cells(m - 2, n - 1).Column Selection.OnAction = "ShowHideMenu" Selection.Characters.Text = ChrW(9664) With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 .ColorIndex = 1 End With ActiveSheet.Buttons.Add(PatronW * (n + 17 / 2), PatronH * (m - 2), PatronW / 2, PatronH).Select Selection.OnAction = "HELP" Selection.Characters.Text = " ? " With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 15 .ColorIndex = 1 End With 'Segment Init-11. General control panel buttons. See Characters.Text to identify the button. ActiveSheet.Buttons.Add(PatronW * (n + 2), PatronH * (m + 1), PatronW / 2, PatronH).Select Selection.name = "AutoSc" Selection.OnAction = "AutoScale" Selection.Characters.Text = "Auto" With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n - 1), PatronH * (m - 1), PatronW / 2, PatronH).Select Selection.name = "AddButt" Selection.OnAction = "AddObject" Selection.Characters.Text = "+ OBJ" With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n), PatronH * (m - 1), PatronW / 2, PatronH).Select Selection.name = "DelButt" Selection.OnAction = "AddObject" Selection.Characters.Text = "- OBJ" With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7 / 2), PatronH * (m - 1), PatronW / 2, PatronH).Select Selection.OnAction = "rotate" Selection.Characters.Text = "" With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 4), PatronH * (m - 2), PatronW / 2, PatronH).Select Selection.OnAction = "rotate_XZY" Selection.Characters.Text = "XYZ" With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 4), PatronH * (m - 1), PatronW / 2, PatronH).Select Selection.OnAction = "rotate_XY" Selection.Characters.Text = "XY" With Selection.Characters(Start:=1, Length:=2).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 9 / 2), PatronH * (m - 1), PatronW / 2, PatronH).Select Selection.OnAction = "rotate_XZ" Selection.Characters.Text = "XZ" With Selection.Characters(Start:=1, Length:=2).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 9 / 2), PatronH * (m - 2), PatronW / 2, PatronH).Select Selection.OnAction = "rotate_YZ" Selection.Characters.Text = "YZ" With Selection.Characters(Start:=1, Length:=2).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7 / 2), PatronH * (m), PatronW / 2, PatronH).Select Selection.OnAction = "rotate_A" Selection.Characters.Text = ChrW(8811) & " A" With Selection.Characters(Start:=1, Length:=1).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7 / 2), PatronH * (m + 1), PatronW / 2, PatronH).Select Selection.OnAction = "rotate_B" Selection.Characters.Text = ChrW(8811) & " B" With Selection.Characters(Start:=1, Length:=1).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7 / 2), PatronH * (m + 2), PatronW / 2, PatronH).Select Selection.OnAction = "rotate_C" Selection.Characters.Text = ChrW(8811) & " C" With Selection.Characters(Start:=1, Length:=1).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 16), PatronH * (m - 2), PatronW, PatronH + 3).Select Selection.OnAction = "CleanSheet" Selection.Characters.Text = Sheets("CONFIG").Range("B2").Value '"Restablecer" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 13), PatronH * (m + 1), PatronW, PatronH).Select Selection.OnAction = "NewSheet" Selection.Characters.Text = Sheets("CONFIG").Range("C2").Value With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7 / 2), PatronH * (m - 2), PatronW / 2, PatronH).Select Selection.OnAction = "XYZNeg" Selection.Characters.Text = "-xyz" With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 3), PatronH * (m - 2), PatronW * 0.5, PatronH).Select Selection.OnAction = "BlackWhiteDesk" Selection.Characters.Text = "B/W" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 17), PatronH * (m + 1), PatronW, PatronH).Select Selection.name = "AddVector1" Selection.OnAction = "AddNewVector" Selection.Characters.Text = "+ Vector" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7), PatronH * (m - 1), PatronW, PatronH).Select Selection.name = "ChangeParFrw" Selection.OnAction = "ChangeParameter" Selection.Characters.Text = ChrW(8811) & Sheets("CONFIG").Range("J3").Value With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7), PatronH * (m), PatronW, PatronH).Select Selection.name = "ChangeParBack" Selection.OnAction = "ChangeParameter" Selection.Characters.Text = "<< " & Sheets("CONFIG").Range("J3").Value With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 9), PatronH * (m + 1), PatronW * 0.5, PatronH).Select Selection.OnAction = "rotate_Single" Selection.Characters.Text = "->" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7.5), PatronH * (m + 1), PatronW * 0.5, PatronH).Select Selection.OnAction = "rotate_SingleBack" Selection.Characters.Text = "<-" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 9.5), PatronH * (m + 1), PatronW * 0.5, PatronH).Select Selection.OnAction = "rotate_End" Selection.Characters.Text = "-->>" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 8), PatronH * (m + 1), PatronW, PatronH).Select Selection.OnAction = "rotate_n" Selection.Characters.Text = ChrW(8811) & Sheets("CONFIG").Range("K5").Value With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 9), PatronH * (m - 2), PatronW * 2, PatronH).Select Selection.OnAction = "About" Selection.Characters.Text = "ScienSolar info" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 12), PatronH * (m - 2), PatronW * 2, PatronH).Select Selection.OnAction = "ManualOnline" Selection.Characters.Text = "Manual" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n + 7), PatronH * (m + 1), PatronW * 0.5, PatronH).Select Selection.OnAction = "Reset" Selection.Characters.Text = "<<--" With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With ActiveSheet.Buttons.Add(PatronW * (n - 2) + 1, PatronH * (m), PatronW, PatronH).Select Selection.OnAction = "CreateCode" Selection.Characters.Text = Sheets("CONFIG").Range("B3").Value With Selection.Characters(Start:=1, Length:=11).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 End With 'Segment Init-12. Give a format to the cells in the spreadsheet: Cells.Select With Selection.Interior .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With Range("A1:K1").Select With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With Range("K2:K5").Select With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With Range("H5:K5").Select With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With Range("G6").Select With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With Range("D6:G6").Select With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With Range("C5:C6").Select With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With Range("A4:C4").Select With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.349986266670736 .Weight = xlThick End With Range("A2:K4").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark2 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 End With Range("D5:J5").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark2 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 End With Range("D6:G6").Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark2 .TintAndShade = 0 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 End With Cells(m + 1, n + 9).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorDark1 .TintAndShade = -0.249977111117893 .PatternTintAndShade = 0 End With With Selection.Font .Size = 9 .Color = -4165632 .TintAndShade = 0 End With ActiveCell.FormulaR1C1 = "S" & "c" & "i" & "e" & "n" _ & "S" & "o" & "l" & "a" & "r" & " v" & 1 & ".5" Cells(m + 4, n + 2).Select With Selection.Font .Size = 12 .Color = -4165632 .TintAndShade = 0 '.Bold = True .Italic = True End With Cells(m, n + 4).Select 'Label text color With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight2 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With Cells(m + 1, n + 4).Select ' X axis color With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight2 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With Cells(m + 2, n + 4).Select ' Y axis color With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight2 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With Cells(m + 3, n + 4).Select ' Z axis color With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight2 .TintAndShade = 0.399975585192419 .PatternTintAndShade = 0 End With 'Segment Init-13.Set initial parameters for the control panel: Cells(m - 1, n - 1).Value = "INICIO" Cells(m - 1, n + 3).FormulaR1C1 = "=CONFIG!R2C4" Cells(m - 1, n + 6).FormulaR1C1 = "=CONFIG!R2C8" Cells(m - 1, n + 8).Value = 1 Cells(m, n + 2).FormulaR1C1 = "=CONFIG!R3C4" Cells(m, n + 3).FormulaR1C1 = "=CONFIG!R3C5" Cells(m, n + 6).FormulaR1C1 = "=CONFIG!R3C8" Cells(m, n + 7).FormulaR1C1 = "=CONFIG!R3C9" Cells(m + 1, n + 2).FormulaR1C1 = "=CONFIG!R4C4" Cells(m + 1, n + 3).FormulaR1C1 = "=CONFIG!R4C5" Cells(m + 1, n + 6).FormulaR1C1 = "=CONFIG!R4C8" Cells(m + 1, n + 4).FormulaR1C1 = "=CONFIG!R4C6" Cells(m + 1, n + 5).FormulaR1C1 = "=CONFIG!R4C7" Cells(m + 1, n + 7).FormulaR1C1 = "=CONFIG!R4C9" Cells(m + 2, n + 2).FormulaR1C1 = "=CONFIG!R5C4" Cells(m + 2, n + 3).FormulaR1C1 = "=CONFIG!R5C5" Cells(m + 2, n + 4).FormulaR1C1 = "=CONFIG!R5C6" Cells(m + 2, n + 5).FormulaR1C1 = "=CONFIG!R5C7" Cells(m + 2, n + 6).FormulaR1C1 = "=CONFIG!R5C8" Cells(m + 2, n + 7).FormulaR1C1 = "=CONFIG!R5C9" Cells(m + 3, n + 2).FormulaR1C1 = "=CONFIG!R6C4" Cells(m + 3, n + 3).FormulaR1C1 = "=CONFIG!R6C5" Cells(m + 3, n + 4).FormulaR1C1 = "=CONFIG!R6C6" Cells(m + 3, n + 5).FormulaR1C1 = "=CONFIG!R6C7" Cells(m - 1, n + 2).Value = 2 'Segment Init-14. Restrict values to the INICIO cell: Range(Cells(m - 1, n - 1), Cells(m - 1, n - 1)).Select With Selection.Validation .Delete .Add Type:=xlValidateCustom, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:="INICIO" .IgnoreBlank = True .InCellDropdown = True .InputTitle = "INICIO" .ErrorTitle = "" .InputMessage = "Only value INICIO is allowed." .ErrorMessage = "Only value INICIO is allowed." .ShowInput = True .ShowError = True End With 'Segment Init-15. Introducing a help comment ActiveSheet.Cells(m, n + 9).Value = "HELP" ActiveSheet.Cells(m, n + 9).AddComment ActiveSheet.Cells(m, n + 9).Comment.Visible = False ActiveSheet.Cells(m, n + 9).Comment.Shape.Width = 300 ActiveSheet.Cells(m, n + 9).Comment.Shape.Height = 300 ActiveSheet.Cells(m, n + 9).Comment.Text Text:= _ "HELP Comment:" _ & Chr(10) & _ "1. To create new projects, press the +Vector button without selecting any project in the project list." _ & Chr(10) & _ "2. To load an existing project, select a project from the list and then press +Vector" _ & Chr(10) & _ "3. To export a new project, press the Get Code button. The code will be saved on your PC in the same directory where this file is located." _ & Chr(10) & Chr(10) & _ "If necessary, use this comment to create your own HELP comment for your project. To do this, simply replace this text with your own (Right Click, Edit Comment) and avoid special characters." _ & Chr(10) & "After pressing Get Code, your comment will be updated and saved in the same txt file as your project and will be uploaded after the project appears in ScienSolar." _ & "To include the new project in ScienSolar, perform the following steps:" _ & Chr(10) & _ "a) Open the txt file where the project was saved; " & _ "b) copy all the contents of the file and paste it in the VBA Editor of the Excel file ScienSolar; " & _ "c) add the project name and number to the list on the CONFIG sheet; " & _ "d) Verify that the number is correlative and that it agrees with the project header number, if not modify it in the header or in the list as necessary." _ & Chr(10) & _ "Right click to delete or edit this comment." _ & Chr(10) & Chr(10) & _ "For documentation on ScienSolar, please visit www.sciensolar.com. ScienSolar was designed for 3D physics modeling in MS Excel." & _ "It is normal that for some projects it takes time to load it in the sheet, it depends on the number of objects in your project and the performance of your PC." Cells(m + 1, n + 1).Select Application.ScreenUpdating = True End Sub Sub XYZ(ByVal m, n As Integer) '© 2022 A Becerra. ScienSolar.com 'Segment XYZ-01. Define the point of the coordinate origin If Cells(m - 1, n + 4).Value = 1 Then Call XYZOpposite(m, n) End If If IsNumeric(ActiveSheet.Cells(m, n + 3).Value) Then Y_abs = ActiveSheet.Cells(m, n + 3).Value Else ActiveSheet.Cells(m, n + 3).Value = 850 Y_abs = 850 End If If IsNumeric(ActiveSheet.Cells(m + 1, n + 3).Value) Then Z_abs = ActiveSheet.Cells(m + 1, n + 3).Value Else ActiveSheet.Cells(m + 1, n + 3).Value = 400 Z_abs = 400 End If If IsNumeric(ActiveSheet.Cells(m + 3, n + 3).Value) Then L = ActiveSheet.Cells(m + 3, n + 3).Value 'Axles length Else ActiveSheet.Cells(m + 3, n + 3).Value = 200 L = 200 End If 'Segment XYZ-02. Define the angles of rotation of the axes: A = -ActiveSheet.Cells(m + 1, n + 5).Value * WorksheetFunction.Pi / 180 'angulo alrededor de X en radianes phi B = ActiveSheet.Cells(m + 2, n + 5).Value * WorksheetFunction.Pi / 180 'angulo alrededor de Y en radianes theta C = -ActiveSheet.Cells(m + 3, n + 5).Value * WorksheetFunction.Pi / 180 'angulo alrededor de Z en radianes alpha 'Segment XYZ-03. Define the variables for the dimensions and position of the axes in the spreadsheet Dim x_width As Double Dim y_width As Double Dim z_width As Double Dim x_height As Double Dim y_height As Double Dim z_height As Double Dim T_top Dim T_left Dim T_name Dim T_color As Double T_color = Cells(m, n + 4).Interior.Color 'Segment XYZ-04. Set the width and height of the Excel shapes that will represent the axes, according to the rotation matrix x_width = L * (Cos(A) * Sin(C) + Sin(A) * Cos(C) * Sin(B)) x_height = L * (Sin(A) * Sin(C) - Cos(A) * Cos(C) * Sin(B)) y_width = L * (Cos(A) * Cos(C) + Sin(A) * Sin(C) * Sin(B)) y_height = L * (Sin(A) * Cos(C) + Cos(A) * Sin(C) * Sin(B)) z_width = -L * Sin(A) * Cos(B) z_height = L * Cos(A) * Cos(B) 'Segment XYZ-05. Delete old labels and axes. If CheckExists("EjeX") = True Then ActiveSheet.Shapes("EjeX").Delete End If If CheckExists("EjeY") = True Then ActiveSheet.Shapes("EjeY").Delete End If If CheckExists("EjeZ") = True Then ActiveSheet.Shapes("EjeZ").Delete End If 'Segment XYZ-06. Delete other old objects DeleteObjects (17) ' 17 - for text boxes (labels), 1 - for axes and vectors, 5- for free forms If CheckExists("campoHelp") = True Then ' ActiveSheet.Shapes("campoHelp").Delete End If 'Segment XYZ-07. Create new axes as Excel shapes Dim Eje As Object Set Eje = ActiveSheet.Shapes.AddShape(msoShapeLineInverse, 787.2, 301.8, 1047, 304.2) Eje.name = "EjeX" Set Eje = ActiveSheet.Shapes.AddShape(msoShapeLineInverse, 787.2, 301.8, 1047, 304.2) Eje.name = "EjeY" Set Eje = ActiveSheet.Shapes.AddShape(msoShapeLineInverse, 787.2, 301.8, 1047, 304.2) Eje.name = "EjeZ" Set Eje = Nothing 'Segment XYZ-08. Correct the dimensions of the shapes that represent the X axis, due to their variation when rotating them. With ActiveSheet.Shapes("EjeX") If x_width < "0" Then .Width = -x_width .Left = Y_abs + x_width T_left = .Left Else .Width = x_width .Left = Y_abs T_left = .Left + x_width .Flip msoFlipHorizontal End If If x_height < "0" Then .Height = -x_height .Top = Z_abs T_top = .Top - x_height Else .Height = x_height .Top = Z_abs - x_height T_top = .Top .Flip msoFlipVertical End If .Line.BeginArrowheadStyle = msoArrowheadTriangle .Line.ForeColor.RGB = Cells(m + 1, n + 4).Interior.Color ' End With 'Segment XYZ-09. Create X axis label T_label = ActiveSheet.Cells(m + 1, n + 4).Value T_name = ActiveSheet.Cells(m + 1, n + 4).Value Call CreateLabel(T_left, T_top, 0, 50, T_color, T_name, T_label) 'Segment XYZ-10. Do the same procedure above for the other two axes and labels With ActiveSheet.Shapes("EjeY") If y_width < "0" Then .Width = -y_width .Left = Y_abs + y_width T_left = .Left Else .Width = y_width .Left = Y_abs T_left = .Left + y_width .Flip msoFlipHorizontal End If If y_height < "0" Then .Height = -y_height .Top = Z_abs T_top = .Top - y_height Else .Height = y_height .Top = Z_abs - y_height T_top = .Top .Flip msoFlipVertical End If .Line.BeginArrowheadStyle = msoArrowheadTriangle .Line.ForeColor.RGB = Cells(m + 2, n + 4).Interior.Color End With T_label = ActiveSheet.Cells(m + 2, n + 4).Value T_name = ActiveSheet.Cells(m + 2, n + 4).Value Call CreateLabel(T_left, T_top, 0, 50, T_color, T_name, T_label) With ActiveSheet.Shapes("EjeZ") If z_width < "0" Then .Width = -z_width .Flip msoFlipHorizontal .Left = Y_abs + z_width T_left = .Left Else .Width = z_width .Left = Y_abs T_left = .Left + z_width End If If z_height < "0" Then .Flip msoFlipVertical .Height = -z_height .Top = Z_abs T_top = .Top - z_height Else .Height = z_height .Top = Z_abs - z_height T_top = .Top End If .Line.EndArrowheadStyle = msoArrowheadTriangle .Line.ForeColor.RGB = Cells(m + 3, n + 4).Interior.Color End With T_label = ActiveSheet.Cells(m + 3, n + 4).Value T_name = ActiveSheet.Cells(m + 3, n + 4).Value Call CreateLabel(T_left, T_top, 0, 50, T_color, T_name, T_label) End Sub Sub XYZNeg() ' Segment-XYZNeg-01. Enable negative axes of the coordinate system Dim m As Integer Dim n As Integer Set fila = ActiveSheet.Cells.Find(What:="INICIO") m = fila.Offset(1, 0).Row n = fila.Offset(1, 1).Column Set fila = Nothing If Cells(m - 1, n + 4).Value = 1 Then Cells(m - 1, n + 4).Value = 0 If CheckExists("EjeXo") = True Then ActiveSheet.Shapes("EjeXo").Delete End If If CheckExists("EjeYo") = True Then ActiveSheet.Shapes("EjeYo").Delete End If If CheckExists("EjeZo") = True Then ActiveSheet.Shapes("EjeZo").Delete End If Else Cells(m - 1, n + 4).Value = 1 End If 'Segment-XYZNeg-02. Update spreadsheet Rotate End Sub Sub XYZOpposite(ByVal m, n As Integer) '© 2022 A Becerra. ScienSolar.com 'Parameters of the negative axes 'Segment XYZOpposite-01. Define the point of the coordinate origin If IsNumeric(ActiveSheet.Cells(m, n + 3).Value) Then Y_abs = ActiveSheet.Cells(m, n + 3).Value Else ActiveSheet.Cells(m, n + 3).Value = 850 Y_abs = 850 End If If IsNumeric(ActiveSheet.Cells(m + 1, n + 3).Value) Then Z_abs = ActiveSheet.Cells(m + 1, n + 3).Value Else ActiveSheet.Cells(m + 1, n + 3).Value = 400 Z_abs = 400 End If If IsNumeric(ActiveSheet.Cells(m + 3, n + 3).Value) Then L = ActiveSheet.Cells(m + 3, n + 3).Value 'longitud de los ejes Else ActiveSheet.Cells(m + 3, n + 3).Value = 200 L = 200 End If 'Segment XYZOpposite-02. Define the angles of rotation of the axes: A = -ActiveSheet.Cells(m + 1, n + 5).Value * WorksheetFunction.Pi / 180 'angulo alrededor de X en radianes phi B = ActiveSheet.Cells(m + 2, n + 5).Value * WorksheetFunction.Pi / 180 'angulo alrededor de Y en radianes theta C = -ActiveSheet.Cells(m + 3, n + 5).Value * WorksheetFunction.Pi / 180 'angulo alrededor de Z en radianes alpha 'Segment XYZOpposite-03. Define the variables for the dimensions and position of the objects in the spreadsheet Dim x_width As Double Dim y_width As Double Dim z_width As Double Dim x_height As Double Dim y_height As Double Dim z_height As Double 'Segment XYZOpposite-04. Set the width and height of the Excel shapes that will represent the axes, according to the rotation matrix x_width = -L * (Cos(A) * Sin(C) + Sin(A) * Cos(C) * Sin(B)) x_height = -L * (Sin(A) * Sin(C) - Cos(A) * Cos(C) * Sin(B)) y_width = -L * (Cos(A) * Cos(C) + Sin(A) * Sin(C) * Sin(B)) y_height = -L * (Sin(A) * Cos(C) + Cos(A) * Sin(C) * Sin(B)) z_width = L * Sin(A) * Cos(B) z_height = -L * Cos(A) * Cos(B) 'Segment XYZOpposite-05. Delete old labels and axes. If CheckExists("EjeXo") = True Then ActiveSheet.Shapes("EjeXo").Delete End If If CheckExists("EjeYo") = True Then ActiveSheet.Shapes("EjeYo").Delete End If If CheckExists("EjeZo") = True Then ActiveSheet.Shapes("EjeZo").Delete End If 'Segment XYZOpposite-06. Create new axes as Excel shapes Dim Eje As Object Set Eje = ActiveSheet.Shapes.AddShape(msoShapeLineInverse, 787.2, 301.8, 1047, 304.2) Eje.name = "EjeXo" Set Eje = ActiveSheet.Shapes.AddShape(msoShapeLineInverse, 787.2, 301.8, 1047, 304.2) Eje.name = "EjeYo" Set Eje = ActiveSheet.Shapes.AddShape(msoShapeLineInverse, 787.2, 301.8, 1047, 304.2) Eje.name = "EjeZo" Set Eje = Nothing 'Segment XYZOpposite-07. Correct the dimensions of the shapes that represent the X axis, due to their variation when rotating them. With ActiveSheet.Shapes("EjeXo") If x_width < "0" Then .Width = -x_width .Left = Y_abs + x_width T_left = .Left Else .Width = x_width .Left = Y_abs T_left = .Left + x_width .Flip msoFlipHorizontal End If If x_height < "0" Then .Height = -x_height .Top = Z_abs T_top = .Top - x_height Else .Height = x_height .Top = Z_abs - x_height T_top = .Top .Flip msoFlipVertical End If .Line.Transparency = 0.3 .Line.DashStyle = 6 .Line.BeginArrowheadStyle = msoArrowheadTriangle .Line.ForeColor.RGB = Cells(m + 1, n + 4).Interior.Color ' End With 'Segment XYZOpposite-08. Do the same procedure above for the other two negative axes With ActiveSheet.Shapes("EjeYo") If y_width < "0" Then .Width = -y_width .Left = Y_abs + y_width T_left = .Left Else .Width = y_width .Left = Y_abs T_left = .Left + y_width .Flip msoFlipHorizontal End If If y_height < "0" Then .Height = -y_height .Top = Z_abs T_top = .Top - y_height Else .Height = y_height .Top = Z_abs - y_height T_top = .Top .Flip msoFlipVertical End If .Line.Transparency = 0.3 .Line.DashStyle = 6 .Line.BeginArrowheadStyle = msoArrowheadTriangle .Line.ForeColor.RGB = Cells(m + 2, n + 4).Interior.Color End With With ActiveSheet.Shapes("EjeZo") If z_width < "0" Then .Width = -z_width .Flip msoFlipHorizontal .Left = Y_abs + z_width T_left = .Left Else .Width = z_width .Left = Y_abs T_left = .Left + z_width End If If z_height < "0" Then .Flip msoFlipVertical .Height = -z_height .Top = Z_abs T_top = .Top - z_height Else .Height = z_height .Top = Z_abs - z_height T_top = .Top End If .Line.Transparency = 0.3 .Line.DashStyle = 6 .Line.EndArrowheadStyle = msoArrowheadTriangle .Line.ForeColor.RGB = Cells(m + 3, n + 4).Interior.Color End With End Sub Sub Field(ByVal m, n As Integer) '© 2022 A Becerra. ScienSolar.com 'Procedure to display three-dimensional fields in the spreadsheet 'Segment Field-01. Declaration of variables ActiveSheet.Range("K6").Value = "" ' ' Clean the message: some vector were underscaled. Dim T_color As Double 'Label text color Dim xS As Single ' Vector scale in the XYZ system Dim NLine As Double ' Variable for range in X coordinate Dim NLine2 As Double ' Variable for range in Y coordinate Dim NLine3 As Double 'Variable for range in Z coordinate Dim s As Integer ' This indicates the number of each vector in a fiel formula. If a field has 900 vectors on the sheet, s goes from 1 to 900 T_color = Cells(m, n + 4).Interior.Color If IsNumeric(ActiveSheet.Cells(m + 2, n + 3).Value) Then xS = ActiveSheet.Cells(m + 2, n + 3).Value Else ActiveSheet.Cells(m + 2, n + 3).Value = 20 xS = 20 End If 'Segment Field-02. Do while there are vectors in the spreadsheet. Do While Cells(m + 3, n - 1).Value <> "" 'Segment Field-03. Clean old vectors in the spreadsheet If Cells(m + 5, n - 1).Value > 2000 Then ' If the number of vectors is >2000, they disappear instantly: Call DeleteObjects(1) Call DeleteObjects(30) Call XYZ(m, n) Else 'if not, they gradually disappear: i = 0 For i = Cells(m + 10, n + 1).Value To Cells(m + 5, n - 1).Value ' deja un vector sin eliminar (el indicado en la celda) On Error Resume Next ActiveSheet.Shapes("campo" & Cells(m + 3, n - 1).Value & "_" & 1).Delete ' Updated Dec 2023 ActiveSheet.Shapes("campo" & Cells(m + 3, n - 1).Value & "_" & i).Delete Next i End If 'Segment Field-04. Verifyif that the vector has 3D objects If Cells(m + 4, n).Value = 200 Then Cells(m + 5, n + 1).Value = 2 ' This property is to enable 3D Excel Models (stored in 3DModels spreadsheet) 'Segment Field-05. Display vectors in the XYZ system: If Cells(m + 3, n - 1).Value > 0 And Cells(m + 5, n + 1).Value <> 1 Then ' These conditions apply to the vectors that will be displayed Dim cod As Integer ' Define the type of Excel shape that will represent the vector cod = Cells(m + 4, n).Value 'Segment Field-06. Output data to a table when simulating. If the cell value is zero, no data will be displayed If Cells(m + 10, n).Value > 0 And Cells(m + 11, n).Value > 0 Then Call DataOutput(m, n) ' Display data in a table. End If 'Segment Field-07. The following condition allows us to display a field function in a region of XYZ as a set of vectors. If ActiveSheet.Cells(m + 4, n + 1).Value <> "" Then ' If not empty, is a field; if empty is a single vector. If ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = 1 Then ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = "" GoTo sig End If If ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = 0 Then ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = "" GoTo sig End If NLine = 0 ' X feed step NLine2 = 10 ' Y feed step NLine3 = 10 ' Z feed step Dim Atemp As Double 'Temp variables Dim Btemp As Double Dim Ctemp As Double Dim x_0 As Double Dim y_0 As Double Dim z_0 As Double Dim Nline0x As Double 'X begin Dim Nline0y As Double 'Y begin Dim Nline0z As Double 'Z begin Dim Nlinex As Double 'X end Dim Nliney As Double 'Y end Dim Nlinez As Double 'Z end Dim Bulk ' calculo preliminar de cantidad de vectores Dim Response Dim msg Dim tfactor 'tiempo que demora el PC enponer un vector en la hoja Dim t As Single 'fijacion del tiempo Dim A As Variant Dim Centery As Double Dim Centerx As Double Dim Centerz As Double A = Array() 'i = CDbl(i) ' convertir a Double Dim j As Double Dim k As Double x_0 = 0 y_0 = 0 z_0 = 0 Atemp = 0 Btemp = 0 Ctemp = 0 i = 0 ' feed in x j = 0 ' feed in y k = 0 ' feed in z s = 1 'Modify the initial coordinate formulas. ActiveSheet.Cells(m + 7, n - 1).FormulaR1C1 = "=R[1]C" ActiveSheet.Cells(m + 7, n).FormulaR1C1 = "=R[1]C" ActiveSheet.Cells(m + 7, n + 1).FormulaR1C1 = "=R[1]C" 'Choose the coordinate system indicated by the user (s, c or o) If Left(ActiveSheet.Cells(m + 4, n + 1).Value, 1) = "s" Then 'Segment Field-07a. Spherical coordinates 'verify if the parameters were not stablished by the user: If WorksheetFunction.Or(InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "r=") = 0, InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "phi=") = 0, InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "theta=") = 0) Then If L / xS < 1 Then Nlinex = Round(L / (2 * xS), InStr(InStr(L / (2 * xS), ","), L / (2 * xS), "0", 0) + 1) Else Nlinex = Round(L / (2 * xS), 0) End If NLine = Nlinex / 10 NLine2 = 10 NLine3 = 10 Nline0x = Nlinex Nline0y = 0 Nline0z = 0 Nliney = 360 Nlinez = 180 ' Set origin by default and automatically according to the dimensions of the current vectors: 'Collect current vector coordinate data: i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n - 1).Value End If i = i + 1 j = j + 1 Loop Centerx = WorksheetFunction.Average(A) Erase A i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n).Value End If i = i + 1 j = j + 1 Loop Centery = WorksheetFunction.Average(A) Erase A i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n + 1).Value End If i = i + 1 j = j + 1 Loop Centerz = WorksheetFunction.Average(A) Erase A 'Put parameters to display the field: ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = "s[" & NLine & "]r=[" & Nline0x & ";" & Nlinex & "]s2[" & NLine2 & "]phi=[" & Nline0y & ";" & Nliney & "]s3[" & NLine3 & "]theta=[" & Nline0z & ";" & Nlinez & "]color=[" & Nlinex * 2 & "]origin[cart.]=[" & Centerx & ";" & Centery & ";" & Centerz & "]tfactor=0,008s" ActiveSheet.Cells(m + 4, n + 1).AddComment ActiveSheet.Cells(m + 4, n + 1).Comment.Visible = False ActiveSheet.Cells(m + 4, n + 1).Comment.Shape.Width = 300 ActiveSheet.Cells(m + 4, n + 1).Comment.Shape.Height = 300 ActiveSheet.Cells(m + 4, n + 1).Comment.Text Text:="Field mode:" & Chr(10) & "1. For spherical coordinates, cell value = s" _ & Chr(10) & "2. For cylindrical coordinates, cell value = c" _ & Chr(10) & "3. For Cartesian coordinates, cell value = o" _ & Chr(10) & Chr(10) & "Then set the parameters to the string that appeared in this cell." _ & Chr(10) & "The first parenthesis [ ] indicates the step of increasing coordinates, " _ & "the next three parentheses [ ] indicate the range of each of the three coordinates, " _ & "the higher the range, the longer the rendering time; " _ & "the color parameter is used to color the vector according to its length, the number indicating approximately the length of the largest vector, " _ & "the color is distributed between red (smaller vector) and violet (larger vector)." _ & "The last parenthesis [ ] indicates the origin of the coordinates, where vector distributions begin." _ & Chr(10) & Chr(10) & "Please enclose only numeric values between semicolons, do not modify the structure of this string, except if you are an expert in MS Excel." _ & Chr(10) & Chr(10) & "To return to single vector mode, clear the contents of this cell." _ & Chr(10) & Chr(10) & "Right-click to remove this comment." 'Regulate the length of all the vectors of the field. ActiveSheet.Cells(m + 5, n).Value = "60*1" ' regulador de longitudes End If Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "s[") + 2 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'value of NLine 'Definir NLine2, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "s2[") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine2 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir NLine3, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "s3[") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine3 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir el rango de r Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "r=") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0x = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de r Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nlinex = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de r 'Definir el rango de phi Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "phi=") + 5 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0y = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de phi Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nliney = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de phi 'Definir el rango de theta Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "theta=") + 7 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0z = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de phi Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nlinez = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de phi 'Definir el tiempo de demora para mostrar un vector Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "tfactor=") + 8 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "s", 1) Ctemp = Btemp - Atemp tfactor = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de tfactor 'Verificar la cantidad de vectores Bulk = (WorksheetFunction.RoundDown((Nlinex - Nline0x + 1) / (NLine + 1), 0) + 1) _ * (WorksheetFunction.RoundDown((Nliney - Nline0y + 1) / (NLine2 + 1), 0) + 1) _ * (WorksheetFunction.RoundDown((Nlinez - Nline0z + 1) / (NLine3 + 1), 0) + 1) msg = "They will be more than " & Bulk & " vectors, and depending on the performance of your computer it will take more than " _ & Round(1.2 * (Bulk * tfactor + 15) / 60, 1) & " minutes to render. Do you want to continue?" If Round(2 * (Bulk * tfactor) / 60, 1) > 0.5 Then ' confirmacion del ususario cuando el tiempode renderiz. es mayor a medio minuto Response = MsgBox(msg, vbYesNo, "Confirmation") If Response = vbYes Then Else GoTo sig End If End If 'Origin of the spherical coordinates in the XYZ system On Error Resume Next ' 08-2024 'Origin in x: Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "origin[cart.]=") + 15 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp x_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'Origin in y Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "origin[cart.]=") + 16 + Ctemp Btemp = InStr(Atemp + 1, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp y_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'Origin in z Atemp = InStr(Btemp + 1, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Atemp - Btemp z_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) '/////////////////' measurement of time t = Timer '///////////////// 'Display the field in the coordinate system (display it in spherical coordinates) For i = Nline0x To Nlinex Step NLine For j = Nline0y To Nliney Step NLine2 For k = Nline0z To Nlinez Step NLine3 ActiveSheet.Cells(m + 8, n - 1).Value = i * Cos(WorksheetFunction.Radians(j)) * Sin(WorksheetFunction.Radians(k)) + x_0 ActiveSheet.Cells(m + 8, n).Value = i * Sin(WorksheetFunction.Radians(j)) * Sin(WorksheetFunction.Radians(k)) + y_0 ActiveSheet.Cells(m + 8, n + 1).Value = i * Cos(WorksheetFunction.Radians(k)) + z_0 Call VectorOutput(m, n, s, cod, Y_abs, Z_abs, xS, T_color) 'Put each vector in XYZ If Cells(m + 10, n).Value > 0 And Cells(m + 11, n).Value > 0 Then Call DataOutput(m, n) DoEvents End If s = s + 1 ' next vector Next k Next j Next i Else 'Segment Field-07b Begin of cylindrical coordinates If Left(ActiveSheet.Cells(m + 4, n + 1).Value, 1) = "c" Then If WorksheetFunction.Or(InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "rho=") = 0, InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "phi=") = 0, InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "z=") = 0) Then If L / xS < 1 Then Nlinex = Round(L / (xS), InStr(InStr(L / (xS), ","), L / (xS), "0", 0) + 1) Else Nlinex = Round(L / (xS), 0) End If NLine = Nlinex / 5 NLine2 = 10 NLine3 = Nlinex / 5 Nline0x = Nlinex / 3 Nline0y = 0 Nline0z = 0 Nliney = 360 Nlinez = 0 ' Set origin by default and automatically according to the dimensions of the current vectors: 'Collect current vector coordinate data: i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n - 1).Value End If i = i + 1 j = j + 1 Loop Centerx = WorksheetFunction.Average(A) Erase A i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n).Value End If i = i + 1 j = j + 1 Loop Centery = WorksheetFunction.Average(A) Erase A i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n + 1).Value End If i = i + 1 j = j + 1 Loop Centerz = WorksheetFunction.Average(A) Erase A 'Put parameters to display the field: ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = "c[" & NLine & "]rho=[" & Nline0x & ";" & Nlinex & "]c2[" & NLine2 & "]phi=[" & Nline0y & ";" & Nliney & "]c3[" & NLine3 & "]z=[" & Nline0z & ";" & Nlinez & "]color=[" & Nlinex & "]origin[cart.]=[" & Centerx & ";" & Centery & ";" & Centerz & "]tfactor=0,008s" ActiveSheet.Cells(m + 4, n + 1).AddComment ActiveSheet.Cells(m + 4, n + 1).Comment.Visible = False ActiveSheet.Cells(m + 4, n + 1).Comment.Shape.Width = 300 ActiveSheet.Cells(m + 4, n + 1).Comment.Shape.Height = 300 ActiveSheet.Cells(m + 4, n + 1).Comment.Text Text:="Field mode:" & Chr(10) & "1. For spherical coordinates, cell value = s" _ & Chr(10) & "2. For cylindrical coordinates, cell value = c" _ & Chr(10) & "3. For Cartesian coordinates, cell value = o" _ & Chr(10) & Chr(10) & "Then set the parameters to the string that appeared in this cell." _ & Chr(10) & "The first parenthesis [ ] indicates the step of increasing coordinates, " _ & "the next three parentheses [ ] indicate the range of each of the three coordinates, " _ & "the higher the range, the longer the rendering time; " _ & "the color parameter is used to color the vector according to its length, the number indicating approximately the length of the largest vector, " _ & "the color is distributed between red (smaller vector) and violet (larger vector)." _ & "The last parenthesis [ ] indicates the origin of the coordinates, where vector distributions begin." _ & Chr(10) & Chr(10) & "Please enclose only numeric values between semicolons, do not modify the structure of this string, except if you are an expert in MS Excel." _ & Chr(10) & Chr(10) & "To return to single vector mode, clear the contents of this cell." _ & Chr(10) & Chr(10) & "Right-click to remove this comment." 'ActiveSheet.Cells(m + 5, n).Value = "60*1" ' regulador de longitudes End If 'Definir NLine, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "c[") + 2 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir NLine2, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "c2[") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine2 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir NLine3, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "c3[") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine3 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir el rango de rho Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "rho=") + 5 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0x = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de rho Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nlinex = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de r 'Definir el rango de phi Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "phi=") + 5 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0y = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de phi Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nliney = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de phi 'Definir el rango de z Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "z=") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0z = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de phi Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nlinez = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de phi 'Definir el tiempo de demora para mostrar un vector Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "tfactor=") + 8 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "s", 1) Ctemp = Btemp - Atemp tfactor = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de tfactor 'Verificar la cantidad de vectores Bulk = (WorksheetFunction.RoundDown((Nlinex - Nline0x + 1) / (NLine + 1), 0) + 1) _ * (WorksheetFunction.RoundDown((Nliney - Nline0y + 1) / (NLine2 + 1), 0) + 1) _ * (WorksheetFunction.RoundDown((Nlinez - Nline0z + 1) / (NLine3 + 1), 0) + 1) msg = "They will be more than " & Bulk & " vectors, and depending on the performance of your computer it will take more than " _ & Round((Bulk * tfactor + 15) / 60, 1) & " minutes to render. Do you want to continue?" If Round((2 * Bulk * tfactor) / 60, 1) > 0.5 Then ' confirmacion del ususario cuando el tiempode renderiz. es mayor a medio minuto Response = MsgBox(msg, vbYesNo, "Confirmation") If Response = vbYes Then Else GoTo sig End If End If 'Origen de coordenadas: 'origen en x: On Error Resume Next ' 08-2024 Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "origin[cart.]=") + 15 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp x_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'origen en y Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "origin[cart.]=") + 16 + Ctemp Btemp = InStr(Atemp + 1, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp y_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'origen en z Atemp = InStr(Btemp + 1, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Atemp - Btemp z_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) '/////////////////'medicion de tiempo de ejecucion del campo t = Timer '///////////////// 'Display the field in the coordinate system (display it in cylindrical coordinates) For i = Nline0x To Nlinex Step NLine For j = Nline0y To Nliney Step NLine2 For k = Nline0z To Nlinez Step NLine3 ActiveSheet.Cells(m + 8, n - 1).Value = i * Cos(WorksheetFunction.Radians(j)) + x_0 ActiveSheet.Cells(m + 8, n).Value = i * Sin(WorksheetFunction.Radians(j)) + y_0 ActiveSheet.Cells(m + 8, n + 1).Value = k + z_0 Call VectorOutput(m, n, s, cod, Y_abs, Z_abs, xS, T_color) 'Put each vector in XYZ If Cells(m + 10, n).Value > 0 And Cells(m + 11, n).Value > 0 Then Call DataOutput(m, n) DoEvents End If s = s + 1 ' siguiente vector clonado Next k Next j Next i Else 'Segment Field-07c. Begin of Cartesian coordinates. If Left(ActiveSheet.Cells(m + 4, n + 1).Value, 1) = "=" Then GoTo sig If WorksheetFunction.Or(InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "x=") = 0, InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "y=") = 0, InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "z=") = 0) Then If L / xS < 1 Then Nliney = Round(L / (xS), InStr(InStr(L / (xS), ","), L / (xS), "0", 0) + 1) Else Nliney = Round(L / (xS), 0) End If NLine = Nliney / 20 NLine2 = Nliney / 20 NLine3 = Nliney / 20 Nline0x = 0 Nline0y = -Nliney Nline0z = -Nliney Nlinex = 0 Nlinez = Nliney ' Set origin by default and automatically according to the dimensions of the current vectors: 'Collect current vector coordinate data: i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n - 1).Value End If i = i + 1 j = j + 1 Loop Centerx = WorksheetFunction.Average(A) Erase A i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n).Value End If i = i + 1 j = j + 1 Loop Centery = WorksheetFunction.Average(A) Erase A i = 0 j = 1 Do While ActiveSheet.Cells(m + 3 + i * 9, n - 1).Value <> "" If Cells(m + 5 + i * 9, n + 1).Value < 1 Then ReDim Preserve A(j + 5) A(j) = Cells(m + 7 + i * 9, n + 1).Value End If i = i + 1 j = j + 1 Loop Centerz = WorksheetFunction.Average(A) Erase A 'Put parameters to display the field: ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = "o[" & NLine & "]x=[" & Nline0x & ";" & Nlinex & "]o2[" & NLine2 & "]y=[" & Nline0y & ";" & Nliney & "]o3[" & NLine3 & "]z=[" & Nline0z & ";" & Nlinez & "]color=[" & Nliney * 2 & "]origin[cart.]=[" & Centerx & ";" & Centery & ";" & Centerz & "]tfactor=0,008s" ActiveSheet.Cells(m + 4, n + 1).AddComment ActiveSheet.Cells(m + 4, n + 1).Comment.Visible = False ActiveSheet.Cells(m + 4, n + 1).Comment.Shape.Width = 300 ActiveSheet.Cells(m + 4, n + 1).Comment.Shape.Height = 300 ActiveSheet.Cells(m + 4, n + 1).Comment.Text Text:="Field mode:" & Chr(10) & "1. For spherical coordinates, cell value = s" _ & Chr(10) & "2. For cylindrical coordinates, cell value = c" _ & Chr(10) & "3. For Cartesian coordinates, cell value = o" _ & Chr(10) & Chr(10) & "Then set the parameters to the string that appeared in this cell." _ & Chr(10) & "The first parenthesis [ ] indicates the step of increasing coordinates, " _ & "the next three parentheses [ ] indicate the range of each of the three coordinates, " _ & "the higher the range, the longer the rendering time; " _ & "the color parameter is used to color the vector according to its length, the number indicating approximately the length of the largest vector, " _ & "the color is distributed between red (smaller vector) and violet (larger vector)." _ & "The last parenthesis [ ] indicates the origin of the coordinates, where vector distributions begin." _ & Chr(10) & Chr(10) & "Please enclose only numeric values between semicolons, do not modify the structure of this string, except if you are an expert in MS Excel." _ & Chr(10) & Chr(10) & "To return to single vector mode, clear the contents of this cell." _ & Chr(10) & Chr(10) & "Right-click to remove this comment." ActiveSheet.Cells(m + 5, n).Value = "60*1" ' regulador de longitudes End If If InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "y=") = 0 Then ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = "o[2]x=[0;0]o2[2]y=[-10;10]o3[2]z=[-10;10]color=[8]origin[cart.]=[0;0;0]tfactor=0,008s" End If If InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "z=") = 0 Then ActiveSheet.Cells(m + 4, n + 1).FormulaR1C1 = "o[2]x=[0;0]o2[2]y=[-10;10]o3[2]z=[-10;10]color=[8]origin[cart.]=[0;0;0]tfactor=0,008s" End If 'Definir NLine, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "o[") + 2 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir NLine2, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "o2[") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine2 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir NLine3, intervalo de cambio de las variables Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "o3[") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp NLine3 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de NLine 'Definir el rango de x Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "x=") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0x = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de x Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nlinex = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de x 'Definir el rango de y Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "y=") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0y = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de y Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nliney = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de y 'Definir el rango de z Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "z=") + 3 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp Nline0z = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor inicial de z Atemp = InStr(Btemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]") Ctemp = Atemp - Btemp Nlinez = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) ' valor final de z 'Definir el tiempo de demora para mostrar un vector Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "tfactor=") + 8 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "s", 1) Ctemp = Btemp - Atemp tfactor = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'valor de tfactor 'Verificar la cantidad de vectores Bulk = (WorksheetFunction.RoundDown((Nlinex - Nline0x + 1) / (NLine + 1), 0) + 1) _ * (WorksheetFunction.RoundDown((Nliney - Nline0y + 1) / (NLine2 + 1), 0) + 1) _ * (WorksheetFunction.RoundDown((Nlinez - Nline0z + 1) / (NLine3 + 1), 0) + 1) msg = "They will be more than " & Bulk & " vectors, and depending on the performance of your computer it will take more than " _ & Round((Bulk * tfactor + 15) / 60, 1) & " minutes to render. Do you want to continue?" If Round((Bulk * tfactor + 15) / 60, 1) > 0.5 Then ' confirmacion del ususario cuando el tiempode renderiz. es mayor a medio minuto Response = MsgBox(msg, vbYesNo, "Confirmation") If Response = vbYes Then Else GoTo sig End If End If 'Origin: On Error Resume Next ' 08-2024 'origen en x: Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "origin[cart.]=") + 15 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp x_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'origen en y Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "origin[cart.]=") + 16 + Ctemp Btemp = InStr(Atemp + 1, ActiveSheet.Cells(m + 4, n + 1).Value, ";", 1) Ctemp = Btemp - Atemp y_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) 'origen en z Atemp = InStr(Btemp + 1, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Atemp - Btemp z_0 = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Btemp + 1, Ctemp - 1) '/////////////////'measurement of time t = Timer '///////////////// ''Display the field in the coordinate system (display it in Cartesian coordinates) For i = Nline0x To Nlinex Step NLine For j = Nline0y To Nliney Step NLine2 For k = Nline0z To Nlinez Step NLine3 ActiveSheet.Cells(m + 8, n - 1).Value = i + x_0 ActiveSheet.Cells(m + 8, n).Value = j + y_0 ActiveSheet.Cells(m + 8, n + 1).Value = k + z_0 Call VectorOutput(m, n, s, cod, Y_abs, Z_abs, xS, T_color) 'Put each vector in XYZ If Cells(m + 10, n).Value > 0 And Cells(m + 11, n).Value > 0 Then ' Call DataOutput(m, n) DoEvents End If s = s + 1 ' next vector Next k Next j Next i End If ' Ending of cylindrical and spherical coord. End If 'End of coordinates '//////////Records the total time it took Excel to place all the vectors of the field into the spreadsheet. ActiveSheet.Cells(m + 4, n + 1).Formula = Replace(ActiveSheet.Cells(m + 4, n + 1).Formula, "tfactor=" & tfactor, "tfactor=" & (Timer - t) / s, 1, 1) sig: 'Segment Field-08. Here the option to show field ends and the option to show a single vector begins Else s = 1 Call VectorOutput(m, n, s, cod, Y_abs, Z_abs, xS, T_color) End If 'Segment field-09. Fix s (vector inside a field) Cells(m + 5, n - 1).Value = s End If m = m + 9 ' Next vector of the spreadsheet in the first 3 columns. Loop End Sub Sub Rotate() '© 2022 A Becerra. ScienSolar.com 'Procedure to update spreadsheet Application.ScreenUpdating = False Dim t As Single ' para medir el tiempo 1/100 s quitar el comentario t = Timer Dim fila As Range Dim m As Integer Dim n As Integer Set fila = Cells.Find(What:="INICIO") m = fila.Offset(1, 0).Row n = fila.Offset(1, 1).Column Set fila = Nothing Call XYZ(m, n) Call Field(m, n) Application.ScreenUpdating = True Cells(m + 2, n).Value = "t = " & Timer - t & " s." ' muestra el tiempo que dura el codigo en ejecutarse. Quitar el comentario End Sub Sub CreateLabel(ByVal L, t, W, h As Single, T_color As Double, name, label As Variant) 'Procedure to create labels of the vectors '© 2022 A Becerra. ScienSolar.com On Error Resume Next If Left(label, 3) = "(Eq" Then Sheets("3DModels").Shapes(label).Copy ActiveSheet.Paste With ActiveSheet.Shapes(label) .Left = L .Top = t .TextFrame2.TextRange.Characters.Font.Fill.ForeColor.RGB = T_color End With ActiveSheet.Buttons("AutoSc").Select Else ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, L, t, 100, h).name = "Cuadro" & name With ActiveSheet.Shapes("Cuadro" & name) With .TextFrame2.TextRange.Characters .Text = label With .Font.Fill .ForeColor.RGB = T_color .Transparency = W .Solid End With End With End With ActiveSheet.Shapes("Cuadro" & name).Fill.Visible = msoFalse ActiveSheet.Shapes("Cuadro" & name).Line.Visible = msoFalse ActiveSheet.Shapes("Cuadro" & name).TextFrame2.AutoSize = msoAutoSizeShapeToFitText ActiveSheet.Shapes("Cuadro" & name).TextFrame2.WordWrap = msoTrue 'modif may 2023 End If End Sub Sub InitVector(ByVal m, n As Integer) ' Procedure to add vectors to the spreadsheet. Specifically adding 9 rows to the first 3 columns to set up a vector '© 2022 A Becerra. ScienSolar.com Application.ScreenUpdating = False 'Segment InitVector-02. Define variables Dim Vname As String Dim lista As Range Dim Vcolor As Variant Dim VecType As Integer Dim m1 As Integer Dim n1 As Integer Dim flag As Boolean Dim FormatName As String Dim Lang As String m1 = m n1 = n Vname = Cells(m + 1, n + 1).Value ' Name of the vector Vcolor = Cells(m + 1, n + 1).Interior.Color ' Color of the vector VecType = Cells(m + 1, n - 1).Value If VecType < 2 Then Vname = InputBox("Enter a letter or short name for the vector:", "Vector", Vname) If Vname = "" Then Vname = Cells(m + 1, n + 1).Value End If End If Cells(m + 2, n + 9).Select Selection.FormulaR1C1 = "A" & "." & " " & "B" & "e" _ & "c" & "e" & "r" & "r" & "a" & " " & "B" & "." With Selection.Font .Color = Selection.Interior.Color End With 'Segment InitVector-02a. Set language of the control panel Set lista = Sheets("CONFIG").Cells.Find(What:="LENGUAJE") m2 = lista.Row n2 = lista.Offset(0, -1).Column Set lista = Nothing Lang = WorksheetFunction.VLookup(ActiveSheet.Cells(m - 1, n + 18).Value, Sheets("CONFIG").Range(Cells(m2, n2).Address(0, 0) & ":" & Cells(m2 + 14, n2 + 2).Address(0, 0)), 3, False) 'Segment InitVector-01. Count the current number of vectors in the spreadsheet i = 0 flag = False Do While Cells(m + 4 + 9 * i, n - 1).Value <> "" If Cells(m + 4 + 9 * i, n).Value = "186" And VecType = 15 Then flag = True End If i = i + 1 Loop 'Segment InitVector-03. Define vector parameters m = m + i * 9 Cells(m + 1, n).Select PatronW = ActiveSheet.Cells(m + 3, n - 1).Width PatronH = ActiveSheet.Cells(m + 3, n - 1).Height PatronT = ActiveSheet.Cells(m + 3, n - 1).Top If flag = True Then GoTo NoVector 'Segment InitVector-03. Restrict values for data table cells Range(Cells(m + 10, n), Cells(m + 11, n)).Validation.Delete Range(Cells(m + 10, n), Cells(m + 11, n)).Validation.Add Type:=xlValidateWholeNumber, AlertStyle:=xlValidAlertStop, _ Operator:=xlGreaterEqual, Formula1:="0" Range(Cells(m + 10, n), Cells(m + 11, n)).Validation.InputTitle = "DATA OUTPUT" Range(Cells(m + 10, n), Cells(m + 11, n)).Validation.InputMessage = "Enter the row and column number to generate " & " coordinates data during the simulation." & "The number ""0"" indicates that no data will be generated. Make sure that " & "the cells do not intersect already occupied cells. " Range(Cells(m + 10, n), Cells(m + 11, n)).Validation.ErrorMessage = "For rows or columns, you can only enter a positive integer." 'Segment InitVector-04. Set format ActiveSheet.Cells(m + 3, n).Select With Selection .Value = Vname .Font.Bold = True .HorizontalAlignment = xlCenter .VerticalAlignment = xlBottom End With 'Segment InitVector-05. Put the first button in cell A6 ActiveSheet.Buttons.Add(PatronW * (n - 2), PatronT, PatronW / 3, PatronH).Select Selection.name = "Conf_" & Cells(m + 3, n - 1).Row Selection.OnAction = "VectorForm" Selection.Characters.Text = ChrW(9967) With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = 1 End With 'Segment InitVector-06. Put the second button in cell A6 ActiveSheet.Buttons.Add(PatronW * (n - 4 / 3), PatronT, PatronW / 3, PatronH).Select Selection.name = Cells(m + 3, n - 1).Row Selection.OnAction = "ShowHideVecConf" Selection.Characters.Text = ChrW(9650) With Selection.Characters(Start:=1, Length:=3).Font .name = "Calibri" .FontStyle = "Normal" .Size = 11 .Strikethrough = False .Superscript = False .Subscript = False .OutlineFont = False .Shadow = False .Underline = xlUnderlineStyleNone .ColorIndex = 1 End With ActiveSheet.Cells(m + 3, n - 1).Select 'Segment InitVector-06a. Set parameters by default ActiveSheet.Cells(m + 3, n - 1).Value = i + 1 ' numero del vector ActiveSheet.Cells(m + 4, n - 1).Value = "1" ' menu desplegado ActiveSheet.Cells(m + 4, n).Value = "183" ' tipo de vector (forma) ActiveSheet.Cells(m + 5, n).Value = "1" ' tipo de linea ActiveSheet.Cells(m + 5, n).NumberFormat = """line: "" 0.0 " ActiveSheet.Cells(m + 5, n + 1).Value = "0.3" ' transparencia ActiveSheet.Cells(m + 5, n + 1).NumberFormat = """transp.: "" 0.0 " ActiveSheet.Cells(m + 5, n - 1).Value = 1 ' memoria de la cantidad de vectores campo ActiveSheet.Cells(m + 7, n - 1).Value = "0" 'componente x inicial ActiveSheet.Cells(m + 7, n).Value = "0" 'componente y inicial ActiveSheet.Cells(m + 7, n + 1).Value = "0" 'componente z inicial ActiveSheet.Cells(m + 9, n - 1).Value = "2" ' valor x del vector ActiveSheet.Cells(m + 9, n).Value = "2" ' valor y del vector ActiveSheet.Cells(m + 9, n + 1).Value = 2 * (i + 1) ' valor z del vector" ActiveSheet.Cells(m + 10, n - 1).Value = 1 ' cola del vector ActiveSheet.Cells(m + 10, n - 1).NumberFormat = """tail: "" 0 " ActiveSheet.Cells(m + 10, n).Value = "0" ActiveSheet.Cells(m + 10, n).NumberFormat = """Dat row: "" 0 " ActiveSheet.Cells(m + 10, n + 1).Value = "1" ActiveSheet.Cells(m + 10, n + 1).NumberFormat = """history: "" 0 " ActiveSheet.Cells(m + 11, n - 1).Value = 3 ' cabeza del vector ActiveSheet.Cells(m + 11, n - 1).NumberFormat = """head: "" 0 " ActiveSheet.Cells(m + 11, n).Value = "0" ' grosor ActiveSheet.Cells(m + 11, n).NumberFormat = """Dat col: "" 0 " ActiveSheet.Cells(m + 11, n + 1).Value = 1 ' grosor del vector ActiveSheet.Cells(m + 11, n + 1).NumberFormat = """thickness: "" 0 " ' grosor del vector ActiveSheet.Cells(m + 8, n + 2).FormulaR1C1 = "=IF(R[-4]C[-1]>1,"" <-- Variable coordinates"","""")" ActiveSheet.Cells(m + 9, n + 2).FormulaR1C1 = "=IF(R[-5]C[-1]>1,"" <-- Field formulae"","""")" ActiveSheet.Cells(m + 10, n + 4).FormulaR1C1 = "=IF(RC[-4]>0,"" For aditional formula (FA),"","""")" ActiveSheet.Cells(m + 11, n + 4).FormulaR1C1 = "=IF(R[-1]C[-4]>0,""<-- use these cells."","""")" ActiveSheet.Cells(m + 7, n - 1).FormulaR1C1 = "=R[-7]C+R[-9]C" 'posiciones iniciales del vector = final del vector anterior ActiveSheet.Cells(m + 7, n).FormulaR1C1 = "=R[-7]C+R[-9]C" ActiveSheet.Cells(m + 7, n + 1).FormulaR1C1 = "=R[-7]C+R[-9]C" 'Segment InitVector-07. Control panel format Range(Cells(m + 3, n - 1), Cells(m + 11, n + 1)).Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With With Selection .HorizontalAlignment = xlCenter End With Cells(m + 3, n + 1).Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThick End With Cells(m + 4, n + 1).Select With Selection.Borders(xlEdgeLeft) .LineStyle = xlDashDot .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlDashDot .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlDashDot .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlDashDot .ThemeColor = 2 .TintAndShade = 0.249977111117893 .Weight = xlThin End With Range(Cells(m + 4, n - 1), Cells(m + 11, n + 1)).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 End With Range(Cells(m + 3, n - 1), Cells(m + 3, n)).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = 0.799981688894314 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorLight1 .TintAndShade = 0 End With Application.Union(Range(Cells(m + 7, n - 1), Cells(m + 7, n + 1)), Range(Cells(m + 9, n - 1), Cells(m + 9, n + 1))).Select With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorAccent6 .TintAndShade = -0.249977111117893 .PatternTintAndShade = 0 End With With Selection.Font .ThemeColor = xlThemeColorDark1 .TintAndShade = 0 End With Cells(m + 3, n + 1).Select ' Color for each vector (different color). With Selection.Interior .Pattern = xlSolid .PatternColorIndex = xlAutomatic .ThemeColor = xlThemeColorLight1 .TintAndShade = 0.5 .Color = RGB(Int((255 * Rnd) + 1), Int((255 * Rnd) + 1), Int((1 * Rnd) + 255)) .PatternTintAndShade = 0 End With Cells(m1 + 1, n1 + 1).Value = "A" & Cells(m + 3, n - 1).Value + 1 NoVector: 'Segment InitVector-08.Download projects from the project list Lang = "_" & Lang If VecType = 2 Then Lang = "" If VecType = 15 Then Lang = "" If VecType > 1 Then Dim strMacro As String strMacro = "Project_" & VecType & Lang Application.Run strMacro, VecType, m, n, m1, n1 End If Application.ScreenUpdating = True End Sub Sub AddNewVector() '© 2022 A Becerra. ScienSolar.com Dim fila As Range Dim m As Integer Dim n As Integer Dim A As Integer Set fila = ActiveSheet.Cells.Find(What:="INICIO") m = fila.Offset(1, 0).Row n = fila.Offset(1, 1).Column Set fila = Nothing Call InitVector(m, n) End Sub Sub VectorOutput(m, n, s, cod As Integer, Y_abs, Z_abs, xS As Single, T_color As Double) '© 2022 A Becerra. ScienSolar.com 'Procedure to Display a single vector in XYZ 'Segment VectorOutput-01. Vector parameters variables Dim T_top Dim T_left Dim T_name Dim T_label Dim L_width As Single Dim L_height As Single Dim Lo_width As Single Dim Lo_height As Single Dim HeightColor As Variant Dim sh As Object Dim Module As Double T_name = ActiveSheet.Cells(m + 3, n).Value & ActiveSheet.Cells(m + 3, n - 1).Value T_label = ActiveSheet.Cells(m + 3, n).Value Lox = ActiveSheet.Cells(m + 7, n - 1).Value * xS 'Position of the vector in X. Obs. :it is not the component of L (axes) but of an arbitrary vector Loy = ActiveSheet.Cells(m + 7, n).Value * xS 'Position of the vector in Y. Obs. :it is not the component of L (axes) but of an arbitrary vector Loz = ActiveSheet.Cells(m + 7, n + 1).Value * xS 'Position of the vector in X. Obs. :it is not the component of L (axes) but of an arbitrary vector Lx = ActiveSheet.Cells(m + 9, n - 1).Value * xS 'Compponent in X of the vector Ly = ActiveSheet.Cells(m + 9, n).Value * xS 'Compponent in Y of the vector Lz = ActiveSheet.Cells(m + 9, n + 1).Value * xS ''Compponent in Z of the vector Module = Sqr((Lx / xS) ^ 2 + (Ly / xS) ^ 2 + (Lz / xS) ^ 2) ' Module of the vector 'Segment VectorOutput-02. If the size of the vector exceeds the size of the axes, then regulate its length with the help of a function and parameters entered by the user (>15) If Cells(m + 5, n).Value > 15 Then Dim L_ref As Single ' Max lenght of the vector(first parameter) Dim L_tau As Single ' How the lenght of the vectors changes. L_ref = Left(Cells(m + 5, n).Value, InStr(1, Cells(m + 5, n).Value, "*", 0) - 1) - 14 L_tau = L_ref * Mid(Cells(m + 5, n).Value, InStr(1, Cells(m + 5, n).Value, "*", 0) + 1) Lx = L_ref * (1 - 1 / Exp(Abs(Lx / L_tau))) * Lx / Module / xS ' updated 07-2024, added / xS in order to big scales to work properly. Ly = L_ref * (1 - 1 / Exp(Abs(Ly / L_tau))) * Ly / Module / xS Lz = L_ref * (1 - 1 / Exp(Abs(Lz / L_tau))) * Lz / Module / xS ActiveSheet.Range("K6").Value = "Some vectors have been R E D U C E D! Set the scale in cell " & Cells(m + 5, n).Address(0, 0) End If L_width = Cos(A) * (Lx * Sin(C) + Ly * Cos(C)) - Sin(A) * (-Sin(B) * (Lx * Cos(C) - Ly * Sin(C)) + Lz * Cos(B)) L_height = Sin(A) * (Lx * Sin(C) + Ly * Cos(C)) + Cos(A) * (-Sin(B) * (Lx * Cos(C) - Ly * Sin(C)) + Lz * Cos(B)) Lo_width = Cos(A) * (Lox * Sin(C) + Loy * Cos(C)) - Sin(A) * (-Sin(B) * (Lox * Cos(C) - Loy * Sin(C)) + Loz * Cos(B)) Lo_height = Sin(A) * (Lox * Sin(C) + Loy * Cos(C)) + Cos(A) * (-Sin(B) * (Lox * Cos(C) - Loy * Sin(C)) + Loz * Cos(B)) 'Segment VectorOutput-03. Data storage to graph trajectory. If Cells(m + 3, n - 1).Value = Sheets("CONFIG").Range("V6").Value Then ' Verify that the current is the vector to be graphed Sheets("CONFIG").Range("V6").Offset(1, -1).Value = "DATOS DE LA FORMA LIBRE - puntos horizontales y verticales" Z = 1 Do While Sheets("CONFIG").Cells(6 + Z, 21).Value <> "" Z = Z + 1 Loop Sheets("CONFIG").Cells(6 + Z, 21).Value = Lo_width + L_width 'Cell where the y coordinate of each point of the free form is stored Sheets("CONFIG").Cells(6 + Z, 22).Value = -Lo_height - L_height 'Cell where the z coordinate of each point is stored 'Stops plotting after set value of steps If Z - 2 > Sheets("CONFIG").Range("T5") Then Sheets("CONFIG").Columns("U:V").ClearContents ActiveSheet.Range(ActiveSheet.Buttons("ResetGraph").TopLeftCell.Offset(1, 1).Address).Value = 2 'it does not erase the graph already drawn End If End If 'Segment VectorOutput-04. Selection of the shape according to cod. If cod < 0 Then cod = -cod L_width = Cells(m + 9, n) * xS L_height = Cells(m + 9, n + 1) * xS Lo_width = Cells(m + 7, n) * xS Lo_height = Cells(m + 7, n + 1) * xS End If 'Segment VectorOutput-05. Graphic case. Draw a freeform with the points collected in Segment VectorOutput-03. If cod = 186 Then With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, Y_abs + Sheets("CONFIG").Cells(8, 21).Value, Z_abs + Sheets("CONFIG").Cells(8, 22).Value) i = 1 Do While Sheets("CONFIG").Cells(7 + i, 21) <> "" .AddNodes msoSegmentCurve, msoEditingAuto, Y_abs + Sheets("CONFIG").Cells(7 + i, 21).Value, Z_abs + Sheets("CONFIG").Cells(7 + i, 22).Value i = i + 1 Loop .ConvertToShape.name = "campo0" ' crea una forma de tipo 5 End With Else ' if not 186 'Segment VectorOutput-06 Integrate a 3D object. To integrate a 3D object enter code 200. If cod = 200 Or cod = 201 Then 'Number for 3D objects. The name of the 3D object must be in the vector name cell and the object must be in the 3D Models spreadsheet. Dim name3D As String name3D = Cells(m + 3, n).Value If Cells(m + 3, n + 1) <> "" And Cells(m + 3, n + 1).Value <> name3D Then ActiveSheet.Shapes(Cells(m + 3, n + 1).Value).Delete End If CheckExists (name3D) If CheckExists(name3D) = False Then Sheets("3DModels").Shapes(name3D).Copy ActiveSheet.Paste Cells(m + 3, n + 1).Select Selection.Value = name3D Else If s > 1 Then ActiveSheet.Shapes(Cells(m + 3, n).Value).Copy ActiveSheet.Paste Selection.name = "campo" & Cells(m + 3, n - 1).Value & "_" & s name3D = "campo" & Cells(m + 3, n - 1).Value & "_" & s End If End If With ActiveSheet.Shapes(name3D) If .Type = 30 Or .Type = 13 Then ' 30 for Mac 13 for Win. Only for 3D objects If Left(Application.Version, 2) < 16 Then ' Warning about old Excel vrsions Range("N10").Value = "(Your version of Excel may not support 3D models. Please, update to 2019 or later!!)" End If .Width = -1 ' To fix error If Cells(m + 5, n).Value > 0 Then .Width = Cells(m + 5, n) * xS .Height = Cells(m + 5, n) * xS Cells(m + 5, n + 1).Value = Cells(m + 5, n).Value End If Else ' Other objects Cells(m + 3, n + 1).Value = "" If .Type = 17 Then ' To color formulas. .TextFrame2.TextRange.Font.Fill.ForeColor.RGB = Cells(m + 3, n + 1).Interior.Color End If End If If cod = 201 Then 'Freeze size in text area .Left = Y_abs + ActiveSheet.Cells(m + 7, n).Value .Top = Z_abs - ActiveSheet.Cells(m + 7, n + 1).Value Else .Left = Y_abs + Lo_width .Top = Z_abs - Lo_height .Model3D.RotationX = ActiveSheet.Range("G5").Value + ActiveSheet.Cells(m + 6, n - 1).Value .Model3D.RotationY = -ActiveSheet.Range("G6").Value + ActiveSheet.Cells(m + 6, n).Value .Model3D.RotationZ = -ActiveSheet.Range("G4").Value + ActiveSheet.Cells(m + 6, n + 1).Value End If End With 'If s = 1 Then 'Selection.name = ActiveSheet.Cells(m + 3, n) 'Comment to get story 'End If ActiveSheet.Cells(m + 5, n).Value = 0 ActiveSheet.Cells(5, 9).Select Else ' neither 200 nor 201 Set sh = ActiveSheet.Shapes.AddShape(cod, Y_abs, Z_abs, 20, 40) 'otras formas sh.name = "campo0" End If End If ' end if 186 'Segment VectorOutput-07. Vector appearance. HeightColor = Cells(m + 3, n + 1).Interior.Color If ActiveSheet.Cells(m + 4, n + 1).Value <> "" Then ' updated 05-2023 Atemp = InStr(ActiveSheet.Cells(m + 4, n + 1).Value, "color=") + 7 ' updated 05-2023 Btemp = InStr(Atemp, ActiveSheet.Cells(m + 4, n + 1).Value, "]", 1) Ctemp = Btemp - Atemp ' May 2023 RedCod = Format((HeightColor Mod 256), "00") 'Current color GreenCod = Format(((HeightColor \ 256) Mod 256), "00") 'Current color BlueCod = Format((HeightColor \ 65536), "00") 'Current color ' Color according to the magnitude of the vector: Lmax = Mid(ActiveSheet.Cells(m + 4, n + 1).Value, Atemp, Ctemp) If Lmax = "0" Then ' Leave current color HeightColor = Cells(m + 3, n + 1).Interior.Color Else ' Gradient If Module < Lmax / 4 Then HeightColor = RGB(255, _ Abs(Left(Round(Module * 255 / (Lmax / 4), 0), 3)), _ 0) End If If Module > Lmax / 4 And Module < Lmax / 2 Then HeightColor = RGB(Abs(255 - Left(Round(Module * 255 / (Lmax / 4), 0), 3)), _ 255, _ 0) End If If Module > Lmax / 2 And Module < Lmax * 3 / 4 Then HeightColor = RGB(0, _ 255, _ Abs(Left(Round(Module * 255 / (Lmax / 4), 0), 3))) End If If Module > Lmax * 3 / 4 Then HeightColor = RGB(0, _ Abs(255 - Left(Round(Module * 255 / (Lmax / 4), 0), 3)), _ 255) End If End If End If 'Segment VectorOutput-08. If it is not a vector but a point. set dimensions = 1. If cod = 146 Or cod = 9 Then ' updated 04.2024 L_width = 1 L_height = 1 End If 'Vector properties On Error Resume Next ' no todas las propiedades aplican para todas las formas With ActiveSheet.Shapes.Range(Array("campo0")) ' apariencia del vector .Line.BeginArrowheadStyle = Cells(m + 10, n - 1).Value .Line.EndArrowheadStyle = Cells(m + 11, n - 1).Value .Line.ForeColor.RGB = HeightColor .Line.Transparency = Cells(m + 5, n + 1).Value .Line.DashStyle = Cells(m + 5, n).Value .Line.Weight = Cells(m + 11, n + 1).Value 'Complementary properties of other forms. If cod < 183 Then .TextFrame2.TextRange.Characters.Text = Cells(m + 6, n - 1).Value .Fill.ForeColor.RGB = HeightColor ' color de relleno '.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = Cells(m + 3, n + 1).Font.Color. Uncomment to color frame .TextFrame2.TextRange.Font.Size = Cells(m + 3, n + 1).Value .ShapeRange.TextFrame2.WordWrap = msoTrue .ShapeRange.TextFrame2.AutoSize = msoAutoSizeShapeToFitText .Fill.Transparency = Cells(m + 5, n + 1).Value ' The position of the arrow head for shapes 109-114 is indicated in row =Cells(m + 6, n) and column =Cells(m + 6, n + 1), text =Cells(m + 6, n - 1) .Adjustments.Item(4) = -(Y_abs - (Cells(m + 6, n + 1).Value - 0.5) * 65 + Cells(m + 7, n).Value * xS) / (Cells(m + 9, n).Value * xS) ' arrow position, if applicable .Adjustments.Item(3) = 1 - (Z_abs - Cells(m + 6, n).Value * 15 - Cells(m + 7, n + 1).Value * xS) / (Cells(m + 9, n + 1).Value * xS) 'arrow position, if applicable End If End With 'Segment VectorOutput-09. Rename the vector and set position of the shape. With ActiveSheet.Shapes("campo0") .name = "campo" & Cells(m + 3, n - 1).Value & "_" & s If cod > 183 Then ' Free form case 'do nothing for a free form (graphic) Else .Width = Abs(L_width) .Height = Abs(L_height) .Left = Y_abs + Lo_width .Top = Z_abs - Lo_height - L_height If L_width < "0" Then .Left = .Left + L_width .Flip msoFlipHorizontal T_left = .Left - L_width / 2 Else T_left = .Left + L_width / 2 End If If L_height < "0" Then .Top = .Top + L_height .Flip msoFlipVertical T_top = .Top - L_height / 2 Else T_top = .Top + L_height / 2 End If End If ' End of cod > 183 End With 'Segment VectorOutput-10. Create the vector label. If T_label <> "" Then If s = 1 And cod <> 200 Then Call CreateLabel(T_left, T_top, Cells(m + 5, n + 1).Value, 20, T_color, T_name, T_label) End If End If Set sh = Nothing End Sub