Create new class with attributes of selected object

michaelk · September 21, 2016

I'd like a new contextual click / menu command to create a new class with the graphic attributes of the selected object.

mk

Pat Stanford · December 3, 2016

Michael, I thought this would be one you would do for yourself.

Run as a script or make a Menu Item PIO out of the script and add to the right click menu.

Procedure MakeClassWithObjAttribs;

{© 2016, Pat Stanford pat@coviana.com}
{Licensed under the GNU Lesser General Public License}
{No warranty or guarantee, expressed or implied. Use at your own risk.}
{Test for suitability for your use before using on live data.}
{Immediately discontinue use if hair loss occurs.}

{December 2, 2016}
{This script creates a new class and sets the class attributes to those of the selected}
{object. The only parameter that is not set is TextStyle}
{Based on a request on the tech board by michaelk, September 21, 2016.}

Var	FPat:							LongInt;
	FillBackR,FillBackG,FillBackB:	LongInt;
	FillForeR,FillForeG,FillForeB:	LongInt;	
	LineS:							LongInt;  {Name List Index}
	LineW:							Integer;
	ObjBMarkStyl:					LongInt;
	ObjBMarkAngle:					Integer;
	ObjBMarkSize:					Real;
	ObjBMarkWidth:					Real;
	ObjBMarkThickB:					Integer;
	ObjBMarkThick:					Real;
	ObjBMarkVis:					Boolean;
	ObjEMarkStyl:					LongInt;
	ObjEMarkAngle:					Integer;
	ObjEMarkSize:					Real;
	ObjEMarkWidth:					Real;
	ObjEMarkThickB:					Integer;
	ObjEMarkThick:					Real;
	ObjEMarkVis:					Boolean;
	POpacity:						Integer;
	FOpacity:						Integer;
	PenBackR,PenBackG,PenBackB:		LongInt;
	PenForeR,PenForeG,PenForeB:		LongInt;
	DSEnabled:						Boolean;
	DSnUnits:						Integer;
	DSdOffset:						Real;
	DSdBlurRadius:					Real;
	DSdAngle:						Real;
	DSOpacity:						Integer;
	DSRed:							Integer;
	DSGreen:						Integer;
	DSBlue:							Integer;
	ThisObject:						Handle;
	SelectedCount:					LongInt;
	ReturnBool:						Boolean;
	NewClassName:					String;
	SetExistingClass:				Boolean;
	
	Function ClassExists(ClsName:String):Boolean;
		var	ThisClass:LongInt;
			ChkClsName:String;
		Begin
			ClassExists:=False;
			For ThisClass := 1 to ClassNum do
				If ClassList(ThisClass)=ClsName then ClassExists:=True;
		End;
		
		
		
