Tile Horizontally

Hi, I make a VB6 form to interact with Acad 2002. I want Acad window and my form be arranged in "tile horizontally" mode. Any ideas how can I do this? Thanks

Diego Alejandro Talledo

 

Another thing, I want to make my form AlwaysOnTop, but I don't find any property such that for my form... Any ideas?

Thanks
Diego Alejandro Talledo

 

For the tiled portion, I'll pass on that one. You might want to consider a
different approach and use the ACCONT container control inside AutoCAD.

You need to learn Windows API calls to accomplish AlwaysOnTop with VB6.
Paste this code into your form and call SetOnTop during the forms Load
event:

'================BEGIN CODE BLOCK==========================
Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Private Sub SetOnTop(hWnd As Long, OnTop As Boolean)
Dim iReturn As Integer
iReturn = IIf(OnTop = True, _
SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS), _
SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS))
End Sub
'=================END CODE BLOCK===========================

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

"Paste this code into your form and call SetOnTop during the forms Load
event:"
"Private Sub SetOnTop(hWnd As Long, OnTop As Boolean)"
I think I have to write this

Private sub Form_load
SetOnTop HWND_TOPMOST, true
end sub

is that correct?

thank you very much for your help
regards Diego Alejandro Talledo

 

Almost - pass the form's handle

Private sub Form_load
SetOnTop Form.Hwnd, true
end sub

where FORM is the name of your form =)

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

I've tried, but my FrmTool isn't AlwaysOnTop...

 

Post your code for just the form

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

This is the code of FrmTool: it is a Toolbar with some functions I want to use in Acad.

Dim acadApp As AcadApplication
Dim acadDoc As AcadDocument
Dim punti(1 To 1000, 1 To 4) As Double
Dim puntiaux(1 To 1000, 1 To 4) As Double
Dim layerquota As Variant
Dim delta
Const pigreco = 3.14159265358979

