Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- Option Explicit
- Dim swApp As Object
- Dim Part As Object
- Dim skSegment As Object
- Dim boolstatus As Boolean
- Dim longstatus As Long
- Dim tabx(1000) As Double
- Dim taby(1000) As Double
- Dim tabz(1000) As Double
- Dim length As Double
- Dim boole As Boolean
- Dim n As Integer
- Dim radius As Double
- Dim securityradius As Double
- Dim dist As Double
- Dim MatrixVolume As Integer
- Dim FibersVolume As Integer
- Dim MatrixVolumeFract As Double
- Dim FibersVolumeFract As Double
- Dim MatrixVolumeFractP As Integer
- Dim FibersVolumeFractP As Integer
- Dim EffectiveTC As Double
- Dim err As Long
- Dim war As Long
- Dim bool As Boolean
- Dim name As String
- Dim swmodel As Object
- Private Sub LengthTextBox_Enter()
- 'Delete indication text
- If LengthTextBox.Value = "Length of RVE" Then
- LengthTextBox.Value = ""
- End If
- End Sub
- Private Sub RadiusTextBox_Enter()
- 'Delete indication text
- If RadiusTextBox.Value = "Radius of inclusions" Then
- RadiusTextBox.Value = ""
- End If
- End Sub
- Private Sub NumbersTextBox_Enter()
- 'Delete indication text
- If NumbersTextBox.Value = "Numbers of inclusions" Then
- NumbersTextBox.Value = ""
- End If
- End Sub
- Private Sub CalculateButton_Click()
- If LengthTextBox.Value = "Length of RVE" Or LengthTextBox.Value = "" Or RadiusTextBox.Value = "Radius of inclusions" Or RadiusTextBox.Value = "" Or NumbersTextBox.Value = "Numbers of inclusions" Or NumbersTextBox.Value = "" Then
- MsgBox "Please fill all the fields !", vbCritical, "Error"
- Else
- 'Show calculate zone
- UserForm1.Height = 489.75
- 'Calculate volume fraction
- MatrixVolume = LengthTextBox.Value * LengthTextBox.Value * LengthTextBox.Value
- FibersVolume = (4 * Atn(1)) * (RadiusTextBox.Value ^ 2) * LengthTextBox.Value * NumbersTextBox.Value
- FibersVolumeFract = FibersVolume / MatrixVolume
- MatrixVolumeFract = 1 - FibersVolumeFract
- MatrixVolumeFractP = MatrixVolumeFract * 100
- FibersVolumeFractP = FibersVolumeFract * 100
- MatrixV.Caption = MatrixVolume
- FibersV.Caption = FibersVolume
- MatrixVF.Caption = MatrixVolumeFractP
- FibersVF.Caption = FibersVolumeFractP
- 'Calculate decimal thermal conductivity and round at 2
- EffectiveTC = (TCF.Value * FibersVolumeFract) + (TCM.Value * MatrixVolumeFract)
- ETC.Caption = Int(EffectiveTC * 10 ^ 2 + 1 / 2) / 10 ^ 2
- End If
- End Sub
- Private Sub GenerateButton_Click()
- 'Enregistrement
- 'identifier le chemin du dossier
- chemin_dossier = "C:\Users\Kader\Desktop\test123"
- 'vérifier l'existence du dossier et le créer
- If Dir(chemin_dossier, vbDirectory) <> vbNullString Then
- 'dossier exuste
- 'ne rien faire
- Else
- 'dossier n'existe pas, le créer
- MkDir (chemin_dossier)
- End If
- If LengthTextBox.Value = "Length of RVE" Or LengthTextBox.Value = "" Or RadiusTextBox.Value = "Radius of inclusions" Or RadiusTextBox.Value = "" Or NumbersTextBox.Value = "Numbers of inclusions" Or NumbersTextBox.Value = "" Then
- MsgBox "Please fill all the fields !", vbCritical, "Error"
- Else
- 'open new part
- Set swApp = Application.SldWorks
- Set Part = swApp.NewDocument("C:\ProgramData\SOLIDWORKS\SOLIDWORKS 2018\templates\Pièce.prtdot", 0, 0, 0)
- '3D sketch
- Part.SketchManager.Insert3DSketch (True)
- 'number of cylinder
- n = NumbersTextBox.Value
- 'length and radius
- length = LengthTextBox.Value / 1000
- radius = RadiusTextBox.Value / 1000
- securityradius = radius * 1.2
- 'random generate and no overlap
- Dim i, j As Integer
- For i = 1 To n
- Randomize Timer
- tabx(i) = Rnd * (length - securityradius * 2) + securityradius 'x position
- taby(i) = Rnd * (length - securityradius * 2) + securityradius 'y position
- boole = 0
- If (i <> 1) Then
- For j = 1 To i - 1
- dist = Sqrt((tabx(i) - tabx(j)) ^ 2 + (taby(i) - taby(j)) ^ 2)
- If (dist < 2.2 * radius) Then boole = 1
- Next j
- End If
- 'add point
- If (boole = 0) Then
- Dim skPoint As Object
- Set skPoint = Part.SketchManager.CreatePoint(tabx(i), taby(i), tabz(i))
- 'MsgBox tabx(i) & " " & taby(i) & " " & tabz(i)
- Else
- i = i - 1
- End If
- Next i
- 'circle insertion
- Set Part = swApp.ActiveDoc
- Part.SketchManager.InsertSketch True
- boolstatus = Part.Extension.SelectByID2("Plan de face", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
- Part.ClearSelection2 True
- Dim skSegment As Object
- Set skSegment = Part.SketchManager.CreateCircle(0#, 0#, 0#, radius, 0#, 0#)
- 'circle extrusion
- Dim myFeature As Object
- Set myFeature = Part.FeatureManager.FeatureExtrusion2(True, False, False, 0, 0, length, length, False, False, False, False, 0.01, 0.01, False, False, False, False, True, True, True, 0, 0, False)
- 'repetition by sketch
- boolstatus = Part.Extension.SelectByID2("Esquisse3D1", "SKETCH", 0, 0, 0, False, 64, Nothing, 0)
- boolstatus = Part.Extension.SelectByID2("Boss.-Extru.1", "SOLIDBODY", 0, 0, 0, True, 256, Nothing, 0)
- Part.FeatureManager.FeatureSketchDrivenPattern True, False
- 'delete the first revolution
- boolstatus = Part.Extension.SelectByID2("Boss.-Extru.1", "SOLIDBODY", 0, 0, 0, True, 0, Nothing, 0)
- Set myFeature = Part.FeatureManager.InsertDeleteBody2(False)
- 'hide the 3D sketch
- boolstatus = Part.Extension.SelectByID2("Esquisse3D1", "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
- Part.BlankSketch
- ' Save As REV
- longstatus = Part.SaveAs3("C:\Users\Kader\Desktop\test vba\RVE.SLDPRT", 0, 2)
- Set swmodel = swApp.ActiveDoc
- name = "RVE"
- bool = swmodel.Extension.SaveAs(name + ".sldprt", 0, 1, Nothing, err, war)
- End If
- '----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
- ' CUBE
- ' New Document part
- Set Part = swApp.NewDocument("C:\ProgramData\SOLIDWORKS\SOLIDWORKS 2018\templates\Pièce.prtdot", 0, 0, 0)
- boolstatus = Part.Extension.SelectByID2("Plan de face", "PLANE", 0, 0, 0, False, 0, Nothing, 0)
- Dim vSkLines As Variant
- vSkLines = Part.SketchManager.CreateCornerRectangle(0, 0, 0, 0.01, 0.01, 0)
- 'Dim myFeature As Object
- Set myFeature = Part.FeatureManager.FeatureExtrusion2(True, False, False, 6, 0, length, length, False, False, False, False, 0, 0, False, False, False, False, True, True, True, 0, 0, False)
- Part.ClearSelection2 True
- ' Save As CUBE
- longstatus = Part.SaveAs3("C:\Users\Kader\Desktop\test vba\CUBE.SLDPRT", 0, 2)
- Set swmodel = swApp.ActiveDoc
- name = "CUBE"
- bool = swmodel.Extension.SaveAs(name + ".sldprt", 0, 1, Nothing, err, war)
- '----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
- ' Ass
- ' New Document Ass
- Set Part = swApp.NewDocument("C:\ProgramData\SolidWorks\SOLIDWORKS 2018\templates\Assemblage.asmdot", 0, 0, 0)
- ' Insert Component CUBE
- Dim swInsertedComponent As Component2
- Set swInsertedComponent = Part.AddComponent5("C:\Users\Kader\Desktop\test vba\CUBE.SLDPRT", 0, "", False, "", 0, 0, 0)
- swApp.CloseDoc "C:\Users\Kader\Desktop\test vba\CUBE.sldprt"
- ' Insert Component RVE
- Set swInsertedComponent = Part.AddComponent5("C:\Users\Kader\Desktop\test vba\RVE.SLDPRT", 0, "", False, "", 0, 0, 0)
- swApp.CloseDoc "C:\Users\Kader\Desktop\test vba\RVE.sldprt"
- ' Named View
- Part.ShowNamedView2 "*Isométrique", 7
- Part.ViewZoomtofit2
- ' Save As CUBE
- longstatus = Part.SaveAs3("C:\Users\Kader\Desktop\test vba\Projet7.sldasm", 0, 2)
- Set swmodel = swApp.ActiveDoc
- name = "Projet7"
- bool = swmodel.Extension.SaveAs(name + ".sldasm", 0, 1, Nothing, err, war)
- End Sub
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement