New Copy Paste Function

I have written a Function to copy and paste from autocad that will allow someone to paste to original coordinates within the same drawing. To do this, I had to ignore the current copyclip and pasteclip and write new ones. One of the problems I am having is when pasting, I wish to be able to see the objects (dragmode). I have used sendcommand for this, but when I use the middle mouse button to pan, the function continues on and screws up the insertion. Anybody have any suggestions?

Here is the code I have for now

Public RegPt(0 To 2) As Double

Public Function MJCopy(CopyType As String)
' This sub returns a bounding box of entities selected on screen.

Dim lBox, uBox As Variant, pfss As AcadSelectionSet, ss1 As AcadSelectionSet
Dim x1, y1, x2, y2 As Double
Dim I As Long, MinX As Double, MinY As Double, MinXY(0 To 1) As Double, MaxX As Double, MaxY As Double
Dim TempPath As String, TempTime As String, TempFilename As String
Dim OldInsBaseVal As Variant, NewPoint As Variant

OldInsBaseVal = ThisDrawing.GetVariable("Insbase")

Set pfss = ThisDrawing.PickfirstSelectionSet
If pfss.count = 0 Then
' Add a selection set, if it already exists, set it to be active
On Error Resume Next
Set ss1 = ThisDrawing.SelectionSets.Add("CopySet")
If Err Then
Set ss1 = ThisDrawing.SelectionSets("CopySet")
End If
On Error GoTo 0
ss1.Clear
' Add entities to a selection set by prompting user to select on the Screen
ss1.SelectOnScreen
Else
Set ss1 = pfss
End If

' Get the bounding box of the first item in the selection set (if Sel Set is not empty)
If ss1.count > 0 Then
ss1(0).GetBoundingBox lBox, uBox
MinX = lBox(0)
MinY = lBox(1)
MaxX = uBox(0)
MaxY = uBox(1)
End If

' Iterate through the objects in the selection set
' (first one has already been done so start at one)
For I = 1 To ss1.count - 1
' Get the bounding box of the current object
ss1(I).GetBoundingBox lBox, uBox

' Get the Lower (x, y) of the bounding box of the entity
x1 = lBox(0)
y1 = lBox(1)

' Get the Upper (x, y) of the bounding box of the entity
x2 = uBox(0)
y2 = uBox(1)

' grow the group's bounding box to include the object's
If x1 < MinX Then MinX = x1
If y1 < MinY Then MinY = y1
If x2 > MaxX Then MaxX = x2
If y2 > MaxY Then MaxY = y2
Next 'i

MinXY(0) = MinX: MinXY(1) = MinY

TempPath = ThisDrawing.GetVariable("tempprefix")
TempTime = ThisDrawing.GetVariable("cdate")
TempTime = Mid(TempTime, 1, 8) & Mid(TempTime, 10, Len(TempTime))
TempFilename = TempPath & TempTime & ".dwg"

SaveSetting "AutoDesk Applications", "MJCopyClip", "InsertionPointX", MinX
SaveSetting "AutoDesk Applications", "MJCopyClip", "InsertionPointY", MinY
SaveSetting "AutoDesk Applications", "MJCopyClip", "TempFile", TempFilename

If CopyType = "CopyBase" Or CopyType = "CutBase" Then
NewPoint = ThisDrawing.Utility.GetPoint(, "Select Base Point:")
Else
NewPoint = MinXY
End If
ThisDrawing.Wblock TempFilename, ss1
If CopyType = "CutClip" Or CopyType = "CutBase" Then
ss1.Erase
End If


End Function
Public Function MJPaste(PasteType As String)

Dim InsFilename As String, InsPt As Variant
Dim Insblk As AcadBlockReference, Insblkname As String

RegPt(0) = GetSetting("AutoDesk Applications", "MJCopyClip", "InsertionPointX")
RegPt(1) = GetSetting("AutoDesk Applications", "MJCopyClip", "InsertionPointY")
RegPt(2) = 0
InsFilename = GetSetting("AutoDesk Applications", "MJCopyClip", "TempFile")

If ThisDrawing.GetVariable("ctab") = "Model" Then
Set Insblk = ThisDrawing.ModelSpace.InsertBlock(RegPt, InsFilename, 1, 1, 1, 0)
Else
Set Insblk = ThisDrawing.PaperSpace.InsertBlock(RegPt, InsFilename, 1, 1, 1, 0)
End If

Insblkname = Insblk.Name