Private Declare Function SetWindowPos Lib "user32" _
(ByVal hWnd As Long, ByVal hWndInsertAfter As Long, _
ByVal X As Long, ByVal Y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const SWP_NOMOVE = 2
Private Const SWP_NOSIZE = 1
Private Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2

Private Sub BtnAgg_Click()
Dim sset As AcadSelectionSet
Dim testo As AcadText
Dim mtesto As AcadMText
Dim punto(0 To 2) As Double

Set sset = acadDoc.SelectionSets.Add("Aggiuntivo")
AppActivate acadApp.Caption
sset.SelectOnScreen

For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadText Then
Set testo = sset.Item(i)
punto(0) = testo.InsertionPoint(0)
punto(1) = testo.InsertionPoint(1)
punto(2) = testo.InsertionPoint(2)
testo.TextString = testo.TextString & " (AGG)"
testo.Alignment = acAlignmentBottomCenter
testo.TextAlignmentPoint = punto
ElseIf TypeOf sset.Item(i) Is AcadMText Then
Set mtesto = sset.Item(i)
mtesto.TextString = mtesto.TextString & " (AGG)"
mtesto.AttachmentPoint = acAttachmentPointBottomCenter
End If
Next
sset.Delete
End Sub

Private Sub BtnClose_Click()
'Close application
acadApp.Quit
Unload Me
End Sub

Private Sub BtnComputo_Click()
Dim element As Variant
Dim Titolo As String 'Titolo in formato "Trave T 1.01 - 35 x 40"
Dim TitoloBrv As String 'Titolo in formato "T 1.01"
Dim PTot 'Peso totale del ferro del disegno
Dim MatFerri(0 To 1000, 1 To 4) '1=numero ferri - 2=diametro - 3=lunghezza - 4=peso

i = 0
For Each element In acadDoc.ModelSpace
If TypeOf element Is AcadText Then
stringa = element.TextString
If Len(stringa) > 14 And element.Layer = "PEN035" Then
'cerco ciò che mi serve: si tratta di sicuro del modello "4%%C16 p.1 L=570 (SUP)"
strtmp = stringa
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 37 Then ' NB: 37 = %
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
sitrova = False
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 43 Then ' NB 43 = +
sitrova = True
Exit For
End If
Next j
Dim stra, strb As Integer
If sitrova = True Then 'esiste il +
stra = Left(strtmp, j - 1)
strb = Right(strtmp, Len(strtmp) - j)
Else
stra = 0
strb = strtmp
End If
Dim numero As Integer
numero = stra + strb
MatFerri(i, 1) = numero
'Ho trovato quanti ferri sono
'Trovo di che diametro sono
strtmp = stringa
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 32 Then ' NB: 32 = Spazio
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If (Asc(tmp1) = 67) Or (Asc(tmp1) = 99) Then ' NB 67 = C / 99 = c
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
MatFerri(i, 2) = strtmp
'Ho trovato di che diametro sono
'Trovo la lunghezza
strtmp = stringa
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If (Asc(tmp1) = 61) Then ' NB 61 = =
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 32 Or Asc(tmp2) = 40 Then ' NB: 32 = Spazio / 40 = (
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
MatFerri(i, 3) = strtmp
'Trovata la lunghezza
i = i + 1
ElseIf Len(stringa) > 12 And element.Layer = "PEN050" Then
'Si tratta del titolo
strtmp = stringa
Titolo = strtmp
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 32 Then
Exit For
End If
Next j
strtmp = Right(strtmp, Len(strtmp) - (j - 1))
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 45 Then ' NB 45 = -
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
strtmp = Trim(strtmp)
TitoloBrv = strtmp
End If
ElseIf TypeOf element Is AcadMText Then
stringa = element.TextString
If Len(stringa) > 12 And element.Layer = "PEN035" Then
'cerco ciò che mi serve: si tratta del modello "4%%C16 p.1 L=570 (SUP)"
'o del modello a più righe "a) st.%%8/10 n. 19\P" e alla fine " L=160"
If Asc(stringa) >= 97 And Asc(stringa) <= 122 Then 'Modello a più righe
'cerco ciò che mi serve
strtmp = stringa
'Cerco la lunghezza
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If Asc(tmp1) = 61 Then ' NB 61 = =
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
lung = strtmp
'Trovata la lunghezza
strtmp = stringa
'Conto quante righe sono
nr = 0
Dim Vetspazi(1 To 15)
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 92 Then ' NB 92 = \
nr = nr + 1
Vetspazi(nr) = j - 1
End If
Next j
For k = 1 To nr
strtmp = stringa
strtmp = Left(strtmp, Vetspazi(k))
'trovo il confine sinistro
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If Asc(tmp1) = 92 Then
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
strtmp1 = strtmp
'trovo il diametro
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 47 Then ' NB: 47 = /
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If (Asc(tmp1) = 67) Or (Asc(tmp1) = 99) Then ' NB 67 = C / 99 = c
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
diam = strtmp
'trovo il numero
strtmp = strtmp1
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If (Asc(tmp1) = 32) Or (Asc(tmp1) = 46) Then ' NB 32 = Spazio / 46 = .
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
'Cerco se c'è qualche x
sitrova = False
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 120 Then ' NB 120 = x
sitrova = True
Exit For
End If
Next j
If sitrova = True Then 'esiste la x
stra = Left(strtmp, j - 1)
strb = Right(strtmp, Len(strtmp) - j)
Else
stra = 1
strb = strtmp
End If
num = stra * strb
'inserisco i dati nella matrice
MatFerri(i, 1) = num
MatFerri(i, 2) = diam
MatFerri(i, 3) = lung
i = i + 1
Next k

Else 'modello di prima
strtmp = stringa
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 37 Then ' NB: 37 = %
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
MatFerri(i, 1) = strtmp
'Ho trovato quanti ferri sono
'Trovo di che diametro sono
strtmp = stringa
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 32 Then ' NB: 32 = Spazio
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If (Asc(tmp1) = 67) Or (Asc(tmp1) = 99) Then ' NB 67 = C / 99 = c
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
MatFerri(i, 2) = strtmp
'Ho trovato di che diametro sono
'Trovo la lunghezza
strtmp = stringa
For j = 1 To Len(strtmp)
tmp1 = Right(strtmp, j)
If (Asc(tmp1) = 61) Then ' NB 61 = =
Exit For
End If
Next j
strtmp = Right(strtmp, j - 1)
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 32 Then ' NB: 32 = Spazio
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
MatFerri(i, 3) = strtmp
'Trovata la lunghezza
i = i + 1
End If
ElseIf Len(stringa) > 12 And element.Layer = "PEN050" Then
'Si tratta del titolo
strtmp = stringa
Titolo = strtmp
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 32 Then
Exit For
End If
Next j
strtmp = Right(strtmp, Len(strtmp) - (j - 1))
For j = 1 To Len(strtmp)
tmp1 = Left(strtmp, j)
tmp2 = StrReverse(tmp1)
If Asc(tmp2) = 45 Then ' NB 45 = -
Exit For
End If
Next j
strtmp = Left(strtmp, j - 1)
strtmp = Trim(strtmp)
TitoloBrv = strtmp
End If
End If
Next
'Sono stati inseriti tutti i dati in una matrice.
'Elaborazione dei dati e stampa su un file di testo????
'converto i mm della sez in cm e i cm della lung in m
n = i
For i = 0 To n - 1
MatFerri(i, 2) = MatFerri(i, 2) / 10
MatFerri(i, 3) = MatFerri(i, 3) / 100
Next
For i = 0 To n - 1
pf = ((pigreco * ((MatFerri(i, 2)) * (MatFerri(i, 2)))) / 4) * 0.785
MatFerri(i, 4) = MatFerri(i, 1) * MatFerri(i, 3) * pf
Next
'calcolo il peso totale
PTot = 0
For i = 0 To n - 1
PTot = PTot + MatFerri(i, 4)
Next
'converto i cm della sez in mm e i m della lung in cm
For i = 0 To n - 1
MatFerri(i, 2) = MatFerri(i, 2) * 10
MatFerri(i, 3) = MatFerri(i, 3) * 100
Next
'Salva tutto
nomefile = TitoloBrv & ".cmp"
Open nomefile For Output As #1
Write #1, Titolo
Write #1, TitoloBrv
Write #1,
For i = 0 To n - 1
Write #1, MatFerri(i, 1); MatFerri(i, 2); MatFerri(i, 3); MatFerri(i, 4)
Next
Close #1
End Sub

Private Sub BtnConnect_Click()
'
'Connection to AuotCAD
'If ACAD is open then connection
'else the program open an ACAD Application
'and connect
'
On Error Resume Next

Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox Err.Description
Exit Sub
End If
End If
MsgBox "Connected to " + acadApp.Name + _
" version " + acadApp.Version
'
'Connection to active document
'
Set acadDoc = acadApp.ActiveDocument
acadApp.Visible = True
End Sub

Private Sub BtnFind_Click()
FrmZoom.Show
End Sub

Private Sub BtnIron_Click()
'
'transform some iron lines
'in one polyline
'

Dim sset As AcadSelectionSet
Dim Linea As AcadLine
Dim ferro As AcadLWPolyline
Dim nomelayer As Variant
Dim n As Integer
Dim tuttoprima As Boolean
Dim s As String
Dim stringa As String

'Crea il selection set
Set sset = acadDoc.SelectionSets.Add("Ferro")
'Seleziona da schermo
AppActivate acadApp.Caption
sset.SelectOnScreen
'controllo che si tratti di linee, se lo sono le aggiungo
'alla matrice
n = 0
k = 0
For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadLine Then
Set Linea = sset.Item(i)
If Linea.Layer = "PEN050" Then
punti(k + 1, 1) = Linea.StartPoint(0)
punti(k + 1, 2) = Linea.StartPoint(1)
punti(k + 1, 3) = Linea.EndPoint(0)
punti(k + 1, 4) = Linea.EndPoint(1)
nomelayer = Linea.Layer
n = n + 1
k = k + 1
Linea.Delete
End If
ElseIf TypeOf sset.Item(i) Is AcadText Then
Dim testo As AcadText
Dim Titolo As AcadText
Dim stemp, stemp2

Set testo = sset.Item(i)
layerquota = sset.Item(i).Layer
s = testo.TextString
'Mi salvo la stringa che mi serve
If Len(s) > 7 Then
stringa = s
'Mi cerco ciò che mi serve dalla stringa
For h = 1 To Len(s)
stemp = Left(stringa, h)
stemp2 = StrReverse(stemp)
If Asc(stemp2) = 61 Then
Exit For
End If
Next h
stringa = Left(stringa, h)
Set Titolo = testo
Titolo.TextString = stringa
End If
'Fatto, ora cancello il testo se non mi serve
If Len(s) <= 7 Then
testo.Delete
End If
ElseIf TypeOf sset.Item(i) Is AcadMText Then
Dim mtesto As AcadMText
Dim mtitolo As AcadMText
Dim mstemp, mstemp2

Set mtesto = sset.Item(i)
layerquota = sset.Item(i).Layer
s = mtesto.TextString
If Len(s) > 7 Then
stringa = s
For h = 1 To Len(s)
mstemp = Left(stringa, h)
mstemp2 = StrReverse(mstemp)
If Asc(mstemp2) = 61 Then
Exit For
End If
Next h
stringa = Left(stringa, h)
Set mtitolo = mtesto
mtitolo.TextString = stringa
End If
If Len(s) <= 7 Then
mtesto.Delete
End If
End If
Next i

'Azzero PuntiAux
For i = 1 To 1000
For j = 1 To 4
puntiaux(i, j) = 0
Next j
Next i

'Inizio il processo di ordinamento
Dim nins As Integer
Dim prima As Integer

tuttoprima = True

prima = 1
Inizia:
'Azzero PuntiAux
For i = 1 To 1000
For j = 1 To 4
puntiaux(i, j) = 0
Next j
Next i
'Metto la primariga su PuntiAux
If tuttoprima Then
For i = 1 To 4
puntiaux(1, i) = punti(prima, i)
Next
Else
puntiaux(1, 1) = punti(prima, 3)
puntiaux(1, 2) = punti(prima, 4)
puntiaux(1, 3) = punti(prima, 1)
puntiaux(1, 4) = punti(prima, 2)
End If
k = 2
nins = 1
Ordina:
For i = 1 To n
If Not Giainserito(i, nins) Then
If (puntiaux(k - 1, 3) = punti(i, 3)) And (puntiaux(k - 1, 4) = punti(i, 4)) Then
puntiaux(k, 1) = punti(i, 3)
puntiaux(k, 2) = punti(i, 4)
puntiaux(k, 3) = punti(i, 1)
puntiaux(k, 4) = punti(i, 2)
nins = nins + 1
Exit For
End If
If (puntiaux(k - 1, 3) = punti(i, 1)) And (puntiaux(k - 1, 4) = punti(i, 2)) Then
For j = 1 To 4
puntiaux(k, j) = punti(i, j)
Next j
nins = nins + 1
Exit For
End If
End If
Next i
k = k + 1
If k > n Then
If nins < n Then
prima = prima + 1
If prima > n Then
prima = 1
If tuttoprima = True Then
tuttoprima = False
Else
GoTo errore
End If
End If
GoTo Inizia
Else
GoTo Disegno
End If
Else
GoTo Ordina
End If

'Matrice ordinata: ora creo i punti e i vertici della polilinea
Disegno:
Dim points(0 To 3) As Double
Dim vertex(0 To 1) As Double
For i = 0 To 3
points(i) = puntiaux(1, i + 1)
Next
Set ferro = acadDoc.ModelSpace.AddLightWeightPolyline(points)
For i = 2 To n
vertex(0) = puntiaux(i, 3)
vertex(1) = puntiaux(i, 4)
ferro.AddVertex i, vertex
Next
ferro.Layer = nomelayer
acadDoc.Regen True
On Error GoTo ProvaM
Titolo.TextString = Titolo.TextString & LengthOfPolyline(ferro)
GoTo Fine

ProvaM:
On Error GoTo FineE
mtitolo.TextString = mtitolo.TextString & LengthOfPolyline(ferro)
GoTo Fine
FineE:
l = LengthOfPolyline(ferro)
GoTo Fine
errore:
MsgBox "Errore: impossibile creare la polilinea. Controllare le linee selezionate", vbOKOnly, "Errore"
Fine:
'elimino il selection set
acadDoc.SelectionSets.Item("Ferro").Delete

End Sub

Public Function LengthOfPolyline(PLine As AcadLWPolyline) As Double

Dim ExplodedObjects As Variant

On Error Resume Next
ExplodedObjects = PLine.Explode

Dim Index As Integer
Dim Perimeter As Double
Dim line As AcadLine
Dim punto1(0 To 2) As Double
Dim punto2(0 To 2) As Double
Dim loc(0 To 2) As Double
Dim ang As Double
Dim quota As AcadDimension

For Index = 0 To UBound(ExplodedObjects)
Perimeter = Perimeter + ExplodedObjects(Index).Length
Set line = ExplodedObjects(Index)
punto1(0) = line.StartPoint(0)
punto1(1) = line.StartPoint(1)
punto1(2) = line.StartPoint(2)
punto2(0) = line.EndPoint(0)
punto2(1) = line.EndPoint(1)
punto2(2) = line.EndPoint(2)
loc(0) = punto1(0) + ((punto2(0) - punto1(0)) / 2)
loc(1) = punto1(1) + ((punto2(1) - punto1(1)) / 2)
loc(2) = 0
'Disegno la quota
If punto1(1) = punto2(1) Then 'Linea orizzontale
ang = 0
Else
If punto1(0) = punto2(0) Then 'Linea verticale
ang = pigreco / 2
End If
End If
Set quota = acadDoc.ModelSpace.AddDimRotated(punto1, punto2, loc, ang)
quota.Layer = "QUOTE"
line.Delete
Next Index
acadDoc.Regen True

LengthOfPolyline = Round(Perimeter)
End Function

Private Sub BtnConvMText_Click()
Dim sset As AcadSelectionSet
Dim testo As AcadText
Dim mtesto As AcadMText
Dim vettore(0 To 99) As String
Dim inspoint(0 To 2) As Double

Set sset = acadDoc.SelectionSets.Add("Testo")
AppActivate acadApp.Caption
sset.SelectOnScreen

For i = 0 To 99
vettore(i) = ""
Next

'Salvo tutte le stringhe in un vettore
For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadText Then
Set testo = sset.Item(i)
vettore(i) = testo.TextString
If Asc(testo.TextString) = 32 Then
inspoint(0) = testo.InsertionPoint(0)
inspoint(1) = testo.InsertionPoint(1)
inspoint(2) = testo.InsertionPoint(2)
End If
testo.Delete
End If
Next

'Ordino il vettore
For i = 0 To sset.Count - 1
tmp = vettore(i)
k = 0
Trovato = False
For j = i + 1 To sset.Count - 1
If (vettore(j) < tmp) And (Asc(vettore(j)) <> 32) Then
k = j
tmp = vettore(j)
Trovato = True
End If
Next j
If Trovato Then
vettore(k) = vettore(i)
vettore(i) = tmp
End If
Next i

'Creo MText
stringa = ""
For i = 0 To sset.Count - 2
stringa = stringa & vettore(i) & "\P"
Next i
i = sset.Count - 1
stringa = stringa & vettore(i)
Set mtesto = acadDoc.ModelSpace.AddMText(inspoint, 150, stringa)
mtesto.AttachmentPoint = acAttachmentPointBottomLeft
mtesto.Height = 10
mtesto.StyleName = "Romans"
mtesto.Layer = "PEN035"
sset.Delete
acadDoc.Regen True
End Sub

Private Sub BtnDown_Click()
Dim sset As AcadSelectionSet
Dim quota As AcadDimension
Dim punto(0 To 2) As Double
Dim stringa As String

Set sset = acadDoc.SelectionSets.Add("Sposta")
AppActivate acadApp.Caption
sset.SelectOnScreen

For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadDimension Then
Set quota = sset.Item(i)
stringa = quota.StyleName
stringa = Right(stringa, 2)
stringa2 = Right(quota.StyleName, 5)
If stringa2 = "50-20" Then
delta = 15
Else
Select Case stringa
Case 50: delta = 15
Case 25: delta = 7.5
Case 20: delta = 6
End Select
End If
'quota.VerticalTextPosition = acOutside
'Horizontal ?
punto(0) = quota.TextPosition(0)
punto(1) = quota.TextPosition(1) - delta
punto(2) = 0
quota.TextPosition = punto
acadDoc.Regen True
End If
Next
sset.Delete
End Sub

Private Sub BtnInf_Click()
Dim sset As AcadSelectionSet
Dim testo As AcadText
Dim mtesto As AcadMText
Dim punto(0 To 2) As Double

Set sset = acadDoc.SelectionSets.Add("Inferiore")
AppActivate acadApp.Caption
sset.SelectOnScreen

For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadText Then
Set testo = sset.Item(i)
punto(0) = testo.InsertionPoint(0)
punto(1) = testo.InsertionPoint(1)
punto(2) = testo.InsertionPoint(2)
testo.TextString = testo.TextString & " (INF)"
testo.Alignment = acAlignmentBottomCenter
testo.TextAlignmentPoint = punto
ElseIf TypeOf sset.Item(i) Is AcadMText Then
Set mtesto = sset.Item(i)
mtesto.TextString = mtesto.TextString & " (INF)"
mtesto.AttachmentPoint = acAttachmentPointBottomCenter
End If
Next
sset.Delete
End Sub


Private Sub BtnLat_Click()
Dim sset As AcadSelectionSet
Dim testo As AcadText
Dim mtesto As AcadMText
Dim punto(0 To 2) As Double

Set sset = acadDoc.SelectionSets.Add("Laterale")
AppActivate acadApp.Caption
sset.SelectOnScreen
acadApp.Visible = True

For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadText Then
Set testo = sset.Item(i)
punto(0) = testo.InsertionPoint(0)
punto(1) = testo.InsertionPoint(1)
punto(2) = testo.InsertionPoint(2)
testo.TextString = testo.TextString & " (LAT)"
testo.Alignment = acAlignmentBottomCenter
testo.TextAlignmentPoint = punto
ElseIf TypeOf sset.Item(i) Is AcadMText Then
Set mtesto = sset.Item(i)
mtesto.TextString = mtesto.TextString & " (LAT)"
mtesto.AttachmentPoint = acAttachmentPointBottomCenter
End If
Next
sset.Delete
End Sub

Private Sub BtnRefresh_Click()
'
'Refresh iron lenght
'
Dim sset As AcadSelectionSet

Set sset = acadDoc.SelectionSets.Add("Ferro")
AppActivate acadApp.Caption
sset.SelectOnScreen

For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadText Then
Dim Titolo As AcadText
Dim stringa, stemp1, stemp2
Set Titolo = sset.Item(i)
stringa = Titolo.TextString

For h = 1 To Len(stringa)
stemp = Left(stringa, h)
stemp2 = StrReverse(stemp)
If Asc(stemp2) = 61 Then
Exit For
End If
Next h
stringa = Left(stringa, h)
Titolo.TextString = stringa
ElseIf TypeOf sset.Item(i) Is AcadLWPolyline Then
Dim ferro As AcadLWPolyline
Set ferro = sset.Item(i)
ElseIf TypeOf sset.Item(i) Is AcadMText Then
Dim mtitolo As AcadMText
Dim mstringa, mstemp1, mstemp2
Set mtitolo = sset.Item(i)
mstringa = mtitolo.TextString

For h = 1 To Len(mstringa)
mstemp1 = Left(mstringa, h)
mstemp2 = StrReverse(mstemp1)
If Asc(mstemp2) = 61 Then
Exit For
End If
Next h
mstringa = Left(mstringa, h)
mtitolo.TextString = mstringa
End If
Next
On Error GoTo ProvaM
Titolo.TextString = Titolo.TextString & lunghezza(ferro)
GoTo Fine
ProvaM:
On Error GoTo Fine
mtitolo.TextString = mtitolo.TextString & lunghezza(ferro)
GoTo Fine
Fine:
sset.Delete
End Sub

Private Sub BtnReset_Click()
'
'reset connection to Acad
'
On Error Resume Next

Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then
MsgBox Err.Description
Exit Sub
End If
End If
'
'Connection to active document
'
Set acadDoc = acadApp.ActiveDocument
acadApp.Visible = True
'
'If error occurs in one or more functions
'this sub deletes all the selection sets still open
'
For i = 0 To acadDoc.SelectionSets.Count - 1
acadDoc.SelectionSets.Item(i).Delete
Next
End Sub

Private Sub BtnRight_Click()
Dim sset As AcadSelectionSet
Dim quota As AcadDimension
Dim punto(0 To 2) As Double
Dim stringa As String

Set sset = acadDoc.SelectionSets.Add("Sposta")
AppActivate acadApp.Caption
sset.SelectOnScreen

For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadDimension Then
Set quota = sset.Item(i)
stringa = quota.StyleName
stringa = Right(stringa, 2)
stringa2 = Right(quota.StyleName, 5)
If stringa2 = "50-20" Then
delta = 15
Else
Select Case stringa
Case 50: delta = 15
Case 25: delta = 7.5
Case 20: delta = 6
End Select
End If
'quota.VerticalTextPosition = acOutside
punto(0) = quota.TextPosition(0) + delta
punto(1) = quota.TextPosition(1)
punto(2) = 0
quota.TextPosition = punto
acadDoc.Regen True
End If
Next
sset.Delete
End Sub

Private Sub BtnStaffe_Click()
'**************************
'Prendo gli input necessari
Dim SsetAI As AcadSelectionSet 'appoggi interni
Dim SsetAE As AcadSelectionSet 'appoggi esterni
Dim SsetDivisioni As AcadSelectionSet '"quote" con division
Dim SsetStaffatura As AcadSelectionSet 'fattore di staffatura
Dim Linea As AcadLine
Dim VetXassiInt(0 To 15) As Double
Dim VetXAssiEst(0 To 1) As Double
Dim VetXLineeQ(0 To 30) As Double
Dim MatTmp(0 To 30, 1 To 3) As Double 'salvo i dati di ogni testo
Dim VetTmp(1 To 8) 'Inserisco dati selle staffature
Dim MatDivisioni(0 To 30, 1 To 5) As Double
'y: 1=lettera(a=1,b=2,...)
' 2=x inizio della divisione
' 3=x fine divisione
' 4=fattore di presenza (es 1/10cm)
' 5=OK TRUE-FALSE: indica se l'ho già disegnata 0=false 1=true
Dim VetCoord(0 To 100, 0 To 1) As Double 'coordinate inizio fine staffature
Dim iCoord

'Inizializzo i nomi dei selection sets
Set SsetAI = acadDoc.SelectionSets.Add("AppInt")
Set SsetAE = acadDoc.SelectionSets.Add("AppEst")
Set SsetDivisioni = acadDoc.SelectionSets.Add("Divisioni")
Set SsetStaffatura = acadDoc.SelectionSets.Add("Staffatura")
iCoord = 0

'Prendo gli assi degli appoggi interni
AppActivate acadApp.Caption
SsetAI.SelectOnScreen
nappint = 0
For i = 0 To SsetAI.Count - 1
If (TypeOf SsetAI.Item(i) Is AcadLine) And (SsetAI.Item(i).Layer = "ASSI") Then
Set Linea = SsetAI.Item(i)
VetXassiInt(i) = Linea.StartPoint(0)
nappint = nappint + 1
End If
Next
For i = 0 To nappint - 1
tmp = VetXassiInt(i)
k = 0
Trovato = False
For j = i + 1 To nappint - 1
If (VetXassiInt(j) < tmp) Then
k = j
tmp = VetXassiInt(j)
Trovato = True
End If
Next j
If Trovato Then
VetXassiInt(k) = VetXassiInt(i)
VetXassiInt(i) = tmp
End If
Next i

'Prendo gli assi degli appoggi esterni
SsetAE.SelectOnScreen
nappest = 0
For i = 0 To SsetAE.Count - 1
If (TypeOf SsetAE.Item(i) Is AcadLine) And (SsetAE.Item(i).Layer = "ASSI") Then
Set Linea = SsetAE.Item(i)
VetXAssiEst(i) = Linea.StartPoint(0)
nappest = nappest + 1
End If
Next
For i = 0 To nappest - 1
tmp = VetXAssiEst(i)
k = 0
Trovato = False
For j = i + 1 To nappest - 1
If (VetXAssiEst(j) < tmp) Then
k = j
tmp = VetXAssiEst(j)
Trovato = True
End If
Next j
If Trovato Then
VetXAssiEst(k) = VetXAssiEst(i)
VetXAssiEst(i) = tmp
End If
Next i

'Prendo le "quote" delle staffe
n = 0
ns = 0
k = 0
j = 0
SsetDivisioni.SelectOnScreen
For i = 0 To SsetDivisioni.Count - 1
If TypeOf SsetDivisioni.Item(i) Is AcadLine Then
Set Linea = SsetDivisioni.Item(i)
If Linea.Layer <> "ASSI" Then
If Linea.delta(0) = 0 Then 'è una di quelle verticali
VetXLineeQ(k) = Linea.StartPoint(0)
n = n + 1
k = k + 1
End If
Linea.Delete
End If
ElseIf TypeOf SsetDivisioni.Item(i) Is AcadText Then
Dim testo As AcadText
Set testo = SsetDivisioni.Item(i)
Select Case testo.TextString
Case "a": MatTmp(j, 1) = 1
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
Case "b": MatTmp(j, 1) = 2
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
Case "c": MatTmp(j, 1) = 3
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
Case "d": MatTmp(j, 1) = 4
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
Case "e": MatTmp(j, 1) = 5
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
Case "f": MatTmp(j, 1) = 6
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
Case "g": MatTmp(j, 1) = 7
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
Case "h": MatTmp(j, 1) = 8
MatTmp(j, 2) = testo.InsertionPoint(0)
MatTmp(j, 3) = testo.InsertionPoint(1)
j = j + 1
ns = ns + 1
End Select
testo.Delete
End If
Next
'Ordino il vetore delle coordinate
For i = 0 To n - 1
tmp = VetXLineeQ(i)
k = 0
Trovato = False
For j = i + 1 To n - 1
If (VetXLineeQ(j) < tmp) Then
k = j
tmp = VetXLineeQ(j)
Trovato = True
End If
Next j
If Trovato Then
VetXLineeQ(k) = VetXLineeQ(i)
VetXLineeQ(i) = tmp
End If
Next i
'Ordino il vettore delle scritte
For i = 0 To ns - 1
tmp1 = MatTmp(i, 1)
tmp2 = MatTmp(i, 2)
tmp3 = MatTmp(i, 3)
k = 0
Trovato = False
For j = i + 1 To ns - 1
If MatTmp(j, 2) < tmp2 Then
k = j
tmp1 = MatTmp(j, 1)
tmp2 = MatTmp(j, 2)
tmp3 = MatTmp(j, 3)
Trovato = True
End If
Next j
If Trovato Then
MatTmp(k, 1) = MatTmp(i, 1)
MatTmp(k, 2) = MatTmp(i, 2)
MatTmp(k, 3) = MatTmp(i, 3)
MatTmp(i, 1) = tmp1
MatTmp(i, 2) = tmp2
MatTmp(i, 3) = tmp3
End If
Next i
'Fine ordinamento
'riempio la matrice matdivisioni
k = 0
For i = 0 To n - 2
If Abs(VetXLineeQ(i + 1) - VetXLineeQ(i)) > 1 Then
MatDivisioni(k, 2) = VetXLineeQ(i)
MatDivisioni(k, 3) = VetXLineeQ(i + 1)
MatDivisioni(k, 1) = MatTmp(k, 1)
MatDivisioni(k, 5) = 0
k = k + 1
End If
Next
ntot = k
'Matrice MatDivisioni riempita

'Leggo dati sulle staffature

SsetStaffatura.SelectOnScreen
For i = 0 To SsetStaffatura.Count - 1
If TypeOf SsetStaffatura.Item(i) Is AcadText Then
Dim staffatext As AcadText
Set staffatext = SsetStaffatura.Item(i)
'trovo la misura che mi interessa
stringa = staffatext.TextString
For j = 1 To Len(stringa)
stemp = Right(stringa, j)
If Asc(stemp) = 47 Then 'Se il carattere è: /
Exit For
End If
Next j
stringa = Right(stringa, j - 1)
For j = 1 To Len(stringa)
stemp = Left(stringa, j)
stempr = StrReverse(stemp)
If Asc(stempr) = 32 Then
Exit For
End If
Next j
num = Left(stringa, j - 1)
Select Case Asc(staffatext.TextString)
Case 97: VetTmp(1) = num
Case 98: VetTmp(2) = num
Case 99: VetTmp(3) = num
Case 100: VetTmp(4) = num
Case 101: VetTmp(5) = num
Case 102: VetTmp(6) = num
Case 103: VetTmp(7) = num
Case 104: VetTmp(8) = num
End Select
End If
Next i
For i = 0 To ntot - 1
Select Case MatDivisioni(i, 1)
Case 1: MatDivisioni(i, 4) = VetTmp(1)
Case 2: MatDivisioni(i, 4) = VetTmp(2)
Case 3: MatDivisioni(i, 4) = VetTmp(3)
Case 4: MatDivisioni(i, 4) = VetTmp(4)
Case 5: MatDivisioni(i, 4) = VetTmp(5)
Case 6: MatDivisioni(i, 4) = VetTmp(6)
Case 7: MatDivisioni(i, 4) = VetTmp(7)
Case 8: MatDivisioni(i, 4) = VetTmp(8)
End Select
Next i

'Prendo le staffe
Dim SsetStaffe As AcadSelectionSet
Set SsetStaffe = acadDoc.SelectionSets.Add("Staffe")

SsetStaffe.SelectOnScreen
nstaffe = 0

Dim VetStaffe(0 To 1000) As Double
Dim y1, y2, yinizio, yfine

k = 0
First = True
For i = 0 To SsetStaffe.Count - 1
If SsetStaffe.Item(i).Layer = "PEN035" Then
Set Linea = SsetStaffe.Item(i)
VetStaffe(k) = Linea.StartPoint(0)
y1 = Linea.StartPoint(1)
y2 = Linea.EndPoint(1)
If y1 < 0 And y2 < 0 Then
If y1 < y2 Then
tmp = y1
y1 = y2
y2 = tmp
End If
If First Or (y1 <= yinizio And y2 >= yfine) Then
yinizio = y1
yfine = y2
First = False
End If
Else
If y1 > y2 Then
tmp = y1
y1 = y2
y2 = tmp
End If
If First Or (y1 >= yinizio And y2 <= yfine) Then
yinizio = y1
yfine = y2
First = False
End If
End If
k = k + 1
nstaffe = nstaffe + 1
Linea.Delete
End If
Next
'Ordino le staffe
For i = 0 To nstaffe - 1
tmp = VetStaffe(i)
k = 0
Trovato = False
For j = i + 1 To nstaffe - 1
If (VetStaffe(j) < tmp) Then
k = j
tmp = VetStaffe(j)
Trovato = True
End If
Next j
If Trovato Then
VetStaffe(k) = VetStaffe(i)
VetStaffe(i) = tmp
End If
Next i
'For i = 1 To nstaffe - 1
' VetStaffe(i - 1) = VetStaffe(i)
'Next
'VetStaffe(nstaffe - 1) = 0
'VetStaffe(nstaffe - 2) = 0
nstaffe = nstaffe - 2
'**************************

If ntot = 1 Then
Dim p1(0 To 2) As Double
Dim p2(0 To 2) As Double
i = 0
'Numero staffe
For j = 0 To ntot
If (VetXAssiEst(i) >= MatDivisioni(j, 2)) And (VetXAssiEst(i) <= MatDivisioni(j, 3)) Then
Exit For
End If
Next j
If j <> 0 Then j = 0
numerostaffe = Abs(MatDivisioni(j, 3) - MatDivisioni(j, 2)) \ MatDivisioni(j, 4)
If numerostaffe Mod 2 <> 0 Then 'Numero dispari di staffe
posx = VetXAssiEst(i)
p1(0) = posx: p1(1) = yinizio: p1(2) = 0
p2(0) = posx: p2(1) = yfine: p2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(p1, p2)
lineatmp.Layer = "PEN035"
Else
posx = VetXAssiEst(i) - (MatDivisioni(j, 4) \ 2)
p1(0) = posx: p1(1) = yinizio: p1(2) = 0
p2(0) = posx: p2(1) = yfine: p2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(p1, p2)
lineatmp.Layer = "PEN035"
End If
oldposx = posx
'Vai a sinistra il più possibile
posx = posx - MatDivisioni(j, 4)
While posx > VetStaffe(0)
p1(0) = posx: p1(1) = yinizio: p1(2) = 0
p2(0) = posx: p2(1) = yfine: p2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(p1, p2)
lineatmp.Layer = "PEN035"
posx = posx - MatDivisioni(j, 4)
Wend
MatDivisioni(j, 2) = posx + MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 2)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
'Vai a destra il più possibile
posx = oldposx
posx = posx + MatDivisioni(j, 4)
While posx < MatDivisioni(j, 3)
p1(0) = posx: p1(1) = yinizio: p1(2) = 0
p2(0) = posx: p2(1) = yfine: p2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(p1, p2)
lineatmp.Layer = "PEN035"
posx = posx + MatDivisioni(j, 4)
Wend
MatDivisioni(j, 3) = posx - MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 3)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
MatDivisioni(j, 5) = 1
GoTo quota
End If

