Posle dugo traganja za makro-om koji ce odredjeni opseg iz excel fajla iskopirati u aktivni fajl AutoCad-a ili da sam otvori novi fajl pa u njemu iskopirati opseg bezuspesno se vracam na istu temu.
U prikazenom excel fajlu u "G" koloni su vrednosti (opseg cici broj celija varira), koje treba iskopirati u comandnoj liniji (CTRL+V) u AutoCad-u.
Nasao sam neki kod koji od prilike treba da odradi ono sto meni treba, ali cim sam ga modifikovao u startu je nastao problem prilikom kontrole
originalni kod
Code:
Sub DrawPoints()
'Declaring the necessary variables.
Dim acadApp As Object
Dim acadDoc As Object
Dim acadCircle As Object
Dim LastRow As Long
Dim i As Long
Dim Point(0 To 2) 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 point.
If LastRow < 2 Then
MsgBox "There are no coordinates to draw a point!", vbCritical, "Point Coordinates Error"
Exit Sub
End If
'Check if AutoCAD application is open.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
'If AutoCAD is not opened create a new instance and make it visible.
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
'Loop through all the coordinates and draw the corresponding point(s).
With Sheets("Coordinates")
'Set the point type.
acadDoc.SetVariable "PDMODE", .Range("E1").Value
'Set the point size.
acadDoc.SetVariable "PDSIZE", .Range("G1").Value
'Loop through all the coordinates.
For i = 2 To LastRow
'Set the point coordinates.
Point(0) = .Range("A" & i).Value
Point(1) = .Range("B" & i).Value
Point(2) = .Range("C" & i).Value
'Draw the point.
acadDoc.ModelSpace.addpoint (Point)
Next i
End With
'Zoom in to the drawing area.
acadApp.ZoomExtents
'Release the objects.
Set acadCircle = Nothing
Set acadDoc = Nothing
Set acadApp = Nothing
'Inform the user about the process.
MsgBox "The point(s) was/were successfully drawn in AutoCAD!", vbInformation, "Finished"
End Sub
modifikovani kod
Code:
Sub KOPIRANJE()
'Proglasavanje potrebne varijable.
Dim acadApp As Object
Dim acadDoc As Object
Dim acadCircle As Object
Dim LastRow As Long
Dim i As Long
Dim Point(0 To 2) As Double
Dim Range As Range
'Aktivirajte koordinata list i pronadite zadnjem redu.
With Sheets("Coordinates")
.Activate
LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row
Range("G7:(LastRow = .Cells(.Rows.Count, "G").End(xlUp).Row)".Select
Selection.Copy
End With
'Provjerite da li postoje koordinate za barem jedne tacke.
If LastRow < 2 Then
MsgBox "There are no coordinates to draw a point!", vbCritical, "Point Coordinates Error"
Exit Sub
End If
'Provjerite da li AutoCAD aplikacija otvorena.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
'Ako se ne otvara AutoCAD stvoriti novu instancu i dozvati.
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If
'Proveri (opet) ako postoji AutoCAD objekt.
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0
'Ukoliko ne postoji aktivno crtež stvoriti novu.
On Error Resume Next
Set acadDoc = acadApp.ActiveDocument
If acadDoc Is Nothing Then
Set acadDoc = acadApp.Documents.Add
End If
On Error GoTo 0
'Provjerite da li je aktivan prostor je papir prostor i promijeniti ga u prostor modela.
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding
Selection.Paste
End If
'Priblizi podrucje na crtezu .
acadApp.ZoomExtents
'Oslobodite objekte.
Set acadCircle = Nothing
Set acadDoc = Nothing
Set acadApp = Nothing
'Obavijestiti korisnika o procesu.
MsgBox "The point(s) was/were successfully drawn in AutoCAD!", vbInformation, "Finished"
End Sub
odmah posle pronalazenja zadnje celije iz ranga pocrveni deo koda koji treba da selektuje rang i kopira
U excel fajlu su snimljeni i originalni i modifikovani kod
Dali neko moze zna kako ovaj problem prevazici
sve ce ovo jednom proci