Begin
	ThisObject:=Nil;
	If NumSObj(ActLayer) =1 then 
		Begin
			ThisObject:=FSActLayer;
			FPat := GetFPat(ThisObject);
			GetFillBack(ThisObject,FillBackR,FillBackG,FillBackB);
			GetFillFore(ThisObject,FillForeR,FillForeG,FillForeB);
			LineS:=GetLSN(ThisObject);
			LineW:=GetLW(ThisObject);
			ReturnBool:=GetObjBeginningMarker(ThisObject,ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
								ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick,
								ObjBMarkVis);
			ReturnBool:=GetObjEndMarker(ThisObject,ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,ObjEMarkWidth,
									ObjEMarkThickB,ObjEMarkThick,ObjEMarkVis);
			ReturnBool:=GetOpacityN(ThisObject,POpacity,FOpacity);
			GetPenBack(ThisObject,PenBackR,PenBackG,PenBackB);
			GetPenFore(ThisObject,PenForeR,PenForeG,PenForeB);
			DSEnabled:=IsDropShadowEnabled(ThisObject);
			ReturnBool:=GetDropShadowData(ThisObject,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
									
			NewClassName:=StrDialog('Enter the name for the new class',
					Concat('NewClass_',Date(2,2)));
					
			SetExistingClass:=False;
					
			If ClassExists(NewClassName) then
				SetExistingClass:=YNDialog('Class already exists. Set attributes to match object?');
				
			If SetExistingClass or NOT ClassExists(NewClassName) then
				Begin
					NameClass(NewClassName);
					SetClFPat(NewClassName,FPat);
					SetClFillBack(NewClassName,FillBackR,FillBackG,FillBackB);
					SetClFillFore(NewClassName,FillForeR,FillForeG,FillForeB);
					SetClLSN(NewClassName,LineS);
					SetClLW(NewClassName,LineW);
					ReturnBool:=SetClassBeginningMarker(NewClassName,
									ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
									ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick);
					ReturnBool:=SetClassEndMarker(NewClassName,
									ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,
									ObjEMarkWidth,ObjEMarkThickB,ObjEMarkThick);
					SetClOpacityN(NewClassName,FOpacity,POpacity);

					SetClPenBack(NewClassName,PenBackR,PenBackG,PenBackB);
					SetClPenFore(NewClassName,PenForeR,PenForeG,PenForeB);
					EnableCLDropShadow(NewClassName,DSEnabled);
					SetCLDrpShadowData(NewClassName,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
				End
			Else AlrtDialog('No Changes Made');
		End
	Else
		AlrtDialog('A problem occured. Make sure a single object is selected.');
End;

Run(MakeClassWithObjAttribs);

michaelk · December 3, 2016

Pat

I never even thought of writing a script to do that!

And I wouldn't have thought that a script to do this would use so many variables!

Thanks, Pat. I'm adding this to my workspace!

mk

michaelk · May 9, 2017

This has been really helpful, Pat.

I'm posting a slight update to it.

This script is the exactly the same as the above except:

1. The newly created script will have "Use At Creation" checked.

2. The active class will not change from the currently active class to the newly created class.

Procedure MakeClassWithObjAttribs;

{© 2016, Pat Stanford pat@coviana.com}
{Licensed under the GNU Lesser General Public License}
{No warranty or guarantee, expressed or implied. Use at your own risk.}
{Test for suitability for your use before using on live data.}
{Immediately discontinue use if hair loss occurs.}

{December 2, 2016}
{This script creates a new class and sets the class attributes to those of the selected}
{object. The only parameter that is not set is TextStyle}
{Based on a request on the tech board by michaelk, September 21, 2016.}
{Updated by Michael Klaers May 8 2017.}
{Changes:	1)  Newly created class will have "Use At Creation" checked.}
{			2)  Active class will not change to newly created class.}



Var	FPat:							LongInt;
	FillBackR,FillBackG,FillBackB:	LongInt;
	FillForeR,FillForeG,FillForeB:	LongInt;	
	LineS:							LongInt;  {Name List Index}
	LineW:							Integer;
	ObjBMarkStyl:					LongInt;
	ObjBMarkAngle:					Integer;
	ObjBMarkSize:					Real;
	ObjBMarkWidth:					Real;
	ObjBMarkThickB:					Integer;
	ObjBMarkThick:					Real;
	ObjBMarkVis:					Boolean;
	ObjEMarkStyl:					LongInt;
	ObjEMarkAngle:					Integer;
	ObjEMarkSize:					Real;
	ObjEMarkWidth:					Real;
	ObjEMarkThickB:					Integer;
	ObjEMarkThick:					Real;
	ObjEMarkVis:					Boolean;
	POpacity:						Integer;
	FOpacity:						Integer;
	PenBackR,PenBackG,PenBackB:		LongInt;
	PenForeR,PenForeG,PenForeB:		LongInt;
	DSEnabled:						Boolean;
	DSnUnits:						Integer;
	DSdOffset:						Real;
	DSdBlurRadius:					Real;
	DSdAngle:						Real;
	DSOpacity:						Integer;
	DSRed:							Integer;
	DSGreen:						Integer;
	DSBlue:							Integer;
	ThisObject:						Handle;
	SelectedCount:					LongInt;
	ReturnBool:						Boolean;
	NewClassName:					String;
	SetExistingClass:				Boolean;
	ActiveClassName:				STRING;
	
	Function ClassExists(ClsName:String):Boolean;
		var	ThisClass:LongInt;
			ChkClsName:String;
		Begin
			ClassExists:=False;
			For ThisClass := 1 to ClassNum do
				If ClassList(ThisClass)=ClsName then ClassExists:=True;
		End;
		
		
		
