James
Include "Icons.def"
Declare Sub Main
Declare Sub ChangeObjStyle
Declare Function AlterObjectFontStyle(ByVal oObject as Object, ByVal fFontStyle as Font) as Object
Declare Function AlterObjectSymbolStyle(ByVal oObject as Object, sSymbolStyle as Symbol) as Object
Declare Function AlterObjectPenStyle(ByVal oObject as Object, pPenStyle as Pen) as Object
Declare Function AlterObjectBrushStyle(ByVal oObject as Object, bBrushStyle as Brush) as Object
'-----------------------------------------------------------------
Sub Main
Print Chr$(12)
Print "Started ChangeObjStyle.mbx"
Create ButtonPad "Change Obj Style" asPushButton
Calling ChangeObjStyle
ID 1
Icon MI_ICON_WRENCH
End Sub
'-----------------------------------------------------------------
Sub ChangeObjStyle
OnError Goto CatchEx
Print "Clicked on Change Object Style button"
If SelectionInfo(SEL_INFO_NROWS) = 0 Then
Print "No Selection"
Note "You must select an object"
Exit Sub
End If
If SelectionInfo(SEL_INFO_NROWS) > 1 Then
Print "Selected " & SelectionInfo(SEL_INFO_NROWS) & " of objects"
Note "This tool is only designed to alter the object style of 1 object at a time!"
Exit Sub
End If
Dim objModify as Object
Fetch First From selection
objModify = selection.obj
Dim fFont as Font
fFont = MakeFont("Courier New", 0, 16,BLUE, -1) 'This is how you define a font
Dim sSymbol as Symbol
sSymbol = MakeSymbol(67,RED, 25) 'This is how you define a symbol style
Dim pPen as Pen
pPen = MakePen(1,92, RED) 'This is how you define a pen style
Dim bBrush as Brush
bBrush = MakeBrush(7,MAGENTA,-1) 'This is how you define a brush style
Do Case ObjectInfo(objModify, OBJ_INFO_TYPE)
Case OBJ_TYPE_ARC
objModify = AlterObjectPenStyle(objModify, pPen)
Case OBJ_TYPE_ELLIPSE
objModify = AlterObjectPenStyle(objModify, pPen)
objModify = AlterObjectBrushStyle(objModify, bBrush)
Case OBJ_TYPE_LINE
objModify = AlterObjectPenStyle(objModify, pPen)
Case OBJ_TYPE_PLINE
objModify = AlterObjectPenStyle(objModify, pPen)
Case OBJ_TYPE_POINT
objModify = AlterObjectSymbolStyle(objModify, sSymbol)
Case OBJ_TYPE_FRAME
objModify = AlterObjectPenStyle(objModify, pPen)
objModify = AlterObjectBrushStyle(objModify, bBrush)
Case OBJ_TYPE_REGION
objModify = AlterObjectPenStyle(objModify, pPen)
objModify = AlterObjectBrushStyle(objModify, bBrush)
Case OBJ_TYPE_RECT
objModify = AlterObjectPenStyle(objModify, pPen)
objModify = AlterObjectBrushStyle(objModify, bBrush)
Case OBJ_TYPE_ROUNDRECT
objModify = AlterObjectPenStyle(objModify, pPen)
objModify = AlterObjectBrushStyle(objModify, bBrush)
Case OBJ_TYPE_TEXT
objModify = AlterObjectFontStyle(objModify, fFont)
Case Else
Note "The selected object is an unknown object type" 'OBJ_TYPE_MULTIPOINT, OBJ_TYPE_COLLECTION
End Case
Update selection set obj = objModify
Done:
Exit Sub
CatchEx:
Note Error$()
Resume Done
End Sub
'-----------------------------------------------------------------
Function AlterObjectFontStyle(ByVal oObject as Object, ByVal fFontStyle as Font) as Object
OnError Goto CatchEx
Alter Object oObject
Info OBJ_INFO_TEXTFONT, fFontStyleAlterObjectFontStyle = oObject
Print "Altered font style"
Done:
Exit Sub
CatchEx:
Note Error$()
Resume Done
End Function
'-----------------------------------------------------------------
Function AlterObjectSymbolStyle(ByVal oObject as Object, sSymbolStyle as Symbol) as Object
OnError Goto CatchEx
Alter Object oObject
Info OBJ_INFO_SYMBOL, sSymbolStyle
AlterObjectSymbolStyle = oObject
Print "Altered symbol style"
Done:
Exit Sub
CatchEx:
Note Error$()
Resume Done
End Function
'-----------------------------------------------------------------
Function AlterObjectPenStyle(ByVal oObject as Object, pPenStyle as Pen) as Object
OnError Goto CatchEx
Alter Object oObject
Info OBJ_INFO_PEN, pPenStyle
AlterObjectPenStyle = oObject
Print "Altered pen style"
Done:
Exit Sub
CatchEx:
Note Error$()
Resume Done
End Function
'-----------------------------------------------------------------
Function AlterObjectBrushStyle(ByVal oObject as Object, bBrushStyle as Brush) as Object
OnError Goto CatchEx
Alter Object oObject
Info OBJ_INFO_BRUSH, bBrushStyle
AlterObjectBrushStyle = oObject
Print "Altered brush style"
Done:
Exit Sub
CatchEx:
Note Error$()
Resume Done
End Function
Very nice example, James
ReplyDeleteAlso note that you can use your AlterObject functions directly in a Update statement. This just requires that you are aware of what type of object you are altering:
Dim bBrush as Brush
bBrush = MakeBrush(7,MAGENTA,-1) 'This is how you define a brush style
Update MY_TABLE Set OBJ = AlterObjectBrushStyle(OBJ, bBrush)
And if you defined your functions using the ByVal on the style variables, you could also pass the MakeBrush function directly to the function
But still a very good example to an often seen question
Hi James
ReplyDeleteThanks for your tools that I have finished my work quickly. Based on your tools I have to edit and create my own tools. For tools I have created different characteristics than the one of you that I can do with multiple objects at once. I am very pleased to send you the tools that I have written to Sharing and I hope you can help me improve it better.
Ps: - Do you see “Bangmau5.dll” in the code? That is the icon of the tools created by my self for personal use (It is shown that the color that I wanted to fill). I want your email address to send you a complete tool I wrote. My address email is: Viethungifee@gmail.com
- I am a beginer MapBasic. Thank you and look forward to sharing many tools for me and everyone
Here is the code I have written tools:
include "mapbasic.def"
include "menu.def"
Dim B_Brushtyle As Brush
Dim MyCurrentObj As Object
Dim nRecords, i as integer
Declare Sub khongmausub
Declare Sub dosub
Declare Sub xanhsub
Declare Sub timsub
declare sub vangsub
declare sub main()
sub main ()
Create ButtonPad "Bang mau" As
toggleButton
Calling khongmausub
Icon 8003 file "bangmau5.dll"
togglebutton
Calling dosub
Icon 8001 file "bangmau5.dll"
togglebutton
calling vangsub
icon 8005 file "bangmau5.dll"
togglebutton
calling xanhsub
icon 8007 file "bangmau5.dll"
Title "Bangmau"
Width 10
Show
End Sub
sub khongmausub
nRecords = SelectionInfo(SEL_INFO_NROWS)
For i =1 To nRecords
Fetch rec i From Selection
MyCurrentObj = Selection.obj
B_Brushtyle = MakeBrush(1,RGB(0,0,0),0)
Alter Object MyCurrentObj
Info OBJ_INFO_BRUSH, B_Brushtyle
Update Selection Set obj = MyCurrentObj where RowID = i
Next
End Sub
sub dosub
nRecords = SelectionInfo(SEL_INFO_NROWS)
For i =1 To nRecords
Fetch rec i From Selection
MyCurrentObj = Selection.obj
B_Brushtyle = MakeBrush(2,RGB(255,0,0),0)
Alter Object MyCurrentObj
Info OBJ_INFO_BRUSH, B_Brushtyle
Update Selection Set obj = MyCurrentObj where RowID = i
Next
End Sub
sub vangsub
nRecords = SelectionInfo(SEL_INFO_NROWS)
For i =1 To nRecords
Fetch rec i From Selection
MyCurrentObj = Selection.obj
B_Brushtyle = MakeBrush(2,RGB(255,255,0),0)
Alter Object MyCurrentObj
Info OBJ_INFO_BRUSH, B_Brushtyle
Update Selection Set obj = MyCurrentObj where RowID = i
Next
End Sub
sub xanhsub
nRecords = SelectionInfo(SEL_INFO_NROWS)
For i =1 To nRecords
Fetch rec i From Selection
MyCurrentObj = Selection.obj
B_Brushtyle = MakeBrush(2,RGB(0,255,0),0)
Alter Object MyCurrentObj
Info OBJ_INFO_BRUSH, B_Brushtyle
Update Selection Set obj = MyCurrentObj where RowID = i
Next
End Sub
Hi Viet Hung,
ReplyDeleteI am glad that this site has helped you develop your tool. I will email you shortly :)
Cheers
Hello, this weekend is good for me, since this time i am reading this enormous informative article here at my home. CodCow
ReplyDeletehttps://www.youtube.com/watch?v=J6o4J9lp1y8
ReplyDeleteGrand Casino Las Vegas - Mapyro
ReplyDeleteGrand Casino 여수 출장안마 Las Vegas. 1750 Las Vegas 양산 출장마사지 Blvd South Las Vegas, 충주 출장마사지 NV 89109. 대구광역 출장마사지 Directions · (702) 770-7000. Call Now · More Info. Hours, Accepts 충주 출장마사지 Credit Cards, Accepts