Master 95 #1/MASTER95_1.iso/microsof/vbasic4/vb4-6.cab/propsht.frm

Visual Basic Form | 1995-07-26 | 11.8 KB | 373 lines

VERSION 4.00
Begin VB.Form frmPropertySheet
   ClientHeight    =   1215
   ClientLeft      =   1815
   ClientTop       =   2325
   ClientWidth     =   7140
   Height          =   1620
   HelpContextID   =   2016139
   Icon            =   "PROPSHT.frx":0000
   Left            =   1755
   LinkTopic       =   "Form2"
   LockControls    =   -1  'True
   MDIChild        =   -1  'True
   ScaleHeight     =   1215
   ScaleWidth      =   7140
   Tag             =   "Properties"
   Top             =   1980
   Width           =   7260
   Begin VB.PictureBox picPropHeader
      Align           =   1  'Align Top
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   315
      Left            =   0
      ScaleHeight     =   315
      ScaleMode       =   0  'User
      ScaleWidth      =   7144.253
      TabIndex        =   0
      Top             =   0
      Width           =   7140
      Begin VB.CommandButton cmdAddUDP
         Caption         =   "&Add UDP"
         Height          =   300
         Left            =   4080
         TabIndex        =   9
         Top             =   0
         Width           =   1335
      End
      Begin VB.CommandButton cmdClose
         Caption         =   "&Close"
         Height          =   300
         Left            =   5400
         TabIndex        =   8
         Top             =   0
         Width           =   1335
      End
      Begin VB.Label lblPropValue
         Caption         =   " Value:"
         Height          =   255
         Left            =   2280
         TabIndex        =   2
         Top             =   30
         Width           =   735
      End
      Begin VB.Label lblPropHeader
         Caption         =   "Prop Name:"
         Height          =   252
         Left            =   120
         TabIndex        =   1
         Top             =   30
         Width           =   1212
      End
   End
   Begin VB.VScrollBar vsbScrollBar
      Height          =   2085
      LargeChange     =   3000
      Left            =   7200
      SmallChange     =   300
      TabIndex        =   7
      Top             =   360
      Visible         =   0   'False
      Width           =   255
   End
   Begin VB.PictureBox picProps
      Appearance      =   0  'Flat
      BorderStyle     =   0  'None
      ForeColor       =   &H80000008&
      Height          =   735
      Left            =   0
      ScaleHeight     =   729.119
      ScaleMode       =   0  'User
      ScaleWidth      =   7120.563
      TabIndex        =   3
      TabStop         =   0   'False
      Top             =   360
      Width           =   7125
      Begin VB.TextBox txtPropData
         BackColor       =   &H00FFFFFF&
         DataSource      =   "datDataCtl"
         ForeColor       =   &H00000000&
         Height          =   285
         Index           =   0
         Left            =   2280
         TabIndex        =   5
         Top             =   30
         Visible         =   0   'False
         Width           =   4575
      End
      Begin VB.CheckBox chkPropData
         DataSource      =   "datDataCtl"
         Height          =   282
         Index           =   0
         Left            =   2280
         TabIndex        =   4
         Top             =   360
         Visible         =   0   'False
         Width           =   3270
      End
      Begin VB.Label lblPropName
         ForeColor       =   &H00000000&
         Height          =   255
         Index           =   0
         Left            =   105
         TabIndex        =   6
         Top             =   40
         Visible         =   0   'False
         Width           =   2055
      End
   End
Attribute VB_Name = "frmPropertySheet"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
'============================================================================
' This is a fairly generic form that can be used in most cases with any
' Data Access Object to display its Properties.
'============================================================================
Dim maPropArr() As Object
Dim mPropObject As Object
Dim mnNumProps As Integer       'number of Props
Dim mbResizing As Integer       'flag to avoid resize recursion
Dim mnPropTop As Integer        'top Prop position
Sub chkPropData_Click(Index As Integer)
  On Error GoTo CPDErr
  If mPropObject.Properties(Index).Value = True And chkPropData(Index).Value = vbChecked Then
    'first time set of value so we should just exit
    Exit Sub
  End If
  'try to set the value if the user changed it
  mPropObject.Properties(Index).Value = IIf(chkPropData(Index).Value = 1, True, False)
  Exit Sub