Begin
	ThisObject:=Nil;
	If NumSObj(ActLayer) =1 then 
		Begin
			ThisObject:=FSActLayer;
			FPat := GetFPat(ThisObject);
			GetFillBack(ThisObject,FillBackR,FillBackG,FillBackB);
			GetFillFore(ThisObject,FillForeR,FillForeG,FillForeB);
			LineS:=GetLSN(ThisObject);
			LineW:=GetLW(ThisObject);
			ReturnBool:=GetObjBeginningMarker(ThisObject,ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
								ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick,
								ObjBMarkVis);
			ReturnBool:=GetObjEndMarker(ThisObject,ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,ObjEMarkWidth,
									ObjEMarkThickB,ObjEMarkThick,ObjEMarkVis);
			ReturnBool:=GetOpacityN(ThisObject,POpacity,FOpacity);
			GetPenBack(ThisObject,PenBackR,PenBackG,PenBackB);
			GetPenFore(ThisObject,PenForeR,PenForeG,PenForeB);
			DSEnabled:=IsDropShadowEnabled(ThisObject);
			ReturnBool:=GetDropShadowData(ThisObject,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
									
			NewClassName:=StrDialog('Enter the name for the new class',
					Concat('NewClass_',Date(2,2)));
					
			SetExistingClass:=False;
					
			If ClassExists(NewClassName) then
				SetExistingClass:=YNDialog('Class already exists. Set attributes to match object?');
				
			If SetExistingClass or NOT ClassExists(NewClassName) then
				Begin
					ActiveClassName := ActiveClass;
					NameClass(NewClassName);
					SetClFPat(NewClassName,FPat);
					SetClFillBack(NewClassName,FillBackR,FillBackG,FillBackB);
					SetClFillFore(NewClassName,FillForeR,FillForeG,FillForeB);
					SetClLSN(NewClassName,LineS);
					SetClLW(NewClassName,LineW);
					ReturnBool:=SetClassBeginningMarker(NewClassName,
									ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
									ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick);
					ReturnBool:=SetClassEndMarker(NewClassName,
									ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,
									ObjEMarkWidth,ObjEMarkThickB,ObjEMarkThick);
					SetClOpacityN(NewClassName,FOpacity,POpacity);

					SetClPenBack(NewClassName,PenBackR,PenBackG,PenBackB);
					SetClPenFore(NewClassName,PenForeR,PenForeG,PenForeB);
					EnableCLDropShadow(NewClassName,DSEnabled);
					SetCLDrpShadowData(NewClassName,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
					SetClUseGraphic(NewClassName,TRUE);
					NameClass(ActiveClassName);													
				End
			Else AlrtDialog('No Changes Made');
		End
	Else
		AlrtDialog('A problem occured. Make sure a single object is selected.');
End;

Run(MakeClassWithObjAttribs);

Ethan R. · May 10, 2017

Thank you !

I was able to add as a menu item - now I need to hunt down how to add as a right click item

Thank you!
Ethan

PVA - Admin · May 10, 2017

In the Workspace Editor, you should be able to add any menu command to right-click by adding the menu command under Object Context:

59131b85d0dfd_ScreenShot2017-05-10at9_53_24AM.png.c1834899c0939d882e24e9f186bbb379.png

(Document Context is when you right click in a blank area of your drawing.)

markdd · August 2, 2017

On 09/05/2017 at 7:13 AM, michaelk said:

This has been really helpful, Pat.

I'm posting a slight update to it.

This is a really useful script

@michaelk could you highlight the changes you made to the script as I would like to try an "in between" version so that the new class is set to the active class and the class attributes are set to "Use at creation". It would be good to understand what you did so that I can make the slight change to the script.

Many thanks

michaelk · August 2, 2017

Mark

I added exactly two lines of code. I actually wrote more comments than code.

My two lines of code added to Pat's 100 lines sounds pretty typical.

This is what I added:

SetClUseGraphic(NewClassName,TRUE);
NameClass(ActiveClassName);

If you delete the NameClass function it should do what you want.

mk

markdd · August 3, 2017

That's got it. Thanks Michael

Mark

michaelk · October 4, 2018

Here's a newer version. This one

1. Creates a new class with the attributes of the selected object.

2. Keeps the active class active.

AND

3. Puts the selected object in the new class.

Procedure MakeClassWithObjAttribs;

{© 2016, Pat Stanford pat@coviana.com}
{Licensed under the GNU Lesser General Public License}
{No warranty or guarantee, expressed or implied. Use at your own risk.}
{Test for suitability for your use before using on live data.}
{Immediately discontinue use if hair loss occurs.}

{December 2, 2016}
{This script creates a new class and sets the class attributes to those of the selected}
{object. The only parameter that is not set is TextStyle}
{Based on a request on the tech board by michaelk, September 21, 2016.}

{Updated by Michael Klaers May 8 2017.}
{Changes:	1)  Newly created class will have "Use At Creation" checked.}
{			2)  Active class will not change to newly created class.}

