[ Home | Discussioni Attive | Discussioni Recenti | Segnalibro | Msg privati | Sondaggi Attivi | Utenti | Download | Cerca | FAQ ]
Nome Utente:
Password:
Salva Password
Password Dimenticata?

 Tutti i Forum
 Autocad
 VBA - Visual Basic per Autocad
 Comandi base (MOVE,ROTATE,...) tramite VBA

Nota: Devi essere registrato per poter inserire un messaggio.

Larghezza finestra:
Nome Utente:
Password:
Icona Messaggio:              
             
Messaggio:

  * Il codice HTML č ON
* Il Codice Forum č OFF


   Allega file
  Clicca qui per sottoscrivere questa Discussione.
 
    

V I S U A L I Z Z A    D I S C U S S I O N E
Lucakit Inserito il - 27/10/2010 : 02:19:05
Ciao!
Ho ritenuto meglio aprire una nuova discussione perchč credo che questo argomento meriti la giusta evidenza, dato che sul web la documentazione č scarsissima...

Spiego in breve, per chi inizia a leggere la mia storia solo da questa discussione, il mio obiettivo.
Durante la compilazione del mio codice č risultato necessario interagire a mano con le operazioni del codice stesso: a un certo punto della macro avrei bisogno di poter modificare dei dettagli del disegno, in quantitā indefinita e in modo diverso da una volta all'altra (ma senza usare un'eccessiva gamma di comandi...diciamo quelli di base). Infine, dopo queste operazioni "ad-hoc", la macro termina di nuovo in automatico con salvataggi e stampe (quindi torno a non avere il controllo di essa fino alla fine).

Pertanto, dopo tanto sbattere la testa, sono giunto alla soluzione che riporto qua sotto, ad uso di chi si trova nel mio stesso mal di testa!

E' previsto un DO...LOOP UNTIL che comprende una SELECT di tutti i comandi di cui posso aver bisogno; tra i comandi, ho messo quello per cui faccio proseguire la macro di nuovo in maniera autonoma (per me č il SAVE). Il tutto comprende la gestione del tasto ESC, nel caso di errore da parte dell'utente nelle operazioni, e la possibilitā di annullare le ultime operazioni svolte.

NOTA IMPORTANTE: nel mio caso, era fondamentale cambiare le coordinate di alcuni punti perchč io lavoro in un sistema di riferimento diverso dal WCS mentre alcuni comandi lavorano solo in quest'ultimo; pertanto, per chi non č nel mio caso, č necessario eliminare le parti di codice che riportano " - ThisDrawing.ActiveUCS.origin(n)" e "CVar(punto_taldeitali)"!


Difetti da sistemare nel tempo:
- far comparire l'anteprima delle modifiche che stanno per essere fatte (quello che succede con i comandi di autocad nel momento in cui "si prendono le misure" della modifica)
- introdurre il comando per MODIFICARE LA POSIZIONE DEI PUNTI DI UNA SPLINE........LUCIO, QUI MI APPELLO A TE SE HAI UN'IDEA!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!![:(][:(][:(][:(]
- comando "Redo" per ripristinare le azioni annullate erroneamente
- gestione di eventuali altri errori



Do
se_premi_ESC_torna_qua:

Dim chiavi As String
chiavi = "M R S I T E L Z P A V"
ThisDrawing.Utility.initializeuserinput 128, chiavi

On Error GoTo OH_NO

Dim scelta As String
scelta = ""
scelta = ThisDrawing.Utility.GetKeyword("Cosa vuoi fare? (Muovi/Ruota/Scala/Interrompi/Taglia/Elimina/Linea_tratteggiata/Zoom/zoomPrecedente/Annulla/salVa_stampa): ")

Dim Selezione As AcadSelectionSet
Dim EntitāSelezione As AcadEntity
Dim scalefactor As AcadDimAligned
Dim punto As Variant
Dim puntoDA(0 To 2) As Double
Dim puntoA(0 To 2) As Double
Dim entObj As AcadEntity
Dim Pnt As Variant
Dim Pnt2 As Variant
Dim det As String
Dim lspPnt As String
Dim lspPnt1 As String
Dim lspPnt2 As String
Dim puntomed...(0 To 2) As Double


Select Case scelta


Case "M" 'MUOVI (MOVE)
On Error GoTo OH_NO


With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set Selezione = .Add("$MoveTest$")
End With
Selezione.SelectOnScreen

