How to create this pattern? (image)

[Anonymous]

Hi everyone,

I have this code that should create the same pattern as in the image. For some reason I get an error message here if I enter an even value at txtVloeren (the vertical integer). It seems that it only works with half of the odd numbers (3, 7, 11, 15, ...).
I don't know how to fix this. Could someone help me with this?
Thank you in advance.

Koo

pattern

Private Sub UserForm_Activate()

    Dim Vloer As Integer  'horizontal integer
    Dim Vak As Integer      'vertical integer
    Dim i As Integer
    Dim R As Integer
    Dim C As Acad3DSolid
    Dim P As AcadPoint
        
    Dim pt1 As Variant
    Dim pt2 As Variant
    Dim pt As Variant
    
    txtBreedteModules = 3
    txtHoogteModules = 2
    txtStartHoogte = 0.2
    txtVloeren = 7
    txtVakken = 5
        
    cboRichting.AddItem "+X", 0
    cboRichting.AddItem "+Y", 1
    cboRichting.AddItem "-X", 2
    cboRichting.AddItem "-Y", 3

    cboRichting.ListIndex = 0
               
End Sub


Private Sub cmdC_Click()
   Me.Hide
   
Dim strRichting As String
strRichting = cboRichting.Text
   
Vloer = 1
Vak = 1
i = 1
R = 150

pt = ThisDrawing.Utility.GetPoint(, "Selecteer linkeronderzijde van de gevel:")
Set P = ThisDrawing.ModelSpace.AddPoint(pt)
pt(2) = pt(2) + Val(txtStartHoogte.Text) * 1000
Set P = ThisDrawing.ModelSpace.AddPoint(pt)
pt1 = pt
pt2 = pt


    Do Until Vak > Val(txtVakken.Text)
            Do Until Vloer * 2 > Val(txtVloeren.Text)
                If i Mod 2 = 1 Then
                    Set C = ThisDrawing.ModelSpace.AddSphere(pt1, R)
                End If
                pt1(2) = pt1(2) + Val(txtBreedteModules.Text) * 1000 * 2 'change Z
                Vloer = Vloer + 1
                i = i + 1
            Loop
        If Val(txtVloeren.Text) Mod 2 = 0 Then
            i = i + 1
        End If
    
        pt1(2) = pt2(2)
        
        If strRichting = "+X" Then
            pt1(0) = pt2(0) + Val(txtBreedteModules.Text) * 1000 'change x
        End If
        If strRichting = "+Y" Then
            pt1(1) = pt2(1) + Val(txtBreedteModules.Text) * 1000 'change y
        End If
        If strRichting = "-X" Then
            pt1(0) = pt2(0) - Val(txtBreedteModules.Text) * 1000 'change x
        End If
        If strRichting = "-Y" Then
            pt1(1) = pt2(1) - Val(txtBreedteModules.Text) * 1000 'change y
        End If
        
        pt2 = pt1
        Vloer = 1
        Vak = Vak + 1
    Loop
End Sub

[grobnik]

Hi @Anonymous 

I tried to transform your code in a without form version, due to I haven't your user form, but I have some difficulties. Seems that all objects will be overlapped one on the second and so on.

In any case, I just give you the suggestion to check the text conversion if entering text that have not an integer value.

Use break point in the sub, and go ahead step by step and in the same time use debug watching window.

Regards

[Anonymous · Accepted solution]

Hey @grobnik ,

I did it. I think based on the code I wrote, I'm able to create any pattern. I've also simplified the code to avoid unnecessary complexity.

 

Private Sub Ok_Click()
   Me.Hide
    Dim V As Integer  'vertical integer
    Dim H As Integer  'horizontal integer
    Dim i As Integer  'vertical integer that resets
    Dim R As Integer
    Dim P As AcadPoint
    Dim pt1 As Variant
    Dim pt2 As Variant
    Dim pt As Variant

V = 1
H = 1
i = 1

pt = ThisDrawing.Utility.GetPoint(, "select lower left point:")
pt1 = pt
pt2 = pt

    Do Until H > Val(txtWidth.Text)
        If H Mod 2 = 1 Then  'H = odd
            Do Until V > Val(txtHeight.Text)
                If i = 1 Then
                    Set P = ThisDrawing.ModelSpace.AddPoint(pt1)
                End If
                pt1(2) = pt1(2) + 1 'change Z
                V = V + 1
                i = i + 1
                If i = 5 Then 'reset i after i = 4
                    i = 1
                End If
            Loop
        Else                'H = even
            Do Until V > Val(txtHeight.Text)
                If i = 3 Then
                    Set P = ThisDrawing.ModelSpace.AddPoint(pt1)
                End If
                pt1(2) = pt1(2) + 1 'change Z
                V = V + 1
                i = i + 1
                If i = 5 Then
                    i = 1
                End If
            Loop
        End If
        pt1(2) = pt2(2) 'reset z
        pt2 = pt1
        V = 1
        i = 1
        pt1(0) = pt2(0) + 1 'change x
        H = H + 1
    Loop
End Sub

[parikhnidi]

Hi,

Please see the following solution. Here I've added flexibility to rotate your pattern to any angle.

Please tie all variable values I hard coded here with the text box values of your dialog box.

Nimish

Public Function DrawPattern()
    
    Dim HorCount As Long
    Dim VerCount As Long
    Dim HDistance As Double
    Dim VDistance As Double
    Dim SphereRad As Double
    Dim AllDots As Boolean
    Dim FirstSphere As Boolean
    
    Dim RotAng As Double
    RotAng = 0
    
    Dim pi As Double
    pi = 4 * Atn(1)
    
    HorCount = 8
    VerCount = 10
    HDistance = 250
    VDistance = 300
    SphereRad = 150
    
    
    Dim ind As Long
    
    Dim llc As Variant
    
    llc = ThisDrawing.Utility.GetPoint(, "Select lower left corner: ")
    
    For ind = 1 To VerCount
        
        llc = ThisDrawing.Utility.PolarPoint(llc, RotAng + pi / 2, VDistance)
        
        If ind Mod 2 = 0 Then
            AllDots = True
        Else
            AllDots = False
        End If
        
        If (ind - 1) Mod 4 = 0 Then
            FirstSphere = True
        Else
            FirstSphere = False
        End If
        
        DrawHorPatten llc, HDistance, RotAng, SphereRad, HorCount, AllDots, FirstSphere
        
    Next ind

End Function
'===================================
'This function will draw a geneaic pattern
'===================================
Public Sub DrawHorPatten(StartPoint As Variant, Distance As Double, RotationAngle As Double, SphereRad As Double, PatternCount As Long, AllDots As Boolean, FirstSphere As Boolean)
    
    Dim i As Long
    Dim Pos As Variant
    Dim sphere As Acad3DSolid
    Dim point As AcadPoint
    
    
    For i = 1 To PatternCount
    
        pos = ThisDrawing.Utility.PolarPoint(StartPoint, RotationAngle, Distance * (i - 1))
        
        If Not AllDots Then
            If FirstSphere Then
                Set sphere = ThisDrawing.ModelSpace.AddSphere(pos, SphereRad)
                sphere.Update
            Else
                Set point = ThisDrawing.ModelSpace.AddPoint(pos)
                point.Update
            End If
        Else
            Set point = ThisDrawing.ModelSpace.AddPoint(pos)
            point.Update
        End If
        
        FirstSphere = Not FirstSphere
    
    Next i
    Set sphere = Nothing
    Set point = Nothing
End Sub