Copyright © 2004-2022 SQL: 2.534 saniye - Sorgu: 83 - Ortalama: 0.03053 saniye
10.06.2015 11:42
güngör özay |
Merhabalar,
Internetten buldugum bir VBA kod yardimiyla, excelden autocade blok aktarabiliyorum. Blokun koordinatlarini, adini (Blok cizimde olmak kaydiyla) girip autocade mevcut koordinatlara bloku istedigimiz sayida atabiliyoruz. Yanliz ben sadece blok atmak istemiyorum. Aticagim bloklar attribute blok olacak ve attribute textlerin degerlerini de excelde girdigim datalardan alicak. Bununla ilgili olarak, zayif oldugum VBA sisteminde birseyler yapmaya calistim ancak basarili olamadim. Uygulama olarak gormeniz acisindan bir ornek dosya hazirladim ekledim. Ornegi calistirirsaniz ne demek istedigimi daha iyi anliycaginizi dusunuyorum. Forumda VBA ile ilgili bir konu yoktu buraya acmak zorunda kaldim. VBA bilgisi olan birileri yardim edebilirmi bu konu hakkinda ? Yardimlariniz icin simdiden tesekkurler... Kod: Option Explicit 229387-sample.rar
'A custom type that holds the scale factors of the block. Private Type ScaleFactor X As Double Y As Double Z As Double End Type Sub InsertBlocks() '-------------------------------------------------------------------------------------------------------------------------- 'Inserts blocks in AutoCAD using data - insertion point, block name/full path, scale factors, rotation angle - from Excel. 'Note that the block name or the block path must already exists, otherwise nothing will be inserted. 'The code uses late binding, so no reference to external AutoCAD (type) library is required. 'It goes without saying that AutoCAD must be installed at your computer before running this code. 'Written by: Christos Samaras 'Date: 21/04/2014 'e-mail: xristos.samaras@gmail.com 'site: http://www.myengineeringworld.net '-------------------------------------------------------------------------------------------------------------------------- ' Define the block 'Declaring the necessary variables. Dim acadApp As Object Dim height As Double Dim acadDoc As Object Dim acadBlock As Object Dim attributeObj As Object Dim LastRow As Long Dim i As Long Dim InsertionPoint(0 To 2) As Double Dim BlockName As String Dim BlockScale As ScaleFactor Dim RotationAngle As Double Dim tag As String Dim value As String Dim prompt As String tag = "ATT1" value = Range("E3") height = 250 'Activate the coordinates sheet and find the last row. With Sheets("Coordinates") .Activate LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row End With 'Check if there are coordinates for at least one circle. If LastRow < 2 Then MsgBox "There are no coordinates for the insertion point!", vbCritical, "Insertion Point Error" Exit Sub End If 'Check if AutoCAD application is open. If is not opened create a new instance and make it visible. On Error Resume Next Set acadApp = GetObject(, "AutoCAD.Application") If acadApp Is Nothing Then Set acadApp = CreateObject("AutoCAD.Application") acadApp.Visible = True End If 'Check (again) if there is an AutoCAD object. If acadApp Is Nothing Then MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error" Exit Sub End If On Error GoTo 0 'If there is no active drawing create a new one. On Error Resume Next Set acadDoc = acadApp.ActiveDocument If acadDoc Is Nothing Then Set acadDoc = acadApp.Documents.Add End If On Error GoTo 0 'Check if the active space is paper space and change it to model space. If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding End If On Error Resume Next 'Loop through all the rows and add the corresponding blocks in AutoCAD. With Sheets("Coordinates") For i = 2 To LastRow 'Set the block name. BlockName = .Range("D" & i).value 'If the block name is not empty, insert the block. If BlockName <> vbNullString Then 'Set the insertion point. InsertionPoint(0) = .Range("A" & i).value InsertionPoint(1) = .Range("B" & i).value InsertionPoint(2) = .Range("C" & i).value 'Initialize the optional parameters. BlockScale.X = 1 BlockScale.Y = 1 BlockScale.Z = 1 RotationAngle = 0 'Add the block using the sheet data (insertion point, block name, scale factors and rotation angle). 'The 0.0174532925 is to convert degrees into radians. Set attributeObj = acadBlock.AddAttribute(height, _ prompt, InsertionPoint, tag, value) Set acadBlock = acadDoc.ModelSpace.InsertBlock(InsertionPoint, BlockName, _ BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925) End If Next i End With 'Zoom in to the drawing area. acadApp.ZoomExtents 'Release the objects. Set acadBlock = Nothing Set acadDoc = Nothing Set acadApp = Nothing End Sub
|
10.06.2015 13:53
Travaci |
Örnek block ve exel dosyası ?
|
10.06.2015 14:02
güngör özay |
Mesajin altnda link olarak bulunuyor.
|
15.06.2015 10:41
güngör özay |
Kimsenin bir fikri yok sanirim ?
|
16.06.2015 06:54
Travaci |
Pc de exel olmadığını unutmuşum : ) Resmini çekip gönderirsen müsait bir zamanda bakıcam.
|
16.06.2015 09:21
güngör özay |
Alıntı Selam, Aslinda excel tablosunun formati nasil oldugu cok onemli degil. Sadece istedigim bir hucredeki veriyi benim belirttigim attribute tag ine aktarmak istiyorum.Ornek yaptigim excelin resmini ekliyorum. Yardimci olabilirsen cok memnun olurum :)
|
17.06.2015 09:14
özkan-wien |
|
17.06.2015 09:27
güngör özay |
Alıntı Verdigin ornegi biliyorum yanliz benim istedigim tam olarak onu yansitmiyor. Senin gonderdiginde sadece cizimdeki mevcut blok uzerinde tagleri editliyoruz. Verdigim dosyadaki exceli ve dwg yi kullanabilrsen ne demek istedigimi daha iyi anlatmis olurum. Tesekkurler yinede...
|
17.06.2015 09:32
özkan-wien |
evet,fikir olsun diye attim, vaktim olunca bakacagim
|
20.06.2015 10:32
miyatu |
Alıntı Kod: Option Explicit 'A custom type that holds the scale factors of the block. Private Type ScaleFactor X As Double Y As Double Z As Double End Type Sub InsertBlocks() '-------------------------------------------------------------------------------------------------------------------------- 'Inserts blocks in AutoCAD using data - insertion point, block name/full path, scale factors, rotation angle - from Excel. 'Note that the block name or the block path must already exists, otherwise nothing will be inserted. 'The code uses late binding, so no reference to external AutoCAD (type) library is required. 'It goes without saying that AutoCAD must be installed at your computer before running this code. 'Written by: Christos Samaras 'Date: 21/04/2014 'e-mail: xristos.samaras@gmail.com 'site: http://www.myengineeringworld.net '-------------------------------------------------------------------------------------------------------------------------- ' Define the block 'Declaring the necessary variables. Dim acadApp As Object Dim height As Double Dim acadDoc As Object Dim acadBlock As Object Dim attributeObj As Object Dim LastRow As Long Dim I As Long Dim insertionPoint(0 To 2) As Double Dim BlockName As String Dim BlockScale As ScaleFactor Dim RotationAngle As Double 'Activate the coordinates sheet and find the last row. With Sheets("Coordinates") .Activate LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row End With 'Check if there are coordinates for at least one circle. If LastRow < 2 Then MsgBox "There are no coordinates for the insertion point!", vbCritical, "Insertion Point Error" Exit Sub End If 'Check if AutoCAD application is open. If is not opened create a new instance and make it visible. On Error Resume Next Set acadApp = GetObject(, "AutoCAD.Application") If acadApp Is Nothing Then Set acadApp = CreateObject("AutoCAD.Application") acadApp.Visible = True End If 'Check (again) if there is an AutoCAD object. If acadApp Is Nothing Then MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error" Exit Sub End If On Error GoTo 0 'If there is no active drawing create a new one. On Error Resume Next Set acadDoc = acadApp.ActiveDocument If acadDoc Is Nothing Then Set acadDoc = acadApp.Documents.Add End If On Error GoTo 0 'Check if the active space is paper space and change it to model space. If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding End If On Error Resume Next 'Loop through all the rows and add the corresponding blocks in AutoCAD. With Sheets("Coordinates") For I = 2 To LastRow 'Set the block name. BlockName = .Range("D" & I).Value 'If the block name is not empty, insert the block. If BlockName <> vbNullString Then 'Set the insertion point. insertionPoint(0) = .Range("A" & I).Value insertionPoint(1) = .Range("B" & I).Value insertionPoint(2) = .Range("C" & I).Value 'Initialize the optional parameters. BlockScale.X = 1 BlockScale.Y = 1 BlockScale.Z = 1 RotationAngle = 0 'Add the block using the sheet data (insertion point, block name, scale factors and rotation angle). 'The 0.0174532925 is to convert degrees into radians. Set acadBlock = acadDoc.ModelSpace.InsertBlock(insertionPoint, BlockName, _ BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925) ' Get the attributes for the block reference Dim varAttributes As Variant varAttributes = acadBlock.GetAttributes ' Move the attribute tags and values into a string to be displayed in a Msgbox Dim strAttributes As String Dim k As Integer For k = LBound(varAttributes) To UBound(varAttributes) strAttributes = strAttributes & vbLf & " Tag: " & varAttributes(I).TagString & _ vbLf & " Value: " & varAttributes(I).TextString & vbLf & " " Next ' Change the value of the attribute ' Note: There is no SetAttributes. Once you have the variant array, you have the objects. ' Changing them changes the objects in the drawing. varAttributes(0).TextString = Range("I" & I) varAttributes(1).TextString = Range("H" & I) varAttributes(2).TextString = Range("G" & I) varAttributes(3).TextString = Range("F" & I) varAttributes(4).TextString = Range("E" & I) End If Next I End With 'Zoom in to the drawing area. End Sub Kolay gelsin...
|
20.06.2015 10:36
güngör özay |
Alıntı Adamsin Miyatu on numara olmus :wink
|
22.10.2016 13:50
elk21 |
miyatu üstadım yazmış olduğun bu lispi nasıl kullanabilirim
|
mttlp |
Alıntıbu lisp değil vba dır
|