'Staffo gli appoggi interni
'Dim lineatmp As AcadLine
Dim punto1(0 To 2) As Double
Dim punto2(0 To 2) As Double

For i = 0 To nappint - 1
'Numero staffe
For j = 0 To ntot
If (VetXassiInt(i) >= MatDivisioni(j, 2)) And (VetXassiInt(i) <= MatDivisioni(j, 3)) Then
Exit For
End If
Next j
numerostaffe = Abs(MatDivisioni(j, 3) - MatDivisioni(j, 2)) \ MatDivisioni(j, 4)
If numerostaffe Mod 2 <> 0 Then 'Numero dispari di staffe
posx = VetXassiInt(i)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
Else
posx = VetXassiInt(i) - (MatDivisioni(j, 4) \ 2)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
End If
oldposx = posx
'Vai a sinistra il più possibile
posx = posx - MatDivisioni(j, 4)
While posx > MatDivisioni(j, 2)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
posx = posx - MatDivisioni(j, 4)
Wend
MatDivisioni(j, 2) = posx + MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 2)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
'Vai a destra il più possibile
posx = oldposx
posx = posx + MatDivisioni(j, 4)
While posx < MatDivisioni(j, 3)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
posx = posx + MatDivisioni(j, 4)
Wend
MatDivisioni(j, 3) = posx - MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 3)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
MatDivisioni(j, 5) = 1
Next i