CPDErr:
  ShowError
  'set the control back to the original value
  chkPropData(Index).Value = IIf(mPropObject.Properties(Index).Value = True, 1, 0)
  Exit Sub
End Sub
Sub cmdAddUDP_Click()
  frmAddUDP.Show vbModal
  If gPropObject.Properties.Count > mnNumProps Then
    LoadProps
  End If
End Sub
Private Sub txtPropData_KeyPress(Index As Integer, KeyAscii As Integer)
  'go to next Prop on an enter keypress
  If KeyAscii = 13 Then
    KeyAscii = 0
    SendKeys "{Tab}"
  End If
End Sub
Private Sub cmdClose_Click()
  On Error Resume Next
  Unload Me
End Sub
Sub txtPropData_LostFocus(Index As Integer)
  On Error GoTo TPDErr
  'don't try to set an Err value
  If Left(txtPropData(Index).Text, 4) = "ERR:" Then Exit Sub
  'try to set the value if the user changed it
  If TypeName(mPropObject.Properties(Index).Value) = "Boolean" Then
    If mPropObject.Properties(Index).Value <> CBool(txtPropData(Index).Text) Then
      mPropObject.Properties(Index).Value = txtPropData(Index).Text
    End If
  Else
    If CStr(mPropObject.Properties(Index).Value) <> txtPropData(Index).Text Then
      mPropObject.Properties(Index).Value = txtPropData(Index).Text
    End If
  End If
  Exit Sub
ResetIt:
  On Error Resume Next
  'try to set the control back to the original value
  'because an error occured
  txtPropData(Index).Text = mPropObject.Properties(Index).Value
  Exit Sub
TPDErr:
  ShowError
  Resume ResetIt
  Exit Sub
