VBA példák

 Egyszerű példák
 AutoCAD példák
 Saját objektum
 Komplex példa

Egyszerű példák

Első példa (Helló Világ)

Public Sub Hello ()
        MsgBox "Helló világ"
End Sub

Helló egy változata

Public Sub Hello1()
        MsgBox "Helló világ", vbInformation, "Első programom"
End Sub

Pi értéke

Public Function PI ()
        PI = 4# * Atn (1)
End Function

Függvény, eljárás paraméterek

Public Function KorTerulet(ByVal Sugar As Double) As Double
    KorTerulet = Sugar ^ 2 * PI
End Function

Public Function KorKerulet(Optional ByVal Sugar As Double = 5) As Double
    KorKerulet = 2# * Sugar * PI
End Function

Public Sub Szamit()
    Dim r As Double
    r = InputBox("Sugár:", "Kör")
    MsgBox "Terület: " & KorTerulet(r) & vbCrLf & _
        "Kerület: " & KorKerulet(r), , "Sugár=" & r
End Sub

Rekurzív függvény

Public Function faktorialis(ByVal n As Integer) As Integer
    If n > 0 Then
        faktorialis = faktorialis(n - 1) * n
    Else
        faktorialis = 1
    End If
End Function

AutoCAD példák

Hello AutoCAD világ

Public Sub HelloAcad()
    Dim beszurasiPont(0 To 2) As Double
    
    beszurasiPont(0) = 3#: beszurasiPont(1) = 4#: beszurasiPont(2) = 0#
    ThisDrawing.ModelSpace.AddText "Hello világ", _
        beszurasiPont, 2
    ZoomExtents
End Sub

Rétegek listája az aktuális rajzban

Public Sub RetegLista ()
        Dim Retegek As AcadLayers
        Dim Reteg As AcadLayer
        Dim RetegNevek As String

        Set Retegek = ThisDrawing.Layers
        RetegNevek = "Rétegek a rajzban:"+vbCrLf
        For Each Reteg In Retegek
                RetegNevek = RetegNevek + Reteg.Name & vbCrLf
        Next

        MsgBox RetegNevek
End Sub

Réteg létrehozás, ha még nem létezik és aktívvá tétel

Public Sub AktReteg ()
        Dim RetegNev As String

        RetegNev = InputBox("Új Réteg neve:")
        RetegNev = Trim(RetegNev)
        If RetegNev = "" Then Exit Sub ' ures a nev?

        On Error Resume Next     ' hibakezeles
        ThisDrawing.ActiveLayer = ThisDrawing.Layers(RetegNev)
        If Err Then
                ThisDrawing.Layers.Add RetegNev
                If Err Then
                        MsgBox RetegNev + " nevû réteget nem sikerült létrehozni" + _
                            vbCrLf + Err.Description
                Else
                        Set ThisDrawing.ActiveLayer = ThisDrawing.Layers(RetegNev)
                End If
        End If
End Sub

Feliratok átalakítása

Public Sub huntxt()
' lebego ekezetes feliratok atalakitasa
Dim ent As AcadObject

For Each ent In ThisDrawing.ModelSpace
    If ent.EntityType = acText Then
         ent.TextString = strconv(ent.TextString)
    End If
Next ent

End Sub

Public Function strconv(ByVal s As String)
Dim r As String
Dim i, j As Integer