'**************************
'Staffo gli appoggi esterni

For i = 0 To nappest - 1
'Numero staffe
For j = 0 To ntot
If (VetXAssiEst(i) >= MatDivisioni(j, 2)) And (VetXAssiEst(i) <= MatDivisioni(j, 3)) Then
Exit For
End If
Next j
numerostaffe = Abs(MatDivisioni(j, 3) - MatDivisioni(j, 2)) \ MatDivisioni(j, 4)
If numerostaffe Mod 2 <> 0 Then 'Numero dispari di staffe
posx = VetXAssiEst(i)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
Else
posx = VetXAssiEst(i) - (MatDivisioni(j, 4) \ 2)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
End If
oldposx = posx
'Vai a sinistra il più possibile
If i = 0 Then
posx = posx - MatDivisioni(j, 4)
While posx > VetStaffe(0)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
posx = posx - MatDivisioni(j, 4)
Wend
MatDivisioni(j, 2) = posx + MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 2)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
Else
posx = posx - MatDivisioni(j, 4)
While posx > MatDivisioni(j, 2)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
posx = posx - MatDivisioni(j, 4)
Wend
MatDivisioni(j, 2) = posx + MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 2)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
End If
'Vai a destra il più possibile
posx = oldposx
If i = 1 Then
posx = posx + MatDivisioni(j, 4)
While posx < VetStaffe(nstaffe + 1)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
posx = posx + MatDivisioni(j, 4)
Wend
MatDivisioni(j, 3) = posx - MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 3)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
Else
posx = posx + MatDivisioni(j, 4)
While posx < MatDivisioni(j, 3)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
posx = posx + MatDivisioni(j, 4)
Wend
MatDivisioni(j, 3) = posx - MatDivisioni(j, 4)
VetCoord(iCoord, 0) = MatDivisioni(j, 3)
VetCoord(iCoord, 1) = MatDivisioni(j, 1)
iCoord = iCoord + 1
End If
MatDivisioni(j, 5) = 1
Next i
'**************************
'Staffatura dell'interno
For i = 0 To ntot - 1
If MatDivisioni(i, 5) = 0 Then 'Se non l'ho già disegnata
distanza = MatDivisioni(i + 1, 2) - MatDivisioni(i - 1, 3)
numerostaffe = distanza \ MatDivisioni(i, 4) + 1
resto = distanza Mod MatDivisioni(i, 4)
While (resto / 2) < MatDivisioni(i - 1, 4)
resto = resto + MatDivisioni(i, 4)
numerostaffe = numerostaffe - 1
Wend
spazio = resto / 2
posx = MatDivisioni(i - 1, 3) + spazio
VetCoord(iCoord, 0) = posx
VetCoord(iCoord, 1) = MatDivisioni(i, 1)
iCoord = iCoord + 1
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
For j = 2 To numerostaffe
posx = posx + MatDivisioni(i, 4)
punto1(0) = posx: punto1(1) = yinizio: punto1(2) = 0
punto2(0) = posx: punto2(1) = yfine: punto2(2) = 0
Set lineatmp = acadDoc.ModelSpace.AddLine(punto1, punto2)
lineatmp.Layer = "PEN035"
Next j
VetCoord(iCoord, 0) = posx
VetCoord(iCoord, 1) = MatDivisioni(i, 1)
iCoord = iCoord + 1
End If
Next i

