Community
I want to change the text size and the arrow size in the dimension.
Sub DodajWymiarowanie(fileNumber As Integer)
Dim lastRow As Long
Dim i As Long
Dim firstDataRow As Long
Dim wymiar As String
Dim odleglosc As Double
Dim roznicaY As Double
' Znajdź pierwszy i ostatni wiersz z danymi w kolumnie B i C
firstDataRow = 13 ' Ustalenie startu od wiersza 13
lastRow = Cells(Rows.Count, 2).End(xlUp).Row ' Ostatni wiersz z danymi w kolumnie B
' Dodanie wymiarowania liniowego w pliku DXF
For i = firstDataRow To lastRow
' Sprawdzenie, czy są dane w kolumnach B, C oraz I, J, oraz pomijanie pierwszego i ostatniego wiersza
If i <> firstDataRow And i <> lastRow Then
If IsNumeric(Cells(i, 2).Value) And IsNumeric(Cells(i, 3).Value) And IsNumeric(Cells(i, 9).Value) And IsNumeric(Cells(i, 10).Value) Then
' Oblicz odległość między punktami
odleglosc = Sqr((Cells(i, 9).Value - Cells(i, 2).Value) ^ 2 + (Cells(i, 10).Value - Cells(i, 3).Value) ^ 2)
' Obliczenie różnicy między wartościami Y z kolumny C i J
roznicaY = Cells(i, 3).Value - Cells(i, 10).Value
' Zaokrąglenie odległości do najbliższych 5 cm i dodanie minusa lub plusa w zależności od różnicy
If roznicaY < -0.024999 Then
wymiar = "-" & FormatZaokraglenieDo5cm(odleglosc) & "m" ' Dodanie minusa, jeśli różnica jest ujemna
Else
wymiar = FormatZaokraglenieDo5cm(odleglosc) & "m" ' Standardowy wymiar, jeśli różnica jest dodatnia
End If
' Dodaj wymiarowanie pomiędzy punktami
Print #fileNumber, "0"
Print #fileNumber, "DIMENSION"
Print #fileNumber, "8"
Print #fileNumber, "WYMIAROWANIE"
' Ustawienie koloru na niebieski (DXF color code 5)
Print #fileNumber, "62"
Print #fileNumber, "5" ' Kod koloru dla niebieskiego
Print #fileNumber, "100"
Print #fileNumber, "AcDbAlignedDimension"
' Środkowy punkt wymiarowania (gdzie pojawi się tekst wymiarowy)
Print #fileNumber, "10" ' Punkt wymiarowy X
Print #fileNumber, Replace(Format((Cells(i, 2).Value + Cells(i, 9).Value) / 2, "0.000"), ",", ".")
Print #fileNumber, "20" ' Punkt wymiarowy Y
Print #fileNumber, Replace(Format((Cells(i, 3).Value + Cells(i, 10).Value) / 2, "0.000"), ",", ".")
Print #fileNumber, "30" ' Współrzędna Z
Print #fileNumber, "0.0"
' Dodaj wartość wymiaru z powiększeniem
Print #fileNumber, "1" ' Tekst wymiarowy
Print #fileNumber, "\H11.1111111111x;" & wymiar ' Dodanie wymiaru po zaokrągleniu i powiększenia
' Punkty bazowe (Początkowy i końcowy punkt wymiarowania)
Print #fileNumber, "13" ' Punkt początkowy X
Print #fileNumber, Replace(Format(Cells(i, 2).Value, "0.000"), ",", ".")
Print #fileNumber, "23" ' Punkt początkowy Y
Print #fileNumber, Replace(Format(Cells(i, 3).Value, "0.000"), ",", ".")
Print #fileNumber, "33"
Print #fileNumber, "0.0" ' Z
Print #fileNumber, "14" ' Punkt końcowy X
Print #fileNumber, Replace(Format(Cells(i, 9).Value, "0.000"), ",", ".")
Print #fileNumber, "24" ' Punkt końcowy Y
Print #fileNumber, Replace(Format(Cells(i, 10).Value, "0.000"), ",", ".")
Print #fileNumber, "34"
Print #fileNumber, "0.0" ' Z
' Wartość wymiaru
Print #fileNumber, "50" ' Kąt wymiarowania
Print #fileNumber, "0.0"
' Wymiarowanie wyśrodkowane
Print #fileNumber, "70" ' Flaga wymiarowania (aligned)
Print #fileNumber, "1" ' Aligned dimension
' Zakończ wymiarowanie
Print #fileNumber, "0"
Print #fileNumber, "SEQEND"
End If
End If
Next i
End Sub
Function FormatZaokraglenieDo5cm(wartosc As Double) As String
' Zaokrąglanie wartości do najbliższych 5 cm (0.05 metra)
Dim zaokraglonaWartosc As Double
zaokraglonaWartosc = Round(wartosc * 20, 0) / 20
' Sprawdzenie, czy liczba kończy się na .05 lub .15 (itd.) - wtedy pokazujemy dwa miejsca po przecinku
If zaokraglonaWartosc * 100 Mod 10 = 5 Then
FormatZaokraglenieDo5cm = Format(zaokraglonaWartosc, "0.00") ' Dwa miejsca po przecinku
Else
' W przeciwnym wypadku pokazujemy jedno miejsce po przecinku
FormatZaokraglenieDo5cm = Format(zaokraglonaWartosc, "0.0")
End If
End Function
‐--------------------
I've tried this:
Print #fileNumber, "\H11.1111111111x;"` ' It works, but it's not the proper method for further text processing.
' Ustawienie wysokości tekstu dla każdego wymiaru
Print #fileNumber, "40"
Print #fileNumber, "4.0" ' Wysokość tekstu ustawiona na 4 jednostki` - doesn't work
Const DEFAULT_FONT_SIZE As Double = 2.0
Print #fileNumber, "9"
Print #fileNumber, "$DIMTXT"
Print #fileNumber, "40"
Print #fileNumber, "2.0"
Can't find what you're looking for? Ask the community or share your knowledge.