Egyszerű példák - Belépés
VBA példák
Egyszerű példákAutoCAD 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
Utolsó módosítás: 2017. március 9., csütörtök, 19:38