{Updated by Michael Klaers October 2 2018}
{Changes:	3)  Selected object will be in the new class, not the active class}



Var	FPat:							LongInt;
	FillBackR,FillBackG,FillBackB:	LongInt;
	FillForeR,FillForeG,FillForeB:	LongInt;	
	LineS:							LongInt;  {Name List Index}
	LineW:							Integer;
	ObjBMarkStyl:					LongInt;
	ObjBMarkAngle:					Integer;
	ObjBMarkSize:					Real;
	ObjBMarkWidth:					Real;
	ObjBMarkThickB:					Integer;
	ObjBMarkThick:					Real;
	ObjBMarkVis:					Boolean;
	ObjEMarkStyl:					LongInt;
	ObjEMarkAngle:					Integer;
	ObjEMarkSize:					Real;
	ObjEMarkWidth:					Real;
	ObjEMarkThickB:					Integer;
	ObjEMarkThick:					Real;
	ObjEMarkVis:					Boolean;
	POpacity:						Integer;
	FOpacity:						Integer;
	PenBackR,PenBackG,PenBackB:		LongInt;
	PenForeR,PenForeG,PenForeB:		LongInt;
	DSEnabled:						Boolean;
	DSnUnits:						Integer;
	DSdOffset:						Real;
	DSdBlurRadius:					Real;
	DSdAngle:						Real;
	DSOpacity:						Integer;
	DSRed:							Integer;
	DSGreen:						Integer;
	DSBlue:							Integer;
	ThisObject:						Handle;
	SelectedCount:					LongInt;
	ReturnBool:						Boolean;
	NewClassName:					String;
	SetExistingClass:				Boolean;
	ActiveClassName:				STRING;
	
	Function ClassExists(ClsName:String):Boolean;
		var	ThisClass:LongInt;
			ChkClsName:String;
		Begin
			ClassExists:=False;
			For ThisClass := 1 to ClassNum do
				If ClassList(ThisClass)=ClsName then ClassExists:=True;
		End;
		
		
		