End Sub
Sub txtPropData_MouseUp(Index As Integer, Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button <> 2 Then Exit Sub
  SetHourglass
  ShowProperties "Property", mPropObject.Properties(Index)
End Sub
Private Sub vsbScrollBar_Change()
  Dim nCurrVal As Integer
  nCurrVal = vsbScrollBar
  If (nCurrVal - mnPropTop) Mod gnCTLARRAYHEIGHT = 0 Then
    picProps.Top = nCurrVal
  Else
    picProps.Top = ((nCurrVal - mnPropTop) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + mnPropTop
  End If
End Sub
Private Sub Form_Load()
  Dim Start As Long, Finish As Long
  On Error GoTo LoadErr
  Set mPropObject = gPropObject
  Me.Width = 7050
  LoadProps
  Me.Show
  maPropArr(0).SetFocus
  Screen.MousePointer = vbDefault
  Exit Sub
LoadErr:
  Screen.MousePointer = vbDefault
  MsgBox "Error:" & Err & " " & Error
  Unload Me
  Exit Sub
End Sub
Private Sub Form_Resize()
  On Error Resume Next
  If mbResizing = True Then Exit Sub
  Dim nHeight As Integer
  Dim i As Integer
  Dim nTotalWidth As Integer
  mbResizing = True
  If Me.WindowState <> 1 And lblPropName(0).Visible = True Then 'not minimized
    'make sure the form is lined up on a Prop
    nHeight = Me.Height
    If (nHeight - 1400) Mod gnCTLARRAYHEIGHT <> 0 Then
      Me.Height = ((nHeight - 1400) \ gnCTLARRAYHEIGHT) * gnCTLARRAYHEIGHT + 1400
    End If
    'resize the scrollbar
    vsbScrollBar.Height = Me.Height - 740
    vsbScrollBar.Left = Me.Width - 360
    If mPropObject.Properties.Count > 10 Then
      picProps.Width = Me.Width - 260
      nTotalWidth = vsbScrollBar.Left - 20
    Else
      picProps.Width = Me.Width - 20
      nTotalWidth = Me.Width - 50
    End If
    picPropHeader.Width = Me.Width - 20
    'widen the Props if possible
    For i = 0 To mPropObject.Properties.Count - 1
      lblPropName(i).Width = (0.3 * nTotalWidth) - 20
      maPropArr(i).Left = lblPropName(i).Width + 40
      If gPropObject.Properties(i).Type > 9 Then
        maPropArr(i).Width = 0.7 * nTotalWidth - 270
      End If
    Next
    lblPropValue.Left = maPropArr(0).Left
  End If
  mbResizing = False
End Sub
Private Function GetPropWidth(rnType As Integer)
  'determines the form control width
  'based on the Prop type
  Select Case rnType
    Case dbBoolean
      GetPropWidth = 850
    Case dbByte
      GetPropWidth = 650
    Case dbInteger
      GetPropWidth = 900
    Case dbLong
      GetPropWidth = 1100
    Case dbCurrency
      GetPropWidth = 1800
    Case dbSingle
      GetPropWidth = 1800
    Case dbDouble
      GetPropWidth = 2200
    Case dbDate
      GetPropWidth = 2000
    Case dbText
      GetPropWidth = 3250
    Case dbMemo
      GetPropWidth = 3250
    Case Else
      GetPropWidth = 3250
  End Select
End Function
Private Sub LoadProps()
   Dim nPropType As Integer
   Dim i As Integer
   On Error GoTo LoadPropsErr
   'load the controls on the form
   mnNumProps = mPropObject.Properties.Count
   ReDim maPropArr(mnNumProps) As Object
   lblPropName(0).Visible = True
   nPropType = mPropObject.Properties(0).Type
   If nPropType = dbBoolean Then
     Set maPropArr(0) = chkPropData(0)
   Else
     Set maPropArr(0) = txtPropData(0)
   End If
   maPropArr(0).Visible = True
   maPropArr(0).Top = 0
   maPropArr(0).Width = GetPropWidth(nPropType)
   maPropArr(0).TabIndex = 0
   On Error Resume Next
   For i = 1 To mPropObject.Properties.Count - 1
     picProps.Height = picProps.Height + gnCTLARRAYHEIGHT
     Load lblPropName(i)
     lblPropName(i).Top = lblPropName(i - 1).Top + gnCTLARRAYHEIGHT
     lblPropName(i).Visible = True
     nPropType = mPropObject.Properties(i).Type
     If nPropType = dbBoolean Then
       Load chkPropData(i)
       Set maPropArr(i) = chkPropData(i)
     Else
       Load txtPropData(i)
       Set maPropArr(i) = txtPropData(i)
     End If
     maPropArr(i).Top = maPropArr(i - 1).Top + gnCTLARRAYHEIGHT
     maPropArr(i).Visible = True
     maPropArr(i).Width = GetPropWidth(nPropType)
     maPropArr(i).TabIndex = i
   Next
   On Error GoTo LoadPropsErr
   'resize main window
   picProps.Top = picPropHeader.Top + picPropHeader.Height
   mnPropTop = picProps.Top
   vsbScrollBar.Value = mnPropTop
   If i <= 11 Then
     Me.Height = i * gnCTLARRAYHEIGHT + 1000
     vsbScrollBar.Visible = False
   Else
     Me.Height = 4500
     Me.Width = Me.Width + 260
     vsbScrollBar.Visible = True
     vsbScrollBar.Min = mnPropTop
     vsbScrollBar.Max = mnPropTop - (i * gnCTLARRAYHEIGHT) + 3000
   End If
   'display the Prop names
   For i = 0 To mPropObject.Properties.Count - 1
     lblPropName(i).Caption = mPropObject.Properties(i).Name & ":"
   Next
   LoadPropValues
   Exit Sub
LoadPropsErr:
   MsgBox "Error:" & Err & " " & Error
   Exit Sub
End Sub
Private Sub LoadPropValues()
  On Error GoTo LPVErr
  Dim i As Integer
  Dim vntTmp As Variant
  For i = 0 To mPropObject.Properties.Count - 1
    vntTmp = mPropObject.Properties(i).Value
    If mPropObject.Properties(i).Type = dbBoolean Then
      If Left(vntTmp, 4) = "ERR:" Then
        chkPropData(i).Value = 2
      Else
        chkPropData(i).Value = IIf(vntTmp = True, 1, 0)
      End If
    Else
      txtPropData(i).Text = vntTmp
      If Left(vntTmp, 4) = "ERR:" Then
        txtPropData(i).Locked = True 'disable Errors
        txtPropData(i).TabStop = False
      End If
    End If
  Next
  Exit Sub
LPVErr:
  vntTmp = "ERR:" & Err & " " & Error
  Resume Next
End Sub