quota:
'Ordino VetCoord
num = iCoord
For i = 0 To num - 1
tmp = VetCoord(i, 0)
tmp2 = VetCoord(i, 1)
k = 0
Trovato = False
For j = i + 1 To num - 1
If (VetCoord(j, 0) < tmp) Then
k = j
tmp = VetCoord(j, 0)
tmp2 = VetCoord(j, 1)
Trovato = True
End If
Next j
If Trovato Then
VetCoord(k, 0) = VetCoord(i, 0)
VetCoord(k, 1) = VetCoord(i, 1)
VetCoord(i, 0) = tmp
VetCoord(i, 1) = tmp2
End If
Next i

Dim oggetto As AcadObject

acadDoc.Utility.GetEntity oggetto, basepnt, "Scegliere linea di inizio"
Dim line As AcadLine
Set line = oggetto
Y = line.StartPoint(1)
If Y > line.EndPoint(1) Then
Y = line.EndPoint(1)
End If
Y = Y - 75
X1 = line.StartPoint(0)

acadDoc.Utility.GetEntity oggetto, basepnt, "Scegliere linea di fine"
Set line = oggetto
X2 = line.StartPoint(0)

For i = 0 To num - 1
VetCoord(num - i, 0) = VetCoord(num - i - 1, 0)
VetCoord(num - i, 1) = VetCoord(num - i - 1, 1)
Next
VetCoord(0, 0) = X1
VetCoord(0, 1) = 0
VetCoord(num + 1, 0) = X2
VetCoord(num + 1, 1) = 0

