Απλή μεταφορά σχεδιαστικών αντικειμένων από φύλλο εργασίας του Excel , κατευθείαν στο Autocad

Αρκετές φορές είναι επιθυμητή η "μεταφορά" παραμέτρων από τα κελλιά κάποιου φύλλου εργασίας στο Excel , κατευθείαν στο Autocad . Αν έχει γίνει πλήρης εγκατάσταση και των δύο προγραμμάτων , με μια σχετικά απλή διαδικασία , μπορεί να υλοποιηθεί μια "γέφυρα" μεταξύ των δύο προγραμμάτων . Βέβαια , απαιτούνται κάποιες βασικές γνώσεις προγραμματισμού αλλά στα αρχεία βοήθειας του Autocad εξηγείται αναλυτικά η διαδικασία .

1. Σύνδεση Excel με το Autocad

Sub AcadConnect()

On Error Resume Next

Set AcadApp = GetObject(, "Autocad.Application")
If Err Then
    Err.Clear
    Set AcadApp = CreateObject("Autocad.Application")
    AcadApp.Visible = True
    If Err Then
        MsgBox Err.Description
        Exit Sub
    End If
End If

End Sub

2. Βασικές διαδικασίες για την σχεδίαση απλών αντικειμένων

Sub AcadLine(xs As Double, ys As Double, xe As Double, ye As Double, LayerName As String)
    Dim sp(0 To 2) As Double
    Dim ep(0 To 2) As Double
    
    sp(0) = xs
    sp(1) = ys
    sp(2) = 0#
    ep(0) = xe
    ep(1) = ye
    ep(2) = 0#
    
    Set LineObj = AcadApp.ActiveDocument.ModelSpace.AddLine(sp, ep)
    
    LineObj.Layer = LayerName
End Sub
Sub AcadRect(orgx As Double, orgy As Double, platos As Double, ypsos As Double, LayerName As String)
    Dim x(5) As Double, y(5) As Double
    Dim np As Integer
    
    np = 5

    
    x(1) = orgx: y(1) = orgy
    x(2) = orgx + platos: y(2) = orgy
    x(3) = orgx + platos: y(3) = orgy - ypsos
    x(4) = orgx: y(4) = orgy - ypsos
    x(5) = orgx: y(5) = orgy

    For i = 1 To 4
        AcadLine x(i), y(i), x(i + 1), y(i + 1), LayerName
    Next
End Sub

Sub AcadText(xp, yp, h, Angle, LayerName, txt)
    Dim pp(0 To 2) As Double
    
    pp(0) = xp: pp(1) = yp: pp(2) = 0#
    Set TextObj = AcadApp.ActiveDocument.ModelSpace.AddText(txt, pp, h)
    TextObj.Rotation = Angle
    TextObj.Layer = LayerName
End Sub

Κατεβάστε από εδώ το αρχείο Excel για άμεσους πειραματισμούς .