Set objutil = ThisDrawing.Utility
strPrmt = vbCr & "Muovi DAL punto: "
punto = objutil.GetPoint(Prompt:=strPrmt)
puntoDA(0) = punto(0) - ThisDrawing.ActiveUCS.origin(0): puntoDA(1) = punto(1) - ThisDrawing.ActiveUCS.origin(1): puntoDA(2) = 0
punto1 = CVar(puntoDA)
strPrmt = vbCr & "AL punto: "
objutil.initializeuserinput 33
punto = objutil.GetPoint(punto1, strPrmt)
puntoA(0) = punto(0) - ThisDrawing.ActiveUCS.origin(0): puntoA(1) = punto(1) - ThisDrawing.ActiveUCS.origin(1): puntoA(2) = 0
punto2 = CVar(puntoA)

For Each EntitāSelezione In Selezione
Set objcopy = EntitāSelezione.Copy
objcopy.Move punto1, punto2
Next EntitāSelezione
Selezione.Erase
Set Selezione = Nothing
Set objutil = Nothing
Set objcopy = Nothing
ThisDrawing.Regen (True)


Case "R" 'RUOTA (ROTATE)
On Error GoTo OH_NO

'ThisDrawing.StartUndoMark
With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set Selezione = .Add("$MoveTest$")
End With
Selezione.SelectOnScreen

Set objutil = ThisDrawing.Utility
strPrmt = vbCr & "Ruota attorno al punto: "
punto = objutil.GetPoint(Prompt:=strPrmt)
puntoB = punto
puntoDA(0) = punto(0) - ThisDrawing.ActiveUCS.origin(0): puntoDA(1) = punto(1) - ThisDrawing.ActiveUCS.origin(1): puntoDA(2) = 0
punto1 = CVar(puntoDA)
strPrmt = vbCr & "Angolo di rotazione: "
objutil.initializeuserinput 33
punto = objutil.GetPoint(punto1, strPrmt)
puntoA(0) = punto(0) - ThisDrawing.ActiveUCS.origin(0): puntoA(1) = punto(1) - ThisDrawing.ActiveUCS.origin(1): puntoA(2) = 0
punto2 = CVar(puntoA)
dblrot = objutil.AngleFromXAxis(punto1, punto2)


For Each EntitāSelezione In Selezione
Set objcopy = EntitāSelezione.Copy
objcopy.Rotate puntoB, dblrot
Next EntitāSelezione
Selezione.Erase
Set Selezione = Nothing
Set objutil = Nothing
Set objcopy = Nothing
ThisDrawing.Regen (True)
'ThisDrawing.EndUndoMark


Case "S" 'SCALA (SCALE)
On Error GoTo OH_NO

With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set Selezione = .Add("$MoveTest$")
End With
Selezione.SelectOnScreen

Set objutil = ThisDrawing.Utility
strPrmt = vbCr & "Scala: "
punto = objutil.GetPoint(Prompt:=strPrmt)
puntoB = punto
puntoDA(0) = punto(0) - ThisDrawing.ActiveUCS.origin(0): puntoDA(1) = punto(1) - ThisDrawing.ActiveUCS.origin(1): puntoDA(2) = 0
punto1 = CVar(puntoDA)
strPrmt = vbCr & "Scala: "
objutil.initializeuserinput 33
punto = objutil.GetPoint(punto1, strPrmt)
puntoA(0) = punto(0) - ThisDrawing.ActiveUCS.origin(0): puntoA(1) = punto(1) - ThisDrawing.ActiveUCS.origin(1): puntoA(2) = 0
punto2 = CVar(puntoA)
puntomed...(0) = (punto1(0) + punto2(0)) / 2: puntomed...(1) = (punto1(1) + punto2(1)) / 2: puntomed...(2) = 0
text = CVar(puntomed...)
Set scalefactor = ThisDrawing.ModelSpace.AddDimAligned(punto1, punto2, text)
scalefactor.Visible = False
valore = scalefactor.Measurement / 4 'questo denominatore varia la sensibilitā della scala
For Each EntitāSelezione In Selezione
Set objcopy = EntitāSelezione.Copy
objcopy.ScaleEntity puntoB, valore
Next EntitāSelezione
Selezione.Erase
Set Selezione = Nothing
Set objutil = Nothing
Set objcopy = Nothing
ThisDrawing.Regen (True)


Case "I" 'INTERROMPI (BREAK)
On Error GoTo OH_NO

ThisDrawing.Utility.GetEntity entObj, Pnt, "Seleziona il primo PUNTO della linea in cui tagliare: "
Pnt2 = ThisDrawing.Utility.GetPoint(, "Seleziona il secondo PUNTO in cui tagliare: ")
puntoA(0) = Pnt2(0) - ThisDrawing.ActiveUCS.origin(0): puntoA(1) = Pnt2(1) - ThisDrawing.ActiveUCS.origin(1): puntoA(2) = 0
Pnt2 = CVar(puntoA)
det = GetDoubleEntTable(entObj, Pnt)
lspPnt1 = axPoint2lspPoint(Pnt)
lspPnt2 = axPoint2lspPoint(Pnt2)
ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & lspPnt1 & vbCr & lspPnt2 & vbCr
ThisDrawing.Regen (True)


