QBasic & Borland Pascal & C/Delphi5.iso/Basic/Visual Basic.60/COMMON/TOOLS/VCM/VCM.MDB/VcmComponentContainer/01_Cabinet/CtlView.frm

Visual Basic Form | 1998-05-18 | 5.6 KB | 159 lines

VERSION 5.00
Object = "{F0D2F211-CCB0-11D0-A316-00AA00688B10}#1.0#0"; "MSDatLst.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "ComDlg32.OCX"
Begin VB.Form frmCtlView
   BackColor       =   &H8000000C&
   Caption         =   "Control Viewer Sample"
   ClientHeight    =   8595
   ClientLeft      =   165
   ClientTop       =   450
   ClientWidth     =   10680
   LinkTopic       =   "Form1"
   ScaleHeight     =   573
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   712
   StartUpPosition =   3  'Windows Default
   Begin MSComDlg.CommonDialog dlgFind
      Left            =   7800
      Top             =   480
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSDataListLib.DataList lstControls
      Height          =   9030
      Left            =   0
      TabIndex        =   1
      Top             =   420
      Width           =   2595
      _ExtentX        =   4577
      _ExtentY        =   15928
      _Version        =   393216
   End
   Begin VB.Label lblInfo
      Appearance      =   0  'Flat
      AutoSize        =   -1  'True
      BorderStyle     =   1  'Fixed Single
      Caption         =   $"CtlView.frx":0000
      ForeColor       =   &H8000000D&
      Height          =   420
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   10635
      WordWrap        =   -1  'True
   End
Attribute VB_Name = "frmCtlView"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim rsControls As New ADODB.Recordset
Dim cnControls As New ADODB.Connection
Dim oControl As Object
Private Sub Form_Load()
    On Error GoTo FindErr
    Dim strQ As String ' query string
    strQ = "Provider=Microsoft.Jet.OLEDB.3.51;Data source=" & App.Path & "\controls.mdb"
    cnControls.Open strQ
    rsControls.Open "select * from controls order by description", cnControls, adOpenKeyset, adLockOptimistic
    lstControls.ListField = "Description"
    Set lstControls.RowSource = rsControls
    Exit Sub
FindErr:
    ' If the database isn't found, use the FindDB function to find it.
    If Err.Number = -2147467259 Then
    cnControls.Open "Provider=Microsoft.Jet.OLEDB.3.51;Data source=" & FindDB("controls.mdb")
    Resume Next
    End If
    Exit Sub
End Sub
Private Function FindDB(dbName As String) As String
    On Error GoTo ErrHandler
    ' Configure cmdDialog in case the database can't be found.
    With dlgFind
        .DialogTitle = "Can't Find " & dbName
        .Filter = "(*.MDB)|*.mdb"
        .CancelError = True   'Causes an error if user clicks on cancel
        .ShowOpen
    End With
    ' Test the string to ensure it's the sought database.
    Do While Right(Trim(dlgFind.FileName), Len(dbName)) <> dbName
       MsgBox "File Name is not equal to " & dbName
       dlgFind.ShowOpen
    Loop
    FindDB = dlgFind.FileName ' return the full path.
    Exit Function
ErrHandler:
    If Err = 32755 Then
      Unload Me
    End If
End Function
Private Sub Form_Resize()
  lblInfo.Width = ScaleWidth
  lstControls.Move 0, lblInfo.Height, lstControls.Width, ScaleHeight - lblInfo.Height
End Sub
Private Sub lstControls_Click()
  Dim vControlLicense As Variant
  Dim vControlType As Variant
  Dim vPropertyName As Variant
  Dim vPropertyValue As Variant
  Dim vControlWidth As Variant
  Dim vControlHeight As Variant
  Dim sError As String
  If Not oControl Is Nothing Then
    Controls.Remove oControl
    Set oControl = Nothing
  End If
  rsControls.MoveFirst
    If rsControls.EOF Then Exit Do
    If rsControls.Fields("Description") = lstControls.BoundText Then
      Exit Do
    End If
    rsControls.MoveNext
  Loop
  vPropertyName = rsControls.Fields("PropertyName")
  vPropertyValue = rsControls.Fields("PropertyValue")
  vControlLicense = rsControls.Fields("ControlLicense")
  vControlType = rsControls.Fields("ControlType")
  vControlWidth = rsControls.Fields("ControlWidth")
  vControlHeight = rsControls.Fields("ControlWidth")
  On Error GoTo CantFindControl
  If (Not IsNull(vControlLicense)) Then
    sError = "unable to add license"
    Licenses.Add vControlType, vControlLicense
  End If
  sError = "unable to create control license"
  Set oControl = Controls.Add(vControlType, "MyControl")
  If (Not IsNull(vControlLicense)) Then
    sError = "unable to remove license"
    Licenses.Remove vControlType
  End If
  If (Not IsNull(vControlWidth)) Then
    sError = "unable to set Width"
    oControl.Width = vControlWidth
  End If
  If (Not IsNull(vControlHeight)) Then
    sError = "unable to set Height"
    oControl.Height = vControlHeight
  End If
  sError = "unable to set Left"
  oControl.Left = lstControls.Width + ((ScaleWidth - lstControls.Width) - oControl.Width) / 2
  sError = "unable to set Top"
  oControl.Top = lblInfo.Height + ((ScaleHeight - lblInfo.Height) - oControl.Height) / 2
  sError = "unable to set Visible"
  oControl.Visible = True
  If (Not IsNull(vPropertyName)) Then
    sError = "unable to set Property '" & vPropertyName & "'"
    If (Left$(vControlType, 3) = "VB.") Then
      CallByName oControl, vPropertyName, VbLet, vPropertyValue
    Else
      CallByName oControl.object, vPropertyName, VbLet, vPropertyValue
    End If
  End If
  Exit Sub
CantFindControl:
  MsgBox "Error adding control '" & vControlType & "', " & sError & ", " & Err.Description
End Sub