Begin
	ThisObject:=Nil;
	If NumSObj(ActLayer) =1 then 
		Begin
			ThisObject:=FSActLayer;
			FPat := GetFPat(ThisObject);
			GetFillBack(ThisObject,FillBackR,FillBackG,FillBackB);
			GetFillFore(ThisObject,FillForeR,FillForeG,FillForeB);
			LineS:=GetLSN(ThisObject);
			LineW:=GetLW(ThisObject);
			ReturnBool:=GetObjBeginningMarker(ThisObject,ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
								ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick,
								ObjBMarkVis);
			ReturnBool:=GetObjEndMarker(ThisObject,ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,ObjEMarkWidth,
									ObjEMarkThickB,ObjEMarkThick,ObjEMarkVis);
			ReturnBool:=GetOpacityN(ThisObject,POpacity,FOpacity);
			GetPenBack(ThisObject,PenBackR,PenBackG,PenBackB);
			GetPenFore(ThisObject,PenForeR,PenForeG,PenForeB);
			DSEnabled:=IsDropShadowEnabled(ThisObject);
			ReturnBool:=GetDropShadowData(ThisObject,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
									
			NewClassName:=StrDialog('Enter the name for the new class',
					Concat('NewClass_',Date(2,2)));
					
			SetExistingClass:=False;
					
			If ClassExists(NewClassName) then
				SetExistingClass:=YNDialog('Class already exists. Set attributes to match object?');
				
			If SetExistingClass or NOT ClassExists(NewClassName) then
				Begin
					ActiveClassName := ActiveClass;
					NameClass(NewClassName);
					SetClFPat(NewClassName,FPat);
					SetClFillBack(NewClassName,FillBackR,FillBackG,FillBackB);
					SetClFillFore(NewClassName,FillForeR,FillForeG,FillForeB);
					SetClLSN(NewClassName,LineS);
					SetClLW(NewClassName,LineW);
					ReturnBool:=SetClassBeginningMarker(NewClassName,
									ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
									ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick);
					ReturnBool:=SetClassEndMarker(NewClassName,
									ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,
									ObjEMarkWidth,ObjEMarkThickB,ObjEMarkThick);
					SetClOpacityN(NewClassName,FOpacity,POpacity);

					SetClPenBack(NewClassName,PenBackR,PenBackG,PenBackB);
					SetClPenFore(NewClassName,PenForeR,PenForeG,PenForeB);
					EnableCLDropShadow(NewClassName,DSEnabled);
					SetCLDrpShadowData(NewClassName,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
					SetClUseGraphic(NewClassName,TRUE);
					NameClass(ActiveClassName);			
					SetClass(ThisObject,NewClassName);															
				End
			Else AlrtDialog('No Changes Made');
		End
	Else
		AlrtDialog('A problem occured. Make sure a single object is selected.');
End;

Run(MakeClassWithObjAttribs);

Boh · October 4, 2018

I'd love to be able to use this script however when I copy it, and paste it into a new script in VW, then try to run it on an object I get an error message.

I've tried multiple times and am being very careful to copy the whole script. I tried this same method on another (simpler) script posted in the forum and the copy & paste worked the first time but thereafter, trying the same thing with the same script, again I kept getting error messages.

This has happened to me before and last time a helpful user posted the script as a vw file for me. I assumed I had missed some text in the copy.

Frustrating! Here is a short video of what I'm doing. Am I missing something?

michaelk · October 4, 2018

That's crazy.

See if the script in this file works:

New Class From Object Script.vwx

michaelk · October 4, 2018

The error message you are getting says there is an error on line 2.

But line 2 is blank.

I just did exactly what you did in your screen capture movie. (Thanks for that. It was very clear.) Copied the above script and pasted it into a script palette. It worked.

I'm very interested to know if the script in the attached file runs for you.

Pat Stanford · October 4, 2018

I always try to past scripts into a "code" block (click on the <> icon above the edit window). That will ensure that everything is truly text and not some extended unicode text like object. It also keeps tab formatting correct rather than compressing everything to the left margin.

My question would be what browser you are each using and what operating system. I know Michael is on Mac and it looks like Boh is on Windows.

My guess is that whatever browser Boh is using is sticking some invisible characters into the text when copied that are then confusing the VS compiler.

michaelk · October 4, 2018

Pat, I was thinking the same thing. Maybe the browser saw the line 2 carriage return -- CHR(13) -- as something else?

Boh · October 4, 2018

You are right Pat. I'm using chrome with windows. When I tried copying and pasting from Firefox it worked! Thanks again for your advice.

I didn't understand this though:

55 minutes ago, Pat Stanford said:

I always try to past scripts into a "code" block (click on the <> icon above the edit window). That will ensure that everything is truly text and not some extended unicode text like object. It also keeps tab formatting correct rather than compressing everything to the left margin.

Which "edit" window? Is there another coding app I should paste into? (Sorry for ignorance).

Michael, thanks for the VW file. Yes it works on my machine on your file as well as when I export to my test file.

This is a very useful script. Thanks!

Boh · October 4, 2018

Loving this script! One "little" improvement could be if the selected object then takes on it's new class attributes. ATM it retains it's object attributes not the class attributes of it's newly created class. 🙂

michaelk · October 4, 2018

When you're composing a forum post there is a button between the quote and emoji buttons that looks like <>

This will give you a window to paste code that keeps formatting.

Everything you type into the regular window is probably converted to something else to be formatted for the web. One of the things you loose is blank space in front of the line, so indentations get lost.

Especially bad since indentations have actual meaning in Python!

michaelk · October 4, 2018

2 minutes ago, Boh said:

Loving this script! One "little" improvement could be if the selected object then takes on it's new class attributes. ATM it retains it's object attributes not the class attributes of it's newly created class. 🙂

Ha! I never noticed before.

Let me see if I can fix that. (Pat may beat me to it!)

Boh · October 4, 2018

7 minutes ago, michaelk said:

When you're composing a forum post there is a button between the quote and emoji buttons that looks like <>

This will give you a window to paste code that keeps formatting.

Ok so that's just for people posting scripts. For copying scripts then it seems to ensure it formats correctly for me best to just use Firefox (at least not chrome).

michaelk · October 4, 2018

This rarely happens. I usually can't look up all the functions, make 5 syntax errors, correct them and test a script in the time it takes Pat to just type it out.

I'm assuming Mr. Stanford isn't at his computer at the moment 🙂

Here's the new script:

New Class From Object Script II.vwx

Boh · October 4, 2018

Very fast - wasn't expecting that! Thanks Michael. 🙂

Pat Stanford · October 5, 2018

I was near the computer, but I have been on 7 conference calls and a lunch meeting today. Hard to script with all that background rigmarole going on 😉

Michaels explanation of the code block being in the forum was exactly what I meant.

mgries · October 19, 2018

Great work everyone!!! This is a gem!

Now all we need is a second contextual click / menu command to put below this one that updates the designated class of the selected object with the overwritten graphic attributes of said object! Think of it as the all too often needed "option B" workflow scenario.

On 9/21/2016 at 10:53 AM, michaelk said:

I'd like a new contextual click / menu command to create a new class with the graphic attributes of the selected object.

michaelk · October 19, 2018

That's a great idea.

I'm sure it will happen 🙂

michaelk · October 20, 2018

Try this:

Procedure MakeClassWithObjAttribs;

{*************************************************

This is a fork of the original script described in the comments below.

*************************************************}

{Unceremoniously an inelegantly forked by Michael Klaers October 19, 2018}

{This script will update the class of the selected object 
to have the attributes that the object currently has.

It will force that class to be Use at Creation and 
the object will be forced to have all attribues by class}

{*********************************************************}

{© 2016, Pat Stanford pat@coviana.com}
{Licensed under the GNU Lesser General Public License}
{No warranty or guarantee, expressed or implied. Use at your own risk.}
{Test for suitability for your use before using on live data.}
{Immediately discontinue use if hair loss occurs.}

{December 2, 2016}
{This script creates a new class and sets the class attributes to those of the selected}
{object. The only parameter that is not set is TextStyle}
{Based on a request on the tech board by michaelk, September 21, 2016.}

{Updated by Michael Klaers May 8 2017.}
{Changes:	1)  Newly created class will have "Use At Creation" checked.}
{			2)  Active class will not change to newly created class.}