'Inserisco le quote
Dim quota As AcadDimension
Dim ang As Double

Dim puntot(0 To 2) As Double
ang = 0

For i = 0 To num
punto1(0) = VetCoord(i, 0): punto1(1) = yinizio: punto1(2) = 0
punto2(0) = VetCoord(i + 1, 0): punto2(1) = yinizio: punto2(2) = 0
puntot(0) = punto1(0) + ((punto2(0) - punto1(0)) / 2)
puntot(1) = Y: puntot(2) = 0
Set quota = acadDoc.ModelSpace.AddDimRotated(punto1, punto2, puntot, ang)
quota.Layer = "quote"
If VetCoord(i, 1) = VetCoord(i + 1, 1) Then
Select Case VetCoord(i, 1)
Case 1: quota.TextOverride = "a=<>"
Case 2: quota.TextOverride = "b=<>"
Case 3: quota.TextOverride = "c=<>"
Case 4: quota.TextOverride = "d=<>"
Case 5: quota.TextOverride = "e=<>"
Case 6: quota.TextOverride = "f=<>"
Case 7: quota.TextOverride = "g=<>"
Case 8: quota.TextOverride = "h=<>"
End Select
End If
Next

'**************************
'Elimino i 5 selection sets
SsetAI.Delete
SsetAE.Delete
SsetDivisioni.Delete
SsetStaffatura.Delete
SsetStaffe.Delete
End Sub

