New topic: How to convert a VB 6 User Control to work with RealBasic
<http://forums.realsoftware.com/viewtopic.php?t=33594> Page 1 of 1 [ 1 post ] Previous topic | Next topic Author Message pjalm Post subject: How to convert a VB 6 User Control to work with RealBasicPosted: Thu Apr 29, 2010 9:02 am Joined: Thu Apr 29, 2010 5:02 am Posts: 1 Is it possible to convert a User Control to work in RealBasic? I have included one of the many User Controls I have in a project that I am trying to convert but can not figure out how to make it work. Any help would be greatly appreciated. Code:VERSION 5.00 Begin VB.UserControl ButtonMatrix BackColor = &H00808000& BorderStyle = 1 'Fixed Single ClientHeight = 885 ClientLeft = 0 ClientTop = 0 ClientWidth = 870 ScaleHeight = 885 ScaleWidth = 870 Begin VB.CommandButton Question BackColor = &H00FFFF00& Height = 615 Index = 1 Left = 120 Style = 1 'Graphical TabIndex = 0 Top = 120 Width = 615 End End Attribute VB_Name = "ButtonMatrix" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = True Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Option Explicit Dim NumCols As Integer Dim NumRows As Integer Dim ButtonLabels As String Dim ButtonTags As String Dim BttnEnabled As String Dim BttnSpacing As Integer Dim BttnHeight As Integer Dim BttnWidth As Integer Dim BttnMode As ModeType Dim BttnUpColor As OLE_COLOR Dim BttnDownColor As OLE_COLOR Dim Borders As Boolean Dim ControlColor As OLE_COLOR Dim ControlStyle As StyleType Dim ControlEnabled As Boolean Const DefaultHeight = 1095 Const DefaultWidth = 2535 Const DefaultSpace = 120 Const DefaultUpColor = &HFFFF00 Const DefaultDownColor = &HFFFF& Const DefaultBackColor = &H808000 Const DefaultStyle = 1 Enum ButtonType CommandButtons = 0 NormalButtons = 1 End Enum Enum ModeType LeftToRight = 0 TopToBottom = 1 End Enum Enum StyleType Transparent = 0 Opaque = 1 End Enum Private WithEvents m_Font1 As StdFont Attribute m_Font1.VB_VarHelpID = -1 Event ButtonPressed(ByVal Index As Integer, ByVal Value As String, ByVal Tag As String) Private Sub m_font1_FontChanged(ByVal PropertyName As String) Dim i As Integer On Error Resume Next For i = 1 To (NumRows * NumCols) Set Question(i).Font = m_Font1 Next On Error GoTo 0 End Sub Public Property Get Font() As Font Set Font = m_Font1 End Property Public Property Set Font(ByVal tmpVal As Font) m_Font1.Bold = tmpVal.Bold m_Font1.Charset = tmpVal.Charset m_Font1.Italic = tmpVal.Italic m_Font1.Name = tmpVal.Name m_Font1.Size = tmpVal.Size m_Font1.Strikethrough = tmpVal.Strikethrough m_Font1.Underline = tmpVal.Underline m_Font1.Weight = tmpVal.Weight PropertyChanged "Font" End Property Private Sub Question_Click(Index As Integer) If Index > 0 Then RaiseEvent ButtonPressed(Index, Trim(Question(Index).Caption), Trim(Question(Index).Tag)) End If End Sub Public Property Let Mode(ByVal tmpVal As ModeType) BttnMode = tmpVal Call Show PropertyChanged "Mode" End Property Public Property Get Mode() As ModeType Mode = BttnMode End Property Public Property Let ShowBorder(ByVal tmpVal As Boolean) Borders = tmpVal Call Show PropertyChanged "ShowBorder" End Property Public Property Get ShowBorder() As Boolean ShowBorder = Borders End Property Public Property Let Enabled(ByVal tmpVal As Boolean) Call EnableBttns ControlEnabled = tmpVal Call EnableBttns PropertyChanged "Enabled" End Property Public Property Get Enabled() As Boolean Enabled = ControlEnabled End Property Public Property Let Spacing(ByVal tmpVal As Integer) BttnSpacing = tmpVal Call Show PropertyChanged "Spacing" End Property Public Property Get Spacing() As Integer Spacing = BttnSpacing End Property Public Property Let Columns(ByVal NumBttns As Integer) If NumBttns <= 0 Then Exit Property If NumBttns > 8 Then Exit Property Call Clear NumCols = NumBttns Call Show PropertyChanged "Columns" End Property Public Property Get Columns() As Integer Columns = NumCols End Property Public Property Let Rows(ByVal NumBttns As Integer) If NumBttns <= 0 Then Exit Property If NumBttns > 8 Then Exit Property Call Clear NumRows = NumBttns Call Show PropertyChanged "Rows" End Property Public Property Get Rows() As Integer Rows = NumRows End Property Public Property Let ButtonsEnabled(ByVal tmpBttns As String) BttnEnabled = tmpBttns Call EnableBttns PropertyChanged "ButtonsEnabled" End Property Public Property Get ButtonsEnabled() As String ButtonsEnabled = BttnEnabled End Property Public Property Let Captions(ByVal BttnCaptions As String) ButtonLabels = BttnCaptions Call UpdateLabels PropertyChanged "Captions" End Property Public Property Get Captions() As String Captions = ButtonLabels End Property Public Property Let Tags(ByVal BttnTags As String) ButtonTags = BttnTags Call UpdateTags PropertyChanged "Tags" End Property Public Property Get Tags() As String Tags = ButtonTags End Property Public Property Let ButtonUpColor(ByVal BttnColor As OLE_COLOR) BttnUpColor = BttnColor Call Show PropertyChanged "ButtonUpColor" End Property Public Property Get ButtonUpColor() As OLE_COLOR ButtonUpColor = BttnUpColor End Property Public Property Let ButtonDownColor(ByVal BttnColor As OLE_COLOR) BttnDownColor = BttnColor Call Show PropertyChanged "ButtonDownColor" End Property Public Property Get ButtonDownColor() As OLE_COLOR ButtonDownColor = BttnDownColor End Property Public Property Let BackColor(ByVal BttnColor As OLE_COLOR) ControlColor = BttnColor Call Show PropertyChanged "BackColor" End Property Public Property Get BackColor() As OLE_COLOR BackColor = ControlColor End Property Public Property Let BackStyle(ByVal tmpVal As StyleType) ControlStyle = tmpVal Call Show PropertyChanged "BackStyle" End Property Public Property Get BackStyle() As StyleType BackStyle = ControlStyle End Property Public Sub Show() Dim i, Row, Col As Integer On Error Resume Next Call Clear UserControl.BackStyle = ControlStyle UserControl.BackColor = ControlColor Select Case (NumRows * NumCols) Case Is > 1 If Borders = True Then UserControl.BorderStyle = 1 BttnWidth = (UserControl.ScaleWidth - ((NumCols + 1) * BttnSpacing)) / NumCols BttnHeight = (UserControl.ScaleHeight - ((NumRows + 1) * BttnSpacing)) / NumRows For Col = 1 To NumCols For Row = 1 To NumRows If BttnMode = 1 Then i = ((Row - 1) * NumCols) + Col Else i = ((Col - 1) * NumRows) + Row End If Load Question(i) Question(i).Top = ((BttnHeight + BttnSpacing) * (Row - 1)) + BttnSpacing Question(i).Left = ((BttnWidth + BttnSpacing) * (Col - 1)) + BttnSpacing Question(i).Height = BttnHeight Question(i).Width = BttnWidth Question(i).Visible = True Question(i).BackColor = ButtonUpColor Next Next Else UserControl.BorderStyle = 0 BttnWidth = (UserControl.ScaleWidth - ((NumCols - 1) * BttnSpacing)) / NumCols BttnHeight = (UserControl.ScaleHeight - ((NumRows - 1) * BttnSpacing)) / NumRows For Col = 1 To NumCols For Row = 1 To NumRows If BttnMode = 1 Then i = ((Row - 1) * NumCols) + Col Else i = ((Col - 1) * NumRows) + Row End If If i > 1 Then Load Question(i) Question(i).Top = ((BttnHeight + BttnSpacing) * (Row - 1)) Question(i).Left = ((BttnWidth + BttnSpacing) * (Col - 1)) Question(i).Height = BttnHeight Question(i).Width = BttnWidth Question(i).Visible = True Question(i).BackColor = ButtonUpColor Next Next End If Case 1 If Borders = True Then UserControl.BorderStyle = 1 BttnWidth = UserControl.ScaleWidth - (BttnSpacing * 2) BttnHeight = UserControl.ScaleHeight - (BttnSpacing * 2) Question(1).Top = BttnSpacing Question(1).Left = BttnSpacing Question(1).Tag = "0101" Question(1).Height = BttnHeight Question(1).Width = BttnWidth Question(1).Visible = True Else UserControl.BorderStyle = 0 BttnWidth = UserControl.ScaleWidth BttnHeight = UserControl.ScaleHeight Question(1).Top = 0 Question(1).Left = 0 Question(1).Tag = "0101" Question(1).Height = BttnHeight Question(1).Width = BttnWidth Question(1).Visible = True End If End Select Call UpdateLabels Call UpdateTags Call EnableBttns End Sub Public Sub Clear() Dim i As Integer On Error Resume Next If Question.Count > 2 Then For i = Question.UBound To 2 Step -1 Question(i).Visible = False Unload Question(i) Next ElseIf Question.Count = 2 Then Question(2).Visible = False Unload Question(2) End If On Error GoTo 0 End Sub Private Sub Question_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) If Index > 0 Then Question(Index).BackColor = ButtonDownColor End Sub Private Sub Question_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) If Index > 0 Then Question(Index).BackColor = ButtonUpColor End Sub Private Sub UserControl_Initialize() Set m_Font1 = New StdFont BttnUpColor = DefaultUpColor BttnDownColor = DefaultDownColor BttnHeight = DefaultHeight BttnWidth = DefaultWidth BttnSpacing = DefaultSpace ControlColor = DefaultBackColor ControlStyle = DefaultStyle ControlEnabled = True NumRows = 1 NumCols = 1 Borders = False BttnEnabled = "1" Mode = TopToBottom End Sub Private Sub UserControl_InitProperties() Set Font = Ambient.Font End Sub Private Sub UserControl_Resize() Call Show End Sub Public Sub UpdateLabels() Dim i As Integer Dim tmpCaption As String On Error Resume Next If Trim(ButtonLabels) <> "" Then If NumRows * NumCols > 1 Then For i = 1 To (NumRows * NumCols) tmpCaption = Split(ButtonLabels, ",")(i - 1) If Err Then tmpCaption = "" If tmpCaption = "NA" Then Question(i).Caption = "" Else Question(i).Caption = tmpCaption End If Next Else tmpCaption = Split(ButtonLabels, ",")(0) If Err Then tmpCaption = "" If tmpCaption = "NA" Then Question(0).Caption = "" Else Question(0).Caption = tmpCaption End If End If End If On Error GoTo 0 End Sub Public Sub UpdateTags() Dim i As Integer On Error Resume Next If Trim(ButtonTags) <> "" Then For i = 1 To (NumRows * NumCols) Question(i).Tag = Split(ButtonTags, ",")(i - 1) If Err Then Question(i).Tag = "" Next End If On Error GoTo 0 End Sub Public Sub EnableBttns() Dim i As Integer On Error Resume Next If ControlEnabled = True Then For i = 1 To (NumRows * NumCols) If Mid(BttnEnabled, i, 1) = "1" Then Question(i).Enabled = True Else Question(i).Enabled = False End If Next Else For i = 1 To (NumRows * NumCols) Question(i).Enabled = False Next End If On Error GoTo 0 End Sub Private Sub UserControl_ReadProperties(PropBag As PropertyBag) Mode = PropBag.ReadProperty("Mode", 1) ShowBorder = PropBag.ReadProperty("ShowBorder", True) Spacing = PropBag.ReadProperty("Spacing", 120) Columns = PropBag.ReadProperty("Columns", 1) Rows = PropBag.ReadProperty("Rows", 1) Captions = PropBag.ReadProperty("Captions", "") Tags = PropBag.ReadProperty("Tags", "") ButtonUpColor = PropBag.ReadProperty("ButtonUpColor", DefaultUpColor) ButtonDownColor = PropBag.ReadProperty("ButtonDownColor", DefaultDownColor) ControlColor = PropBag.ReadProperty("ControlColor", DefaultBackColor) ControlStyle = PropBag.ReadProperty("ControlStyle", DefaultStyle) ControlEnabled = PropBag.ReadProperty("ControlEnabled", True) ButtonsEnabled = PropBag.ReadProperty("ButtonsEnabled", "1") Set Font = PropBag.ReadProperty("Font", Ambient.Font) Call Show End Sub Private Sub UserControl_WriteProperties(PropBag As PropertyBag) Call PropBag.WriteProperty("Mode", Mode, 1) Call PropBag.WriteProperty("ShowBorder", ShowBorder, True) Call PropBag.WriteProperty("Spacing", Spacing, 120) Call PropBag.WriteProperty("Columns", Columns, 1) Call PropBag.WriteProperty("Rows", Rows, 1) Call PropBag.WriteProperty("Captions", Captions, "") Call PropBag.WriteProperty("Tags", Tags, "") Call PropBag.WriteProperty("ButtonUpColor", BttnUpColor, DefaultUpColor) Call PropBag.WriteProperty("ButtonDownColor", BttnDownColor, DefaultDownColor) Call PropBag.WriteProperty("ControlColor", ControlColor, DefaultBackColor) Call PropBag.WriteProperty("ControlStyle", ControlStyle, DefaultStyle) Call PropBag.WriteProperty("ControlEnabled", ControlEnabled, True) Call PropBag.WriteProperty("ButtonsEnabled", ButtonsEnabled, "1") Call PropBag.WriteProperty("Font", Font, Ambient.Font) End Sub Thanks Top Display posts from previous: All posts1 day7 days2 weeks1 month3 months6 months1 year Sort by AuthorPost timeSubject AscendingDescending Page 1 of 1 [ 1 post ] -- Over 1500 classes with 29000 functions in one REALbasic plug-in collection. The Monkeybread Software Realbasic Plugin v9.3. http://www.monkeybreadsoftware.de/realbasic/plugins.shtml [email protected]