{Updated by Michael Klaers October 2 2018}
{Changes:	3)  Selected object will be in the new class, not the active class}

{Updated by Michael Klaers October 4 2018}
{Changes:  	4) Selected object attributes will all be by class}


Var	FPat:							LongInt;
	FillBackR,FillBackG,FillBackB:	LongInt;
	FillForeR,FillForeG,FillForeB:	LongInt;	
	LineS:							LongInt;  {Name List Index}
	LineW:							Integer;
	ObjBMarkStyl:					LongInt;
	ObjBMarkAngle:					Integer;
	ObjBMarkSize:					Real;
	ObjBMarkWidth:					Real;
	ObjBMarkThickB:					Integer;
	ObjBMarkThick:					Real;
	ObjBMarkVis:					Boolean;
	ObjEMarkStyl:					LongInt;
	ObjEMarkAngle:					Integer;
	ObjEMarkSize:					Real;
	ObjEMarkWidth:					Real;
	ObjEMarkThickB:					Integer;
	ObjEMarkThick:					Real;
	ObjEMarkVis:					Boolean;
	POpacity:						Integer;
	FOpacity:						Integer;
	PenBackR,PenBackG,PenBackB:		LongInt;
	PenForeR,PenForeG,PenForeB:		LongInt;
	DSEnabled:						Boolean;
	DSnUnits:						Integer;
	DSdOffset:						Real;
	DSdBlurRadius:					Real;
	DSdAngle:						Real;
	DSOpacity:						Integer;
	DSRed:							Integer;
	DSGreen:						Integer;
	DSBlue:							Integer;
	ThisObject:						Handle;
	SelectedCount:					LongInt;
	ReturnBool:						Boolean;
	NewClassName:					String;
	SetExistingClass:				Boolean;
	ActiveClassName:				STRING;
	
	Function ClassExists(ClsName:String):Boolean;
		var	ThisClass:LongInt;
			ChkClsName:String;
		Begin
			ClassExists:=False;
			For ThisClass := 1 to ClassNum do
				If ClassList(ThisClass)=ClsName then ClassExists:=True;
		End;
		
		
		
