Pages

Friday 30 May 2014

Change Object Style with Mapbasic (Alter or Change Front, Symbol, Pen or Brush Style of an object)

I have seen a lot of questions asking how to change an object style in MapInfo programatically with Mapbasic. This example demonstrates how to define a font, symbol, pen and brush style and apply a style to an object. To run and test this demo, copy the code below and compile, select an object in a map window and click the wrench tool button to see how the code modifies object styles base on the type of object selected. The image below shows what the object will look like when you click the change object style button. Feel free to use these functions in your code :)

James 


Include "Mapbasic.def"
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

6 comments:

  1. Very nice example, James

    Also 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

    ReplyDelete
  2. Hi James
    Thanks 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

    ReplyDelete
  3. Hi Viet Hung,

    I am glad that this site has helped you develop your tool. I will email you shortly :)

    Cheers

    ReplyDelete
  4. Hello, this weekend is good for me, since this time i am reading this enormous informative article here at my home. CodCow

    ReplyDelete
  5. https://www.youtube.com/watch?v=J6o4J9lp1y8

    ReplyDelete
  6. Grand Casino Las Vegas - Mapyro
    Grand 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

    ReplyDelete