If PasteType <> "PasteOrig" Then
ThisDrawing.SendCommand "move" & vbCr & "last" & vbCr & vbCr & RegPt(0) & "," & RegPt(1) & "," & RegPt(2) & vbCr
End If
If PasteType <> "PasteBlock" Then
Insblk.Explode
Insblk.Delete
ThisDrawing.Blocks(Insblkname).Delete
Exit Function
End If
End Function
Sub CopyClip()
CopyType = "CopyClip"
MJCopy (CopyType)
End Sub
Sub CopyBase()
CopyType = "CopyBase"
MJCopy (CopyType)
End Sub
Sub CutClip()
CopyType = "CutClip"
MJCopy (CopyType)
End Sub
Sub CutBase()
CopyType = "CutBase"
MJCopy (CopyType)
End Sub
Sub Pasteclip()
PasteType = "PasteClip"
MJPaste (PasteType)
End Sub
Sub PasteOrig()
PasteType = "PasteOrig"
MJPaste (PasteType)
End Sub
Sub PasteBlock()
PasteType = "PasteBlock"
MJPaste (PasteType)
End Sub

 

I have written a Function to copy and paste from autocad that will allow

Ok, sorry for the diversion but I gotta ask...why would someone paste to
the original coordinates in the same drawing? And better yet, why re-write
copy/paste when all you need to do is convert the selected entities to a
blockreference?

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

Good questions,

First, I like to paste between viewports (north arrows, drawing titles, etc...) and the current pasteorig will not allow that.
Secondly, all copying and pasting is, is wblocking to a temp file and inserting from a temp file, but because autocad writes the filename to the clipboard, it only pastes to drawings not containing that name, which requires me to rewrite the copy routine to avoid using the clipboard.

If anybody knows how to read and modify the clipboard object created by autocad, I would prefer to build on a function already working.

As for changing the normal copyclip to copybase @ 0,0, that won't work because, when you just paste normally, the insertion point won't be at the lower left boundary like it should be.

 

Interesting idea. Unfortunately, I haven't messed around with the
copy/paste of an AutoCAD object. If you can't get it to work, you could
still do it within AutoCAD:

1. select your stuff
2. create a block with them
3. switch to your viewport and insert the new block
4. you could even explode the insert if needed

Only thing your missing would be using the copy/paste and ctrl+c/ctrl+v
commands

-- Mike
___________________________
Mike Tuersley
CADalyst's CAD Clinic
Rand IMAGINiT Technologies
___________________________
the trick is to realize that there is no spoon...

 

johnsonm,

I've got something that copies and pastes to the original
coordinates between files. It does use the "_copybase"
command and "_pasteorig". Therefore it can paste back into
the same drawing, though I would not know why one would
want to do that unless one was changing UCS or one was
using the "_pasteblock" command instead of "_pasteorig". I
think you could start with this code. I'm afraid you'll have to sort through the stuff that does not apply::

Option Explicit
Public OpMode As Integer
Public NotNew As Boolean
Public FloatMode As Integer

Sub CopyAtOrigin()
Dim CmdStr As String
Dim ssetObj As AcadSelectionSet
Dim stat As Integer
OpMode = 0 ' 0 = copypast
stat = ZapSSSet("COPYSET")
Set ssetObj = ThisDrawing.SelectionSets.Add("COPYSET")
' Add entities to a selection set by prompting user to select on the screen
ssetObj.SelectOnScreen
If ssetObj.Count = 0 Then
CycleFiles
Else
CmdStr = "_copybase" + vbCr + "0,0" + vbCr + "prev" + vbCr + vbCr
ThisDrawing.SendCommand CmdStr
ufPickTarget.Hide
ufPickTarget.SetPerOpMode
ufPickTarget.Show
End If
End Sub

Sub CycleFiles()
Dim stat As Integer
OpMode = 1 ' 1 = cycle files
FloatMode = 1
ufPickTarget.Hide
ufPickTarget.Show vbModeless
End Sub

' zapz existing ss if there is one, returns 1 if so
Private Function ZapSSSet(ssname As String) As Integer
Dim ssetObj As AcadSelectionSet
Dim sset As AcadSelectionSet
ZapSSSet = 0
For Each sset In ThisDrawing.SelectionSets
If sset.Name = ssname Then
sset.Delete
ZapSSSet = 1
Exit For
End If
Next
End Function

..............................
This is the action button in the PickTarget form. You would
probably be using "_pasteblock" instead of "_pasteorig". I
tried "_pasteblock" in the source dwg and it seemed to work
for as many times as needed.
............................

Private Sub cbProceed_Click()
ufPickTarget.Hide
Dim X As Integer
Dim CmdStr As String
Dim Docname As String
Select Case OpMode
Case 0
CmdStr = "_pasteorig" + vbCr
For X = 0 To ufPickTarget.lbFilesOpen.ListCount - 1
If ufPickTarget.lbFilesOpen.Selected(X) = True Then
Docname = ufPickTarget.lbFilesOpen.List(X)
NotNew = True
Application.Documents(Docname).Activate
NotNew = False
Application.Documents(Docname).ActiveSpace = SpaceType
ThisDrawing.SendCommand CmdStr
End If
Next
OpMode = 1
FloatMode = 1
UpDateListBox
SetPerOpMode
ShowMe
Case 1
Me.Hide
RunMacro VPBrowserN
ShowMe
End Select
End Sub

AKS