Begin
	ThisObject:=Nil;
	If NumSObj(ActLayer) =1 then 
		Begin
			ThisObject:=FSActLayer;
			FPat := GetFPat(ThisObject);
			GetFillBack(ThisObject,FillBackR,FillBackG,FillBackB);
			GetFillFore(ThisObject,FillForeR,FillForeG,FillForeB);
			LineS:=GetLSN(ThisObject);
			LineW:=GetLW(ThisObject);
			ReturnBool:=GetObjBeginningMarker(ThisObject,ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
								ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick,
								ObjBMarkVis);
			ReturnBool:=GetObjEndMarker(ThisObject,ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,ObjEMarkWidth,
									ObjEMarkThickB,ObjEMarkThick,ObjEMarkVis);
			ReturnBool:=GetOpacityN(ThisObject,POpacity,FOpacity);
			GetPenBack(ThisObject,PenBackR,PenBackG,PenBackB);
			GetPenFore(ThisObject,PenForeR,PenForeG,PenForeB);
			DSEnabled:=IsDropShadowEnabled(ThisObject);
			ReturnBool:=GetDropShadowData(ThisObject,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
									
			NewClassName:=GetClass(ThisObject);
					
			SetExistingClass:=False;
					
		
				
			
					ActiveClassName := ActiveClass;
					NameClass(NewClassName);
					SetClFPat(NewClassName,FPat);
					SetClFillBack(NewClassName,FillBackR,FillBackG,FillBackB);
					SetClFillFore(NewClassName,FillForeR,FillForeG,FillForeB);
					SetClLSN(NewClassName,LineS);
					SetClLW(NewClassName,LineW);
					ReturnBool:=SetClassBeginningMarker(NewClassName,
									ObjBMarkStyl,ObjBMarkAngle,ObjBMarkSize,
									ObjBMarkWidth,ObjBMarkThickB,ObjBMarkThick);
					ReturnBool:=SetClassEndMarker(NewClassName,
									ObjEMarkStyl,ObjEMarkAngle,ObjEMarksize,
									ObjEMarkWidth,ObjEMarkThickB,ObjEMarkThick);
					SetClOpacityN(NewClassName,FOpacity,POpacity);

					SetClPenBack(NewClassName,PenBackR,PenBackG,PenBackB);
					SetClPenFore(NewClassName,PenForeR,PenForeG,PenForeB);
					EnableCLDropShadow(NewClassName,DSEnabled);
					SetCLDrpShadowData(NewClassName,DSnUnits,DSdOffset,
									DSdBlurRadius,DSdAngle,DSOpacity,
									DSRed,DSGreen,DSBlue);
					SetClUseGraphic(NewClassName,TRUE);
					NameClass(ActiveClassName);			
					SetClass(ThisObject,NewClassName);				
					SetFPatByClass(ThisObject);
					SetFillColorByClass(ThisObject);
					SetLSByClass(ThisObject);
					SetLWByClass(ThisObject);
					SetMarkerByClass(ThisObject);
					SetOpacityByClass(ThisObject);
					SetPenColorByClass(ThisObject);
					SetTextStyleByClass(ThisObject);

				
		
		End
	
End;

Run(MakeClassWithObjAttribs);

Update Class.vwx

Create new class with attributes of selected object

Question

Link to comment

Top Posters For This Question

Popular Days

Top Posters For This Question

Popular Days

Popular Posts

michaelk

Pat Stanford

michaelk

Posted Images

61 answers to this question

Recommended Posts

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Link to comment

Join the conversation

Announcements