VERSION 5.00 Begin VB.Form frmAttrDefs Caption = " Edit Attribute Definitions" ClientHeight = 3225 ClientLeft = 60 ClientTop = 345 ClientWidth = 4095 Icon = "frmAttrDefs.frx":0000 LinkTopic = "Form1" NegotiateMenus = 0 'False ScaleHeight = 3225 ScaleWidth = 4095 StartUpPosition = 1 'CenterOwner Begin VB.ListBox lbAttrs BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty ForeColor = &H00FF0000& Height = 2790 ItemData = "frmAttrDefs.frx":08CA Left = 120 List = "frmAttrDefs.frx":08CC Sorted = -1 'True TabIndex = 4 Top = 300 Width = 2310 End Begin VB.CommandButton cbDelete Caption = "&Delete" BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 2520 TabIndex = 3 Top = 1260 Width = 1470 End Begin VB.CommandButton cbRename Caption = "&Rename" BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 2520 TabIndex = 2 Top = 780 Width = 1470 End Begin VB.CommandButton cbNew Caption = "&Add" BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 2520 TabIndex = 1 Top = 315 Width = 1470 End Begin VB.CommandButton cbOkay Caption = "&OK" BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 375 Left = 2520 TabIndex = 0 Top = 2730 Width = 1470 End Begin VB.Label Label3 Caption = "Attributes" BeginProperty Font Name = "Verdana" Size = 8.25 Charset = 0 Weight = 700 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 195 Left = 150 TabIndex = 5 Top = 60 Width = 1125 End End Attribute VB_Name = "frmAttrDefs" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Sub Form_Load() Dim attr As infNameDef For Each attr In inf.Modules("Main").AttributeDefs lbAttrs.AddItem attr.Name Next End Sub Private Sub cbDelete_Click() Dim upCount As Long Dim cls As infObject Dim obj As infObject Dim cont As String upCount = 0 For Each obj In inf.Modules("Main").Objects If obj.Attributes.Find(lbAttrs.Text) > 0 Then upCount = upCount + 1 End If Next For Each cls In inf.Modules("Main").Classes If cls.Attributes.Find(lbAttrs.Text) > 0 Then upCount = upCount + 1 End If Next cont = MsgBox("The attribute '" & lbAttrs.Text & "' is being used " & upCount & " times. Do you wish to continue deleting?", vbYesNoCancel, "Delete Attribute Definition") If cont = vbYes Then inf.Modules("Main").AttributeDefs.Remove lbAttrs.Text For Each obj In inf.Modules("Main").Objects If obj.Attributes.Find(lbAttrs.Text) > 0 Then obj.Attributes.Remove lbAttrs.Text End If Next For Each cls In inf.Modules("Main").Classes If cls.Attributes.Find(lbAttrs.Text) > 0 Then cls.Attributes.Remove lbAttrs.Text End If Next frmMain.cbAttribs.RemoveItem frmMain.cbAttribs.FindItemIndex(lbAttrs.Text, True) frmMain.cbAttribs.ListIndex = -1 lbAttrs.RemoveItem lbAttrs.ListIndex End If End Sub Private Sub cbNew_Click() Dim newattr As String TryAgain: newattr = InputBox("Enter a new attribute name:", "Add Attribute Definition") If isBlank(newattr) Then Exit Sub ElseIf Not LCase(Left(newattr, 1)) Like "[a-z]" Then MsgBox "Attribute must begin with A to Z." & vbCrLf & "(case insensitive)", vbExclamation, "New Attribute" Exit Sub Else For lChar = 1 To Len(newattr) sChar = Mid(newattr, lChar, 1) If Not sChar Like "[_0-9A-Za-z]" Then MsgBox "Attribute may only contain 0 to 9, underscore, or A to Z." & vbCrLf & "(case insensitive)", vbExclamation, "New Attribute" Exit Sub End If Next lChar End If If inf.Modules("Main").AttributeDefs.Find(newattr) > 0 Then MsgBox "Attribute already exists.", vbExclamation, "New Attribute" Exit Sub End If inf.Modules("Main").AttributeDefs.Add newattr lbAttrs.AddItem newattr End Sub Private Sub cbOkay_Click() Unload Me End Sub Private Sub cbRename_Click() Dim yn As String Dim newattr As String Dim tempattr As infAttribute Dim obj As infObject Dim cls As infObject newattr = InputBox("Rename '" & lbAttrs.Text & "' to:", "Rename Attribute") If isBlank(newattr) Then Exit Sub ElseIf Not LCase(Left(newattr, 1)) Like "[a-z]" Then MsgBox "Property must begin with A to Z." & vbCrLf & "(case insensitive)", vbExclamation, "Rename Attribute" Exit Sub Else For lChar = 1 To Len(newattr) sChar = Mid(newattr, lChar, 1) If Not sChar Like "[_0-9A-Za-z]" Then MsgBox "Property may only contain 0 to 9, underscore, or A to Z." & vbCrLf & "(case insensitive)", vbExclamation, "Rename Attribute" Exit Sub End If Next lChar End If If inf.Modules("Main").AttributeDefs.Find(newattr) > 0 Then MsgBox "Attribute already exists.", vbExclamation, "Rename Attribute" Exit Sub End If yn = MsgBox("Rename '" & lbAttrs.Text & "' to '" & newattr & "'?", vbYesNoCancel, "Rename Attribute") If yn = vbYes Then inf.Modules("Main").AttributeDefs.Add newattr Set inf.Modules("Main").AttributeDefs(newattr).Comments = inf.Modules("Main").AttributeDefs(lbAttrs.Text).Comments inf.Modules("Main").AttributeDefs.Remove lbAttrs.Text For Each obj In inf.Modules("Main").Objects If obj.Attributes.Find(lbAttrs.Text) > 0 Then Set tempattr = obj.Attributes(lbAttrs.Text) obj.Attributes.Remove lbAttrs.Text obj.Attributes.Add newattr, tempattr.Value End If Next For Each cls In inf.Modules("Main").Classes If cls.Attributes.Find(lbAttrs.Text) > 0 Then Set tempattr = cls.Attributes(lbAttrs.Text) cls.Attributes.Remove lbAttrs.Text cls.Attributes.Add newattr, tempattr.Value End If Next frmMain.cbClasses.ListIndex = -1 frmMain.cbObjects.ListIndex = -1 frmMain.cbProc.ListIndex = -1 frmMain.cbProps.ListIndex = -1 lbAttrs.Clear frmMain.cbAttribs.Clear Form_Load End If End Sub