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: 640 x 480 800 x 600 1024 x 768 1280 x 1024 Nome Utente: Password: Icona Messaggio:                             Messaggio:   * Il codice HTML č ON * Il Codice Forum č OFF [quote][i]Messaggio inserito da Lucakit[/i] [br]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 [/quote]    Allega file   Clicca qui per sottoscrivere questa Discussione.