Private Sub BtnStyle_Click()
FrmStyle.Show
End Sub

Private Sub BtnSup_Click()
Dim sset As AcadSelectionSet
Dim testo As AcadText
Dim mtesto As AcadMText
Dim punto(0 To 2) As Double

Set sset = acadDoc.SelectionSets.Add("Superiore")
AppActivate acadApp.Caption
sset.SelectOnScreen

For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadText Then
Set testo = sset.Item(i)
punto(0) = testo.InsertionPoint(0)
punto(1) = testo.InsertionPoint(1)
punto(2) = testo.InsertionPoint(2)
testo.TextString = testo.TextString & " (SUP)"
testo.Alignment = acAlignmentTopCenter
testo.TextAlignmentPoint = punto
ElseIf TypeOf sset.Item(i) Is AcadMText Then
Set mtesto = sset.Item(i)
mtesto.TextString = mtesto.TextString & " (SUP)"
mtesto.AttachmentPoint = acAttachmentPointTopCenter
End If
Next
sset.Delete
End Sub

Public Sub Seleziona(cerca)
Dim sset As AcadSelectionSet
Dim blocco As AcadBlockReference
Dim attributi As AcadAttribute
Dim varattributi As Variant

FrmZoom.Hide
Set sset = acadDoc.SelectionSets.Add("Blocchi")
sset.SelectOnScreen
For i = 0 To sset.Count - 1
If TypeOf sset.Item(i) Is AcadBlockReference Then
Set blocco = sset.Item(i)
varattributi = blocco.GetAttributes
For j = LBound(varattributi) To UBound(varattributi)
stringa = varattributi(j).TextString
stringa = Trim(stringa)
If stringa = cerca Then
Dim punto1(0 To 2) As Double
punto1(0) = blocco.InsertionPoint(0)
punto1(1) = blocco.InsertionPoint(1)
punto1(2) = 0
ZoomCenter punto1, 300
GoTo Fine
End If
Next j
End If
Next
Fine:
sset.Delete
End Sub

