napisał: rambobo
postów: 3
 umieszczony:
19 kwietnia 2005
21:42
|
|
Panowie wielkie dzięki!
Rambobo:o |
|
|
napisał:  admin
postów: 613
umieszczony:
18 kwietnia 2005
20:16
|
|
Makro już w serwisie, w dziale inne.
Dziękuję! |
|
|
napisał: pil
postów: 154
umieszczony:
18 kwietnia 2005
09:21
|
|
| W weekend dodałem obsługę segmentów łukowych. Gotowe makro wysłałem adminowi i może niedługo pojawi się dziale makra, ale jeżeli zależy Ci na tym żeby już je mieć napisz : sebastians@konto.pl |
|
|
napisał: rambobo
postów: 3
umieszczony:
17 kwietnia 2005
19:38
|
|
Pil dzięki Ci bardzo:) Jestem Ci dzwięczny do końca życia a nawet jeden dzień dłużej.
Pozdrawiam
Rambobo
PS: To olbrzymia oszczędność czasu |
|
|
napisał: pil
postów: 154
umieszczony:
13 kwietnia 2005
07:14
|
|
Polecenie ZMIERZ do tego się nie nadaje. Trzeba taką procedurę zrobić od początku i może wyglądać tak :
'wymaga by na rysunku był zdefiniowany blok "piketa" z atrybutem dis
Option Explicit
Const Pi = 3.141592654
Function ObliczKat(x1, y1, x2, y2) As Double
If x1 <= x2 Then
ObliczKat = (Atn((y2 - y1) / (x2 - x1)))
Else
ObliczKat = Pi + (Atn((y2 - y1) / (x2 - x1)))
End If
End Function
Function ObliczDlugosc(x1, y1, x2, y2) As Double
ObliczDlugosc = ((x2 - x1) ^ 2 + (y2 - y1) ^ 2) ^ 0.5
End Function
Private Sub WstawBlok(PunktWstawienia, atrybut, kat)
Dim blok As AcadBlockReference
Dim strBlok As String
strBlok = "pikieta" 'nazwa bloku
Set blok = ThisDrawing.ModelSpace.InsertBlock(PunktWstawienia, strBlok, 1, 1, 1, kat)
blok.GetAttributes
Dim varAttributes As Variant
varAttributes = blok.GetAttributes
varAttributes(0).TextString = atrybut
Set blok = Nothing
End Sub
Public Sub PobierzPolilinie()
Dim selekcja As AcadSelectionSet
Dim polilinia As AcadObject
Dim wierzcholki As Variant
Dim iloscWierzcholkow As Integer
Dim xtemp, ytemp, xend, yend As Double
Dim kat, katObrotu, wypuklosc, dlugoscSegmentu, dlugosc As Double
Dim PunktWstawienia(0 To 2) As Double
Dim reszta As Double
Dim index As Integer
Dim rozstaw, przyrost As Double
'wartości startowe
rozstaw = 25 'pikieta co 25 jednostek
index = 0
dlugosc = 0
'wybór obiektu na ekranie
Set selekcja = ThisDrawing.SelectionSets.Add("Nowa Selekcja")
On Error GoTo Koniec
selekcja.SelectOnScreen
Set polilinia = selekcja(0) 'przypisanie jak chłop do miedzy
'pierwszego wskazanego elementu do obiektu "polilinia"
'Czy wskazany obiekt jest poliliniš
If polilinia.ObjectName = "AcDbPolyline" Then
'MsgBox "Wybrałeś polilinię"
wierzcholki = polilinia.Coordinates
'ilość wierzchołków przy indeksowaniu od 0
iloscWierzcholkow = (UBound(wierzcholki) + 1) / 2 - 1
For index = 0 To (iloscWierzcholkow - 1) ' iteracja do przedostatniego wierzchołka
dlugoscSegmentu = 0
'współrzędne bierzšcego wierzchołka
xtemp = wierzcholki(2 * index): ytemp = wierzcholki(2 * index + 1)
'współrzędne następnego wierzchołka
xend = wierzcholki(2 * index + 2): yend = wierzcholki(2 * index + 3)
kat = ObliczKat(xtemp, ytemp, xend, yend)
'ustawienie kšta obrotu bloku
wypuklosc = polilinia.GetBulge(index)
If wypuklosc = 0 Then
dlugoscSegmentu = ObliczDlugosc(xtemp, ytemp, xend, yend)
If xtemp <= xend Then
katObrotu = kat
Else
katObrotu = kat + Pi
End If
Else
'dlugoscSegmentu z osobnej funkcji
MsgBox "Sorry, chwilowo nie działa"
Exit Sub
End If
przyrost = reszta 'wartosc starowa przyrostu reszta z poprzedniej iteracji
Do While przyrost <= dlugoscSegmentu
If wypuklosc = 0 Then
PunktWstawienia(0) = xtemp + (przyrost) * Cos(kat)
PunktWstawienia(1) = ytemp + (przyrost) * Sin(kat)
PunktWstawienia(2) = 0
Call WstawBlok(PunktWstawienia, (dlugosc + przyrost), katObrotu)
Else
'tutaj obsługa dla segmentów łukowych
End If
przyrost = przyrost + rozstaw
Loop
'obliczenie do odłożenia na następnym segmencie
reszta = Abs(dlugoscSegmentu - przyrost)
dlugosc = dlugosc + dlugoscSegmentu
Next index
Else
MsgBox "cokolwiek wybrałeś nie jest poliliniš"
End If
Koniec:
selekcja.Delete
Set polilinia = Nothing
End Sub
Wygama, żeby na rysunku był blok z atrubutem o nazwie "pikieta. Narazie działa tylko na łamanej, ale ponieważ to wersja "rozwojowa" docelowo będzie obsługiwała odcinki łuków. |
|
|
napisał: rambobo
postów: 3
umieszczony:
8 kwietnia 2005
21:55
|
|
Witam! Poszukuje wskazówki jak w VB w AutiCAD wykonać polecenie rysuj>punkt>zmierz ze wstawianiem bloku. Chodzi mi o wstawienie wielu bloków ze zmiennymi opisami prostopadle do np. polilini w stałej odległości. Niestety podobna procedura Trasowanie linii dostępna w Landzie nie wstawia opisów. Rozwiązanie tego problemu to olbrzymia oszczędność czasu dla mnie. Z góry dziękuję za wskazówki.
Pozdrawiam
Rambobo |
|
|
 wstecz 1 dalej  wszystkich stron: 1
|