Case "T" 'TAGLIA (BREAK AT POINT)
On Error GoTo OH_NO

ThisDrawing.Utility.GetEntity entObj, Pnt, "Seleziona la LINEA da tagliare: "
Pnt2 = ThisDrawing.Utility.GetPoint(, "Seleziona il PUNTO in cui tagliare: ")
puntoA(0) = Pnt2(0) - ThisDrawing.ActiveUCS.origin(0): puntoA(1) = Pnt2(1) - ThisDrawing.ActiveUCS.origin(1): puntoA(2) = 0
Pnt2 = CVar(puntoA)
det = GetDoubleEntTable(entObj, Pnt)
lspPnt = axPoint2lspPoint(Pnt2)
ThisDrawing.SendCommand "_break" & vbCr & det & vbCr & lspPnt & vbCr & "@" & vbCr 'lspPnt & vbCr
ThisDrawing.Regen (True)


Case "E" 'ELIMINA
On Error GoTo OH_NO

With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set Selezione = .Add("$MoveTest$")
End With
Selezione.SelectOnScreen

For Each EntitāSelezione In Selezione
EntitāSelezione.Erase
Next EntitāSelezione
Set Selezione = Nothing
ThisDrawing.Regen (True)


Case "L" 'LINEA TRATTEGGIATA
On Error GoTo OH_NO

With ThisDrawing.SelectionSets
While .Count > 0
.Item(0).Delete
Wend
Set Selezione = .Add("$MoveTest$")
End With
Selezione.SelectOnScreen

For Each EntitāSelezione In Selezione
EntitāSelezione.Linetype = "DASHEDX2"
Next EntitāSelezione
Set Selezione = Nothing
ThisDrawing.Regen (True)



Case "Z" 'ZOOM
On Error GoTo OH_NO

Set objutil = ThisDrawing.Utility
strPrmt = vbCr & "Clicca il primo angolo della zona in cui zoomare: "
punto1 = objutil.GetPoint(Prompt:=strPrmt)
strPrmt = vbCr & "Specifica il secondo angolo: "
objutil.initializeuserinput 33
punto2 = objutil.GetPoint(punto1, strPrmt)
ZoomWindow punto1, punto2


Case "P" 'ZOOMPRECEDENTE
On Error GoTo OH_NO 'qua l'errore non serve perchč non c'č modo di dare ESC, essendo repentino il comando
ZoomPrevious


Case "A" 'ANNULLA ULTIMO COMANDO (UNDO)
On Error GoTo OH_NO 'qua l'errore non serve perchč non c'č modo di dare ESC, essendo repentino il comando
ThisDrawing.SendCommand "_undo" & vbCr
ThisDrawing.SendCommand "1" & vbCr


Case "V" 'SALVA_STAMPA
On Error GoTo OH_NO 'qua l'errore non serve perchč non c'č modo di dare ESC, essendo repentino il comando
Exit Do


End Select

Set Selezione = Nothing

Loop Until scelta = "V"


OH_NO:
ThisDrawing.Utility.Prompt vbCrLf & Err.Description & vbCr
Resume se_premi_ESC_torna_qua
Err.Clear



Public Function GetDoubleEntTable(entObj As AcadEntity, Pnt As Variant) As String
Dim entHandle As String
entHandle = entObj.Handle
GetDoubleEntTable = "(list(handent " & Chr(34) & entHandle & Chr(34) & ")(list " & str(Pnt(0)) & str(Pnt(1)) & str(Pnt(2)) & "))"
End Function


'convert Point to LISP format
Public Function axPoint2lspPoint(Pnt As Variant) As String
axPoint2lspPoint = Replace(Pnt(0), ",", ".") & "," & Replace(Pnt(1), ",", ".") & "," & Pnt(2)
End Function


1   U L T I M E    R I S P O S T E    (in alto le pių recenti)
admin Inserito il - 11/11/2010 : 21:08:11
Ciao,
accidenti che papiro...
scusa ma non ce la faccio a starti dietro questi giorni, almeno durante la settimana.

© Torna all'inizio della Pagina
Tradotto Da: Vincenzo Daniele & Luciano Boccellino- www.targatona.it | Distribuito Da: Massimo Farieri - www.superdeejay.net | Powered By: - Snitz Forums 2000 Version 3.4.03

Antidoto.org | Brutto.it | Estela.org | Equiweb.it