Public Sub ScriviNome()
Dim oggetto As AcadObject
Dim punto As Variant

acadDoc.Utility.GetEntity oggetto, punto, "Inserire oggetto"
oggetto.Color = acRed
oggetto.Update
MsgBox "Il nome dell'oggetto è " & oggetto.EntityName, vbOKOnly
oggetto.Color = bylayer
oggetto.Update
End Sub

Public Sub EsempioAttr()
UserForm.Show
End Sub

Public Sub cancella()
acadDoc.SelectionSets.Item("Blocchi").Delete
End Sub

Private Function Giainserito(a, insaux As Integer) As Boolean
Giainserito = False
For i = 1 To insaux
If (punti(a, 1) = puntiaux(i, 1)) And (punti(a, 2) = puntiaux(i, 2)) And (punti(a, 3) = puntiaux(i, 3)) And (punti(a, 4) = puntiaux(i, 4)) Then
Giainserito = True
End If
If (punti(a, 1) = puntiaux(i, 3)) And (punti(a, 2) = puntiaux(i, 4)) And (punti(a, 3) = puntiaux(i, 1)) And (punti(a, 4) = puntiaux(i, 2)) Then
Giainserito = True
End If
Next
End Function

Public Sub salvavar(var)
delta = var
End Sub

Public Function lunghezza(PLine As AcadLWPolyline) As Double

Dim ExplodedObjects As Variant

On Error Resume Next
ExplodedObjects = PLine.Explode

Dim Index As Integer
Dim Perimeter As Double
Dim line As AcadLine

For Index = 0 To UBound(ExplodedObjects)
Perimeter = Perimeter + ExplodedObjects(Index).Length
Set line = ExplodedObjects(Index)
line.Delete
Next Index

lunghezza = Round(Perimeter)
End Function

Private Sub Form_Load()
SetOnTop FrmTool.hWnd, True
End Sub

Private Sub SetOnTop(hWnd As Long, OnTop As Boolean)
Dim iReturn As Integer
iReturn = IIf(OnTop = True, _
SetWindowPos(hWnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS), _
SetWindowPos(hWnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS))
End Sub

Thank you for your help
regards
Diego Alejandro Talledo