r = Left(s, 1)
j = 1
For i = 2 To Len(s)
    Select Case Mid(s, i, 1)
        Case "'"
            r = Left(r, j - 1)
            Select Case Mid(s, i - 1, 1)
                Case "a"
                    r = r & "á"
                Case "e"
                    r = r & "é"
                Case "i"
                    r = r & "í"
                Case "o"
                    r = r & "ó"
                Case "u"
                    r = r & "ú"
                Case "A"
                    r = r & "Á"
                Case "E"
                    r = r & "É"
                Case "I"
                    r = r & "I"
                Case "O"
                    r = r & "Ó"
                Case "U"
                    r = r & "Ú"
                Case Else
                    r = r & "?"
            End Select
        Case ":"
            r = Left(r, j - 1)
            Select Case Mid(s, i - 1, 1)
                Case "o"
                    r = r & "ö"
                Case "u"
                    r = r + "ü"
                Case "O"
                    r = r & "Ö"
                Case "U"
                    r = r + "Ü"
                Case Else
                    r = r & "?"
            End Select
        Case """"
            r = Left(r, j - 1)
            Select Case Mid(s, i - 1, 1)
                Case "o"
                    r = r & "õ"
                Case "u"
                    r = r + "û"
                Case "O"
                    r = r & "Õ"
                Case "U"
                    r = r + "Û"
                Case Else
                    r = r & "?"
            End Select
        Case Else
            r = r & Mid(s, i, 1)
            j = j + 1
    End Select
Next i
strconv = r
End Function

Rajz tartalmának listázása

Public Sub dwg_list()
' informació az aktuális rajz rétegeinek tartalmáról
    If Documents.Count = 0 Then
        MsgBox "Nincs nyitott dokumentum"
        Exit Sub
    End If
    Dim ent As AcadObject
    Dim i, j, f As Integer
    Dim c, w, fname As String
    Dim extmi, extma As Variant
    Dim sli, stx, siv, spl, slw, sbl, sci, sdi, spt, sp3, sd3, _
        ssh, ssp, sat, sel, sha, sre, sso As Long
    ReDim names(ThisDrawing.Layers.Count - 1) As String
    ReDim li(ThisDrawing.Layers.Count - 1) As Long ' vonal
    ReDim tx(ThisDrawing.Layers.Count - 1) As Long ' szöveg
    ReDim iv(ThisDrawing.Layers.Count - 1) As Long ' ív
    ReDim pl(ThisDrawing.Layers.Count - 1) As Long ' vonallánc
    ReDim lw(ThisDrawing.Layers.Count - 1) As Long ' könnyû vonallánc
    ReDim bl(ThisDrawing.Layers.Count - 1) As Long ' blokk
    ReDim ci(ThisDrawing.Layers.Count - 1) As Long ' kör
    ReDim di(ThisDrawing.Layers.Count - 1) As Long ' méretezés
    ReDim pt(ThisDrawing.Layers.Count - 1) As Long ' pont
    ReDim p3(ThisDrawing.Layers.Count - 1) As Long ' 3d vonallánc
    ReDim d3(ThisDrawing.Layers.Count - 1) As Long ' 3d objektumok
    ReDim sh(ThisDrawing.Layers.Count - 1) As Long ' shape
    ReDim sp(ThisDrawing.Layers.Count - 1) As Long ' spline
    ReDim at(ThisDrawing.Layers.Count - 1) As Long ' attribútum definíció
    ReDim el(ThisDrawing.Layers.Count - 1) As Long ' ellipszis
    ReDim ha(ThisDrawing.Layers.Count - 1) As Long ' sraffozás
    ReDim re(ThisDrawing.Layers.Count - 1) As Long ' régió
    ReDim so(ThisDrawing.Layers.Count - 1) As Long ' szolid
    
    If ThisDrawing.FullName = "" Then
    ' meg nincs elmentve igy nem tudunk nevet adni az eredmény fájlnak
        MsgBox "Mentse el elõbb a rajzot és indítsa újra a makrót"
        Exit Sub
    End If

'   változók inicializálása
    sli = 0 ' vonalak száma a rajzban
    stx = 0 ' szövegek száma a rajzban
    siv = 0 ' körívek száma a rajzban
    spl = 0 ' vonalláncok száma a rajzban
    slw = 0 ' könnyû vonalláncok száma a rajzban
    sbl = 0 ' blokk beillesztések száma a rajzban
    sci = 0 ' körök száma a rajzban
    sdi = 0 ' méretvonalak száma a rajzban
    spt = 0 ' pontok száma a rajzban
    sp3 = 0 ' 3D-s vonalláncok száma a rajzban
    sd3 = 0 ' 3D-s objektumok száma a rajzban
    ssh = 0 ' shape beillesztések száma a rajzban
    ssp = 0 ' spline görbék száma a rajzban
    sat = 0 ' blokk attribútumok száma a rajzban
    sel = 0 ' ellipszisek száma a rajzban
    sha = 0 ' sraffozások száma a rajzban
    sre = 0 ' régiók száma a rajzban
    sso = 0 ' szolidok száma a rajzban
'   réteg nevek beszerzése
    For i = 0 To ThisDrawing.Layers.Count - 1
        names(i) = ThisDrawing.Layers.Item(i).Name
        li(i) = 0   ' vonalak száma a rétegen
        tx(i) = 0   ' szövegek száma a rétegen
        iv(i) = 0   ' ívek száma a rétegen
        pl(i) = 0   ' vonalláncok száma a rétegen
        lw(i) = 0   ' könnyû vonallálncok száma a rétegen
        bl(i) = 0   ' blokk beillesztések száma a rétegen
        di(i) = 0   ' méretvonalak száma a rétegen
        pt(i) = 0   ' pontok száma a rétegen
        p3(i) = 0   ' 3D-s vonalláncok száma a rétegen
        d3(i) = 0   ' 3D-s elemek száma a rétegen
        sh(i) = 0   ' shape beillesztések száma a rétegen
        sp(i) = 0   ' spline görbék száma a rétegen
        at(i) = 0   ' blokk attribútumok száma a rétegen
        el(i) = 0   ' ellipszisek száma a rétegen
        ha(i) = 0   ' sraffozások száma a rétegen
        re(i) = 0   ' régiók száma a rétegen
        so(i) = 0   ' szolidok száma a rétegen
    Next i
    ' retegnevek rendezese ABC-be
    For i = 0 To ThisDrawing.Layers.Count - 1
        For j = i + 1 To ThisDrawing.Layers.Count - 1
            If names(j) < names(i) Then
                w = names(j)
                names(j) = names(i)
                names(i) = w
            End If
        Next j
    Next i
    For Each ent In ThisDrawing.ModelSpace ' a modelltér minden elemére
        ' réteg index kikeresése
        For i = 0 To ThisDrawing.Layers.Count - 1
            If ent.Layer = names(i) Then
                Exit For
            End If
        Next
        Select Case ent.EntityType
            Case ac3dFace, ac3dSolid, acPolymesh
                d3(i) = d3(i) + 1
            Case ac3dPolyline
                p3(i) = p3(i) + 1
            Case acArc
                iv(i) = iv(i) + 1
            Case acAttribute
            Case acAttributeReference
                at(i) = at(i) + 1
            Case acBlockReference
                bl(i) = bl(i) + 1
            Case acCircle
                ci(i) = ci(i) + 1
            Case acDimAligned, acDimAngular, acDimDiametric, acDimOrdinate, _
                 acDimRadial, acDimRotated, acLeader, acTolerance
                di(i) = di(i) + 1
            Case acEllipse
                el(i) = el(i) + 1
            Case acGroup
            Case acHatch
                ha(i) = ha(i) + 1
            Case acLine
                li(i) = li(i) + 1
            Case acPoint
                pt(i) = pt(i) + 1
            Case acPolyline
                pl(i) = pl(i) + 1
            Case acPolylineLight
                lw(i) = lw(i) + 1
            Case acRegion
                re(i) = re(i) + 1
            Case acShape
                sh(i) = sh(i) + 1
            Case acSolid
                so(i) = so(i) + 1
            Case acSpline
                sp(i) = sp(i) + 1
            Case acText, acMtext
                tx(i) = tx(i) + 1
            Case acPViewport
            Case acRaster
            Case acRay
            Case acTrace
            Case acXline
        End Select
    Next ent
    ' output
    fname = Left(ThisDrawing.FullName, _
        InStr(UCase(ThisDrawing.FullName), ".DWG") - 1) & ".out"
    f = FreeFile
    Open fname For Output As f
    ' terjedelem
    extmi = ThisDrawing.GetVariable("EXTMIN")
    extma = ThisDrawing.GetVariable("EXTMAX")
    Print #f, ThisDrawing.Name
    Print #f, "Terjedelem"
    w = ThisDrawing.Utility.RealToString(extmi(0), acDecimal, 4)
    Print #f, "   xmin="; Space(12 - Len(w)); w;
    w = ThisDrawing.Utility.RealToString(extmi(1), acDecimal, 4)
    Print #f, "   ymin="; Space(12 - Len(w)); w;
    w = ThisDrawing.Utility.RealToString(extmi(2), acDecimal, 4)
    Print #f, "   zmin="; Space(12 - Len(w)); w
    w = ThisDrawing.Utility.RealToString(extma(0), acDecimal, 4)
    Print #f, "   xmax="; Space(12 - Len(w)); w;
    w = ThisDrawing.Utility.RealToString(extma(1), acDecimal, 4)
    Print #f, "   ymax="; Space(12 - Len(w)); w;
    w = ThisDrawing.Utility.RealToString(extma(2), acDecimal, 4)
    Print #f, "   zmax="; Space(12 - Len(w)); w
    Print #f, " "
    Print #f, "Réteg";
    ' táblázat fejléc
    Print #f, Space(27); "  pont vonal vonal könnyü  3D szöveg shape  " & _
        "kör  körív splin blokk attri ellip sraff régió solid    3D Méret"
    Print #f, Space(32); "              lánc  lánc  lánc"
    Print #f, String(140, "-")
    For i = 0 To ThisDrawing.Layers.Count - 1
        c = IIf(pt(i) + li(i) + pl(i) + lw(i) + p3(i) + tx(i) + sh(i) + _
                ci(i) + iv(i) + sp(i) + bl(i) + at(i) + el(i) + ha(i) + _
                re(i) + so(i) + d3(i) + di(i), " ", "*")
        Print #f, names(i); Space(31 - Len(names(i))); c;
        Print #f, Space(6 - Len(Str(pt(i)))); Str(pt(i));
        Print #f, Space(6 - Len(Str(li(i)))); Str(li(i));
        Print #f, Space(6 - Len(Str(pl(i)))); Str(pl(i));
        Print #f, Space(6 - Len(Str(lw(i)))); Str(lw(i));
        Print #f, Space(6 - Len(Str(p3(i)))); Str(p3(i));
        Print #f, Space(6 - Len(Str(tx(i)))); Str(tx(i));
        Print #f, Space(6 - Len(Str(sh(i)))); Str(sh(i));
        Print #f, Space(6 - Len(Str(ci(i)))); Str(ci(i));
        Print #f, Space(6 - Len(Str(iv(i)))); Str(iv(i));
        Print #f, Space(6 - Len(Str(sp(i)))); Str(sp(i));
        Print #f, Space(6 - Len(Str(bl(i)))); Str(bl(i));
        Print #f, Space(6 - Len(Str(at(i)))); Str(at(i));
        Print #f, Space(6 - Len(Str(el(i)))); Str(el(i));
        Print #f, Space(6 - Len(Str(ha(i)))); Str(ha(i));
        Print #f, Space(6 - Len(Str(re(i)))); Str(re(i));
        Print #f, Space(6 - Len(Str(so(i)))); Str(so(i));
        Print #f, Space(6 - Len(Str(d3(i)))); Str(d3(i));
        Print #f, Space(6 - Len(Str(di(i)))); Str(di(i))
        sli = sli + li(i)
        stx = stx + tx(i)
        siv = siv + iv(i)
        spl = spl + pl(i)
        slw = slw + lw(i)
        sbl = sbl + bl(i)
        sdi = sdi + di(i)
        spt = spt + pt(i)
        sp3 = sp3 + p3(i)
        sd3 = sd3 + d3(i)
        ssh = ssh + sh(i)
        ssp = ssp + sp(i)
        sat = sat + at(i)
        sel = sel + el(i)
        sha = sha + ha(i)
        sre = sre + re(i)
        sso = sso + so(i)
    Next i
    Print #f, String(140, "-")
    Print #f, Space(4 - Len(Str(ThisDrawing.Layers.Count))); _
        Str(ThisDrawing.Layers.Count); " rétegen összesen"; Space(11);
    Print #f, Space(6 - Len(Str(spt))); Str(spt);
    Print #f, Space(6 - Len(Str(sli))); Str(sli);
    Print #f, Space(6 - Len(Str(spl))); Str(spl);
    Print #f, Space(6 - Len(Str(slw))); Str(slw);
    Print #f, Space(6 - Len(Str(sd3))); Str(sd3);
    Print #f, Space(6 - Len(Str(stx))); Str(stx);
    Print #f, Space(6 - Len(Str(ssh))); Str(ssh);
    Print #f, Space(6 - Len(Str(sci))); Str(sci);
    Print #f, Space(6 - Len(Str(siv))); Str(siv);
    Print #f, Space(6 - Len(Str(ssp))); Str(ssp);
    Print #f, Space(6 - Len(Str(sbl))); Str(sbl);
    Print #f, Space(6 - Len(Str(sat))); Str(sat);
    Print #f, Space(6 - Len(Str(sel))); Str(sel);
    Print #f, Space(6 - Len(Str(sha))); Str(sha);
    Print #f, Space(6 - Len(Str(sre))); Str(sre);
    Print #f, Space(6 - Len(Str(sso))); Str(sso);
    Print #f, Space(6 - Len(Str(sd3))); Str(sd3);
    Print #f, Space(6 - Len(Str(sdi))); Str(sdi)
    Close f
End Sub

Blokkok táblázata

' blokkok megjelenítése táblazatosan
Public Sub blks(Optional ByVal x0 As Double = 0, Optional ByVal y0 As Double, _
        Optional ByVal dx As Double = 1, Optional ByVal dy As Double = 1)
    Dim b As AcadBlock
    Dim r As AcadBlockReference
    Dim i As Integer
    Dim p2(2) As Double
    Dim p1(2) As Double
    Dim n As String
    
    p1(0) = x0
    p1(1) = y0
    p1(2) = 0#
    p2(0) = x0 + dx
    p2(1) = y0
    p2(2) = 0#

    On Error Resume Next
    For i = 2 To ThisDrawing.Blocks.Count - 1
        Set b = ThisDrawing.Blocks.Item(i)
        n = b.Name
        If (Left(n, 1) <> "*") Then
            ThisDrawing.ModelSpace.InsertBlock p1, n, 1#, 1#, 1#, 0#
            ThisDrawing.ModelSpace.AddText n, p2, 1#
        End If
        p1(1) = p1(1) + dy
        p2(1) = p2(1) + dy
    Next
End Sub

Public Sub blocktable()
blks , , 3, 3
End Sub

Saját objektum létrehozás (Class modul)

Négyzet objektum osztály

Option Explicit
' objektum tulajdonságok, állapotok
Private a As Double ' oldalhossz
Private x As Double, y As Double    ' pozició
Private rajz As Boolean ' kirajzolva jelzés
Private ent As AcadEntity    ' hivatkozas az ACAD entitasra

Property Let side(oldal As Double)
    If oldal >= 0 Then
        a = oldal
    Else
        a = 0
    End If
End Property

Property Let PosX(xx As Double)
    x = xx
End Property

Property Let PosY(yy As Double)
    y = yy
End Property

Property Get side() As Double
    side = a
End Property

Property Get Xc() As Double
    Xc = x
End Property

Property Get Yc() As Double
    Yc = y
End Property

Property Get terulet()
    terulet = a ^ 2
End Property

Public Sub Display()
    Dim p(7) As Double
    Dim lw As AcadLWPolyline

    If Not rajz Then
        p(0) = x: p(1) = y
        p(2) = x + a: p(3) = y
        p(4) = x + a: p(5) = y + a
        p(6) = x: p(7) = y + a
    
        Set lw = ThisDrawing.ModelSpace.AddLightWeightPolyline(p)
        lw.Closed = True
        rajz = True
        Set ent = lw
    End If
End Sub

Public Sub Del()
    Dim kod(0) As Integer
    Dim ertek(0) As Variant
    Dim ss As AcadSelectionSet
    
    On Error Resume Next
    If rajz Then ent.Delete
End Sub

' konstruktor
Private Sub Class_Initialize()
    a = 1#: x = 0#: y = 0#
    rajz = False: Set ent = Nothing
End Sub

' destruktor
Private Sub Class_Terminate()
    
    Del ' törlés a rajzból
End Sub

Komplex példa

Pontok felrakása fájlból

Private Sub CancelButton_Click()
    ' párbeszéd ablak lezárása
    Unload Me
End Sub

Private Sub FileList_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
' dupla kattintás esetén csinálja ugyanazt mint az OK gomb megnyomásánál
    Call OkButton_Click
End Sub

Private Sub OkButton_Click()
    ' van kiválasztott elem ?
    If FileList.ListIndex = -1 Then
        MsgBox ("Válasszon egy fájlt")
        Exit Sub
    End If
    On Error GoTo betolt
    ' könytár váltás, ha sikertelen, akkor felrakja a fájl tartalmát
    ChDir (FileList.Value)
    On Error GoTo 0
    ' fájl lista tartalmának frissítése
    Call lista
    Exit Sub
betolt:
    ' pontok felrakása
    Call Felrak(FileList.Value, PszCheck.Value)
    ' párbeszéd ablak lezárása
    Unload Me
End Sub

Private Sub UserForm_Initialize()
    ' a fájl lista elsõ kitöltése
    Call lista
End Sub

Public Sub Felrak(ByVal fn As String, ByVal pszOn As Boolean)
' pontok felrakása fájlból
Dim f As Integer
Dim psz As String
Dim pnt(0 To 2) As Double
Dim pntObj As AcadPoint
Dim txtObj As AcadText

    On Error GoTo hiba
    ' input fájl megnyitása
    f = FreeFile
    Open fn For Input As f
    ' z koordináta nullázása (2D pont)
    pnt(2) = 0#
    ' pont szimbólum típusának beállítása
    ThisDrawing.SetVariable "PDMODE", 2
    ' pont szimbólum méretének beállítása
    ThisDrawing.SetVariable "PDSIZE", 1
    
    Do While Not EOF(f)
        Input #f, psz, pnt(0), pnt(1)
        If pszOn = True Then ' pontszám felírása
            Set txtObj = ThisDrawing.ModelSpace.AddText(psz, pnt, 2#)
        End If
        ' pont elhelyezése
        Set pntObj = ThisDrawing.ModelSpace.AddPoint(pnt)
    Loop
veg:
    Set pntObj = Nothing
    Set txtObj = Nothing
    Close f
    Exit Sub
hiba:
    MsgBox "Hibás sor az input fájlban"
    Resume veg
End Sub

Private Sub lista()

Dim fajl_nev As String
    
    ' fájl és könyvtárnevek listájának törlése
    FileList.Clear
    ' normal fájlok és könyvtárak nevei
    fajl_nev = Dir("*", vbDirectory)
    Do While fajl_nev <> ""
        ' elem hozzáadása a listához
        FileList.AddItem (fajl_nev)
        ' következõ könyvtár bejegyzés
        fajl_nev = Dir
    Loop
End Sub