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

Visual Basic Form | 1995-07-26 | 29.5 KB | 897 lines

VERSION 4.00
Begin VB.Form frmDFD
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Data Form Designer"
   ClientHeight    =   5310
   ClientLeft      =   1155
   ClientTop       =   2505
   ClientWidth     =   6135
   Height          =   5715
   Icon            =   "DFD.frx":0000
   Left            =   1095
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5310
   ScaleWidth      =   6135
   Top             =   2160
   Width           =   6255
   Begin VB.CheckBox chkOnScreen
      Caption         =   "On Screen"
      Height          =   210
      Left            =   810
      TabIndex        =   8
      Top             =   4515
      Width           =   1875
   End
   Begin VB.ListBox lstOLECtls
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   615
      Left            =   120
      TabIndex        =   21
      Top             =   4560
      Visible         =   0   'False
      Width           =   615
   End
   Begin VB.CommandButton cmdMoveFields
      Caption         =   "<<"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   3
      Left            =   2760
      TabIndex        =   9
      Top             =   4080
      Width           =   495
   End
   Begin VB.CommandButton cmdMoveFields
      Caption         =   "<"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   2
      Left            =   2760
      TabIndex        =   7
      Top             =   3600
      Width           =   495
   End
   Begin VB.CommandButton cmdMoveFields
      Caption         =   ">"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   1
      Left            =   2760
      TabIndex        =   6
      Top             =   3120
      Width           =   495
   End
   Begin VB.CommandButton cmdMoveFields
      Caption         =   ">>"
      BeginProperty Font
         name            =   "MS Sans Serif"
         charset         =   0
         weight          =   700
         size            =   8.25
         underline       =   0   'False
         italic          =   0   'False
         strikethrough   =   0   'False
      EndProperty
      Height          =   375
      Index           =   0
      Left            =   2760
      TabIndex        =   5
      Top             =   2640
      Width           =   495
   End
   Begin VB.ListBox lstIncludedFields
      DragIcon        =   "DFD.frx":030A
      Height          =   1785
      Left            =   3360
      MultiSelect     =   2  'Extended
      TabIndex        =   4
      Top             =   2640
      Width           =   2655
   End
   Begin VB.CommandButton cmdBuildForm
      Caption         =   "&Build the Form"
      Height          =   375
      Left            =   720
      TabIndex        =   10
      Top             =   4800
      Width           =   1695
   End
   Begin VB.ComboBox cboRecordSource
      Height          =   300
      Left            =   1680
      TabIndex        =   2
      Top             =   1680
      Width           =   4335
   End
   Begin VB.ListBox lstFields
      DragIcon        =   "DFD.frx":0614
      Height          =   1785
      Left            =   120
      MultiSelect     =   2  'Extended
      TabIndex        =   3
      Top             =   2640
      Width           =   2535
   End
   Begin VB.CommandButton cmdOpenDB
      Caption         =   "&Open Database"
      Height          =   375
      Left            =   2760
      TabIndex        =   11
      Top             =   1200
      Width           =   1935
   End
   Begin VB.ComboBox cboConnect
      Height          =   300
      ItemData        =   "DFD.frx":091E
      Left            =   1680
      List            =   "DFD.frx":0940
      TabIndex        =   1
      Top             =   480
      Width           =   4335
   End
   Begin VB.TextBox txtFormName
      Height          =   285
      Left            =   3240
      MaxLength       =   8
      TabIndex        =   0
      Top             =   120
      Width           =   1095
   End
   Begin VB.CommandButton cmdClose
      Caption         =   "&Close"
      Height          =   375
      Left            =   3600
      TabIndex        =   12
      Top             =   4800
      Width           =   1695
   End
   Begin VB.Label lblDatabaseName
      Height          =   255
      Left            =   1680
      TabIndex        =   22
      Top             =   855
      Width           =   4335
   End
   Begin MSComDlg.CommonDialog dlgDBOpen
      Left            =   360
      Top             =   1200
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin VB.Line Line1
      BorderWidth     =   3
      X1              =   120
      X2              =   6000
      Y1              =   2280
      Y2              =   2280
   End
   Begin VB.Label lblLabels
      Alignment       =   2  'Center
      Caption         =   "Select a Table/QueryDef from the list or enter a SQL statement."
      Height          =   195
      Index           =   4
      Left            =   120
      TabIndex        =   20
      Top             =   2040
      Width           =   5925
   End
   Begin VB.Label lblLabels
      AutoSize        =   -1  'True
      Caption         =   "Included Columns: "
      Height          =   195
      Index           =   10
      Left            =   3360
      TabIndex        =   19
      Top             =   2400
      Width           =   1350
   End
   Begin VB.Label lblLabels
      AutoSize        =   -1  'True
      Caption         =   " Drag/Drop to Change Order "
      Height          =   195
      Index           =   7
      Left            =   3360
      TabIndex        =   18
      Top             =   4500
      Width           =   2070
   End
   Begin VB.Label lblLabels
      AutoSize        =   -1  'True
      Caption         =   "RecordSource: "
      Height          =   195
      Index           =   6
      Left            =   105
      TabIndex        =   17
      Top             =   1740
      Width           =   1125
   End
   Begin VB.Label lblLabels
      AutoSize        =   -1  'True
      Caption         =   "Available Columns: "
      Height          =   195
      Index           =   3
      Left            =   120
      TabIndex        =   16
      Top             =   2400
      Width           =   1380
   End
   Begin VB.Label lblLabels
      AutoSize        =   -1  'True
      Caption         =   "Connect String: "
      Height          =   195
      Index           =   2
      Left            =   105
      TabIndex        =   15
      Top             =   540
      Width           =   1140
   End
   Begin VB.Label lblLabels
      AutoSize        =   -1  'True
      Caption         =   "Database Name: "
      Height          =   195
      Index           =   1
      Left            =   105
      TabIndex        =   14
      Top             =   900
      Width           =   1245
   End
   Begin VB.Label lblLabels
      AutoSize        =   -1  'True
      Caption         =   "Base Form Name (w/o Extension): "
      Height          =   195
      Index           =   0
      Left            =   105
      TabIndex        =   13
      Top             =   180
      Width           =   2460
   End
Attribute VB_Name = "frmDFD"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim mdbCurrentDB As DATABASE
Dim msDBName As String
Dim mrecRS As Recordset
Dim mnDataType As Integer
'constants used for the data type of the database
Const gnDT_NONE = -1
Const gnDT_ACCESS = 0
Const gnDT_DBASEIV = 1
Const gnDT_DBASEIII = 2
Const gnDT_FOXPRO26 = 3
Const gnDT_FOXPRO25 = 4
Const gnDT_FOXPRO20 = 5
Const gnDT_PARADOX4X = 6
Const gnDT_PARADOX3X = 7
Const gnDT_BTRIEVE = 8
Const gnDT_ODBC = 9
Private Sub cboConnect_Change()
  msDBName = ""
  mnDataType = gnDT_NONE
  lblDatabaseName.Caption = msDBName
  cboRecordSource.Clear
  Set mrecRS = Nothing
  lstFields.Clear
  lstIncludedFields.Clear
End Sub
Private Sub cboConnect_Click()
  Call cboConnect_Change
  mnDataType = cboConnect.ListIndex
End Sub
Private Sub cboRecordSource_Change()
  Set mrecRS = Nothing
  lstFields.Clear
  lstIncludedFields.Clear
End Sub
Private Sub cboRecordSource_Click()
  Call cboRecordSource_LostFocus
End Sub
Private Sub cboRecordSource_LostFocus()
  On Error GoTo RSErr
  Dim i As Integer
  Dim fld As Field
  If Len(cboRecordSource.TEXT) = 0 Then Exit Sub
  Screen.MousePointer = 11
  'this code clears out the current field list
  'and gets the new fields from the new recordset
  If mrecRS Is Nothing Then
    Set mrecRS = mdbCurrentDB.OpenRecordset(cboRecordSource.TEXT)
    For Each fld In mrecRS.Fields
      lstFields.AddItem fld.Name
    Next
  ElseIf mrecRS.Name <> cboRecordSource.TEXT Then
    lstFields.Clear
    lstIncludedFields.Clear
    Set mrecRS = mdbCurrentDB.OpenRecordset(cboRecordSource.TEXT)
    For Each fld In mrecRS.Fields
      lstFields.AddItem fld.Name
    Next
  End If
  Screen.MousePointer = 0
  Exit Sub
RSErr:
  Screen.MousePointer = 0
  MsgBox Error$
  Exit Sub
End Sub
Sub cmdBuildForm_Click()
  If Len(txtFormName.TEXT) = 0 Then
    MsgBox "Form Name cannot be blank!", 16
    txtFormName.SetFocus
    Exit Sub
  End If
  If InStr(txtFormName.TEXT, " ") > 0 Then
    MsgBox "Form Name cannot have spaces in it!", 16
    txtFormName.SetFocus
    Exit Sub
  End If
  If mdbCurrentDB Is Nothing Then
    MsgBox "You must open a Database!", 16
    Exit Sub
  End If
  If Len(cboRecordSource.TEXT) = 0 Then
    MsgBox "You must enter a RecordSource!", 16
    Exit Sub
  End If
  If lstIncludedFields.ListCount = 0 Then
    MsgBox "You must include some Columns!", 16
    Exit Sub
  End If
  If chkOnScreen.VALUE = vbChecked Then
    BuildFormOnScreen
  Else
    BuildFormFile
  End If
End Sub
Sub cmdClose_Click()
  Unload Me
End Sub
Private Sub cmdMoveFields_Click(Index As Integer)
  Dim i As Integer
  Select Case Index
    Case 0
      For i = 0 To lstFields.ListCount - 1
        lstIncludedFields.AddItem lstFields.List(i)
      Next
      lstFields.Clear
    Case 1
      If lstFields.ListIndex = -1 Then Exit Sub
      For i = lstFields.ListCount - 1 To 0 Step -1
        If lstFields.Selected(i) = True Then
          lstIncludedFields.AddItem lstFields.List(i)
          lstFields.RemoveItem i
        End If
      Next
    Case 2
      If lstIncludedFields.ListIndex = -1 Then Exit Sub
      For i = lstIncludedFields.ListCount - 1 To 0 Step -1
        If lstIncludedFields.Selected(i) = True Then
          lstFields.AddItem lstIncludedFields.List(i)
          lstIncludedFields.RemoveItem i
        End If
      Next
    Case 3
      For i = 0 To lstIncludedFields.ListCount - 1
        lstFields.AddItem lstIncludedFields.List(i)
      Next
      lstIncludedFields.Clear
  End Select
End Sub
Sub Form_Load()
  'center it on the screen
  Me.TOP = (Screen.Height - Me.Height) \ 2
  Me.Left = (Screen.Width - Me.Width) \ 2
  #If Win32 Then
    chkOnScreen.VALUE = vbChecked
    chkOnScreen.Visible = False
  #End If
  cboConnect.ListIndex = 0
End Sub
Sub lstIncludedFields_DragDrop(Source As Control, x As Single, Y As Single)
  Dim sTmp As String
  Dim nPos As Integer
  If Source = lstIncludedFields Then
    If lstIncludedFields.ListIndex >= 0 Then
      sTmp = lstIncludedFields.List(lstIncludedFields.ListIndex)
      nPos = (Y / TextHeight(sTmp)) + lstIncludedFields.TopIndex
      'check for the last item
      If nPos > lstIncludedFields.ListCount Then
        nPos = lstIncludedFields.ListCount
      End If
      lstIncludedFields.AddItem sTmp, nPos
      If lstIncludedFields.ListIndex > nPos Then
        lstIncludedFields.RemoveItem lstIncludedFields.ListIndex + 1
      Else
        lstIncludedFields.RemoveItem lstIncludedFields.ListIndex
      End If
    End If
    Source.MousePointer = 0
  End If
End Sub
Private Sub cmdOpenDB_Click()
  On Error GoTo OpenError
  Dim sConnect As String
  Dim sDatabaseName As String
  Dim tdf As TableDef
  Dim qdf As QueryDef
  Select Case mnDataType
    Case gnDT_ACCESS
      dlgDBOpen.Filter = "Access DBs (*.mdb)|*.mdb|All Files (*.*)|*.*"
      dlgDBOpen.DialogTitle = "Open MS Access Database"
    Case gnDT_BTRIEVE
      dlgDBOpen.Filter = "Btrieve DBs (FILE.DDF)|FILE.DDF"
      dlgDBOpen.DialogTitle = "Open Btrieve Database"
    Case gnDT_DBASEIII
      dlgDBOpen.Filter = "dBASE III DBs (*.dbf)|*.dbf"
      dlgDBOpen.DialogTitle = "Open dBASE III Database"
    Case gnDT_DBASEIV
      dlgDBOpen.Filter = "dBASE IV DBs (*.dbf)|*.dbf"
      dlgDBOpen.DialogTitle = "Open dBASE IV Database"
    Case gnDT_FOXPRO20
      dlgDBOpen.Filter = "FoxPro DBs (*.dbf)|*.dbf"
      dlgDBOpen.DialogTitle = "Open FoxPro 2.0 Database"
    Case gnDT_FOXPRO25
      dlgDBOpen.Filter = "FoxPro DBs (*.dbf)|*.dbf"
      dlgDBOpen.DialogTitle = "Open FoxPro 2.5 Database"
    Case gnDT_FOXPRO26
      dlgDBOpen.Filter = "FoxPro DBs (*.dbf)|*.dbf"
      dlgDBOpen.DialogTitle = "Open FoxPro 2.6 Database"
    Case gnDT_PARADOX3X
      dlgDBOpen.Filter = "Paradox DBs (*.db)|*.db"
      dlgDBOpen.DialogTitle = "Open Paradox 3.X Database"
    Case gnDT_PARADOX4X
      dlgDBOpen.Filter = "Paradox DBs (*.db)|*.db"
      dlgDBOpen.DialogTitle = "Open Paradox 4.X Database"
    Case Else
      If UCase(Left(cboConnect.TEXT, 4)) = "ODBC" Then
        'default to ODBC
        mnDataType = gnDT_ODBC
      Else
        Beep
        MsgBox "Invalid Connect String!", 48
        Exit Sub
      End If
  End Select
  If mnDataType <> gnDT_ODBC Then
    With dlgDBOpen
      .FilterIndex = 1
      .FileName = msDBName  '""
      .CancelError = True
      .Flags = &H4
      .Action = 1
    End With
    msDBName = dlgDBOpen.FileName
  Else
    msDBName = ""
  End If
  lblDatabaseName.Caption = msDBName
  cboRecordSource.Clear
  Set mrecRS = Nothing
  lstFields.Clear
  lstIncludedFields.Clear
  Me.Refresh       'repaint the form to get rid og the common dialog
  Select Case mnDataType
    Case gnDT_ACCESS
      sConnect = ""
      sDatabaseName = msDBName
    Case gnDT_DBASEIII
      sConnect = "dBASE III"
      sDatabaseName = StripFileName(msDBName)
    Case gnDT_DBASEIV
      sConnect = "dBASE IV"
      sDatabaseName = StripFileName(msDBName)
    Case gnDT_FOXPRO20
      sConnect = "FoxPro 2.0"
      sDatabaseName = StripFileName(msDBName)
    Case gnDT_FOXPRO25
      sConnect = "FoxPro 2.5"
      sDatabaseName = StripFileName(msDBName)
    Case gnDT_PARADOX3X
      sConnect = "Paradox 3.X"
      sDatabaseName = StripFileName(msDBName)
    Case gnDT_PARADOX4X
      sConnect = "Paradox 4.X"
      sDatabaseName = StripFileName(msDBName)
    Case gnDT_BTRIEVE
      sConnect = "Btrieve;"
      sDatabaseName = msDBName
    Case Else
      sConnect = cboConnect.TEXT
      sDatabaseName = msDBName
  End Select
  Screen.MousePointer = 11 'set the hourglass
  Set mdbCurrentDB = OpenDatabase(sDatabaseName, False, True, sConnect)
  'set the connect string for an ODBC datasource
  If mnDataType = gnDT_ODBC Then
    cboConnect.TEXT = mdbCurrentDB.Connect
  End If
  For Each tdf In mdbCurrentDB.TableDefs
    If (tdf.Attributes And &H80000002) = 0 Then
      cboRecordSource.AddItem tdf.Name
    End If
  Next
  If mnDataType = gnDT_ACCESS Then
    For Each qdf In mdbCurrentDB.QueryDefs
      cboRecordSource.AddItem qdf.Name
    Next
  End If
  cboRecordSource.ListIndex = 0
  Screen.MousePointer = 0 'unset the hourglass
  Exit Sub
OpenError:
  Screen.MousePointer = 0 'unset the hourglass
  If Err <> 32755 Then     'check for common dialog cancelled
    MsgBox Error
  End If
  Exit Sub
End Sub
Private Sub lstIncludedFields_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button = 1 Then lstIncludedFields.Drag
End Sub
Sub BuildFormOnScreen()
  On Error GoTo BuildErr
  Dim i As Integer
  Dim sTmp As String
  Dim nNumFlds As Integer
  Dim frmNewForm As VBIDE.FormTemplate
  Dim nButtonTop As Integer
  Dim iHiddenLeft As Integer
  nNumFlds = lstIncludedFields.ListCount
  lstOLECtls.Clear
  'create the new form
  Set frmNewForm = gobjIDEAppInst.ActiveProject.AddFormTemplate()
  'form height = 320 * numflds + 1260 for buttons and data control
  'form width = 5640
  With frmNewForm.Properties
    .Item("Caption") = Left(mrecRS.Name, 32)
    .Item("Height") = 1115 + (nNumFlds * 320)
    .Item("Name") = "frm" & txtFormName.TEXT
    .Item("Width") = 5640
    .Item("Left") = 1050
  End With
  iHiddenLeft = -5640
  'labels.left") = 120, .width") = 1815, .height = 255
  'fields.left = 2040, .width = 3375, .height = 285
  For i = 0 To nNumFlds - 1
    sTmp = lstIncludedFields.List(i)
    With frmNewForm.ControlTemplates.Add("Label").Properties
      .Item("Left") = iHiddenLeft
      .Item("Caption") = sTmp & ":"
      .Item("Height") = 255
      .Item("Index") = i
      .Item("Name") = "lblLabels"
      .Item("Top") = (i * 320) + 60
      .Item("Width") = 1815
      .Item("Left") = 120
    End With
    If mrecRS.Fields(sTmp).Type = 1 Then
      'true/false field
      With frmNewForm.ControlTemplates.Add("CheckBox").Properties
        .Item("Left") = iHiddenLeft
        .Item("Caption") = ""
        .Item("Height") = 285
        .Item("Index") = i
        .Item("Name") = "chkFields"
        .Item("Top") = (i * 320) + 40
        .Item("Width") = 3375
        .Item("DataSource") = "Data1"
        .Item("DataField") = sTmp
        .Item("Left") = 2040
      End With
    ElseIf mrecRS.Fields(sTmp).Type = 11 Then
      'picture field
      With frmNewForm.ControlTemplates.Add("OLE").Properties
        .Item("Left") = iHiddenLeft
        .Item("Height") = 285
        .Item("Name") = "oleField" & i
        .Item("OLETypeAllowed") = 1
        .Item("Top") = (i * 320) + 40
        .Item("Width") = 3375
        .Item("DataSource") = "Data1"
        .Item("DataField") = sTmp
        .Item("Left") = 2040
      End With
      SendKeys "{Esc}"
      lstOLECtls.AddItem i
    Else
      With frmNewForm.ControlTemplates.Add("TextBox").Properties
        .Item("Left") = iHiddenLeft
        .Item("Index") = i
        .Item("Name") = "txtFields"
        .Item("Text") = ""
        If mrecRS.Fields(sTmp).Type < 10 Then
          'numeric or date
          .Item("Width") = 1935
        Else
          'string or memo
          .Item("Width") = 3375
        End If
        .Item("DataSource") = "Data1"
        .Item("DataField") = sTmp
        If mrecRS.Fields(sTmp).Type = 10 Then
          .Item("Height") = 285
          .Item("Top") = (i * 320) + 40
          .Item("MaxLength") = mrecRS.Fields(sTmp).Size
        ElseIf mrecRS.Fields(sTmp).Type = 12 Then
          .Item("Height") = 310
          .Item("Top") = (i * 320) + 30
          .Item("MultiLine") = True
          .Item("ScrollBars") = 2
        Else
          .Item("Height") = 285
          .Item("Top") = (i * 320) + 40
        End If
        .Item("Left") = 2040
      End With
    End If
  Next
  nButtonTop = i * 320 + 60 'ctlNewControl.Properties.Item("Top") + 340
  'add the data control and buttons
  With frmNewForm.ControlTemplates.Add("Data").Properties
    .Item("Left") = iHiddenLeft
    .Item("Caption") = ""
    .Item("DatabaseName") = mdbCurrentDB.Name
    .Item("Connect") = mdbCurrentDB.Connect
    .Item("RecordSource") = cboRecordSource.TEXT
    .Item("Align") = 2
  End With
  With frmNewForm.ControlTemplates.Add("CommandButton").Properties
    .Item("Left") = iHiddenLeft
    .Item("Caption") = "&Add"
    .Item("Height") = 300
    .Item("Name") = "cmdAdd"
    .Item("Top") = nButtonTop
    .Item("Width") = 975
    .Item("Left") = 120
  End With
  With frmNewForm.ControlTemplates.Add("CommandButton").Properties
    .Item("Left") = iHiddenLeft
    .Item("Caption") = "&Delete"
    .Item("Height") = 300
    .Item("Name") = "cmdDelete"
    .Item("Top") = nButtonTop
    .Item("Width") = 975
    .Item("Left") = 1200
  End With
  With frmNewForm.ControlTemplates.Add("CommandButton").Properties
    .Item("Left") = iHiddenLeft
    .Item("Caption") = "&Refresh"
    .Item("Height") = 300
    .Item("Name") = "cmdRefresh"
    .Item("Top") = nButtonTop
    .Item("Width") = 975
    .Item("Left") = 2280
  End With
  With frmNewForm.ControlTemplates.Add("CommandButton").Properties
    .Item("Left") = iHiddenLeft
    .Item("Caption") = "&Update"
    .Item("Height") = 300
    .Item("Name") = "cmdUpdate"
    .Item("Top") = nButtonTop
    .Item("Width") = 975
    .Item("Left") = 3360
  End With
  With frmNewForm.ControlTemplates.Add("CommandButton").Properties
    .Item("Left") = iHiddenLeft
    .Item("Caption") = "&Close"
    .Item("Height") = 300
    .Item("Name") = "cmdClose"
    .Item("Top") = nButtonTop
    .Item("Width") = 975
    .Item("Left") = 4440
  End With
  'add the code to the form
  Dim fh As Integer
  fh = FreeFile
  Open App.Path & "\DFD_FRM.MOD" For Output As fh
  WriteFrmCode fh
  Close fh
  frmNewForm.InsertFile App.Path & "\DFD_FRM.MOD"
  Kill App.Path & "\DFD_FRM.MOD"
  'save the new form
  gobjIDEAppInst.ActiveProject.SelectedComponents(0).SaveAs (gobjIDEAppInst.LastUsedPath & "\" & txtFormName & ".FRM")
  'set the form back to defaults
  txtFormName.TEXT = ""
  cboRecordSource.TEXT = ""
  'try to set focus back to the form
  Me.SetFocus
  txtFormName.SetFocus
  Exit Sub
BuildErr:
  MsgBox Error$
  Exit Sub
End Sub
Sub BuildFormFile()
  On Error GoTo BuildFErr
  Dim i As Integer
  Dim sTmp As String
  Dim nNumFlds As Integer
  Dim frmNewForm As Object
  Dim ctlNewControl As Object
  Dim nButtonTop As Integer
  'create and open the file
  Dim nFileHnd As Integer
  nFileHnd = FreeFile
  Open gobjIDEAppInst.LastUsedPath & "\" & txtFormName & ".FRM" For Output As nFileHnd
  Print #nFileHnd, "VERSION 4.00"
  nNumFlds = lstIncludedFields.ListCount
  lstOLECtls.Clear
  Print #nFileHnd, "Begin VB.Form frm" & txtFormName.TEXT
  'form height = 320 * numflds + 1260 for buttons and data control
  'form width = 5640
  Print #nFileHnd, "   Caption = """ & Left(mrecRS.Name, 32) & """"
  Print #nFileHnd, "   Height       = " & 1115 + (nNumFlds * 320)
  Print #nFileHnd, "   Left         = 2400"
  Print #nFileHnd, "   Top          = 2040"
  Print #nFileHnd, "   Width        = 5640"
  'labels.left = 120, .width = 1815, .height = 255
  'fields.left = 2040, .width = 3375, .height = 285
  For i = 0 To nNumFlds - 1
    sTmp = lstIncludedFields.List(i)
    Print #nFileHnd, "   Begin VB.Label lblLabels"
    Print #nFileHnd, "      Caption = """ & sTmp & ":"""
    Print #nFileHnd, "      Height  = 255"
    Print #nFileHnd, "      Index   = " & i
    Print #nFileHnd, "      Left    = 120"
    Print #nFileHnd, "      Top     = " & (i * 320) + 60
    Print #nFileHnd, "      Width   = 1815"
    Print #nFileHnd, "   End"
    If mrecRS.Fields(sTmp).Type = 1 Then
      'true/false field
      Print #nFileHnd, "   Begin VB.CheckBox chkField" & i
      Print #nFileHnd, "      DataField  = """ & sTmp & """"
      Print #nFileHnd, "      DataSource = ""Data1"""
      Print #nFileHnd, "      Height     = 285"
      Print #nFileHnd, "      Index      = " & i
      Print #nFileHnd, "      Left       = 2040"
      Print #nFileHnd, "      Top        = " & (i * 320) + 40
      Print #nFileHnd, "      Width      = 3375"
      Print #nFileHnd, "   End"
    ElseIf mrecRS.Fields(sTmp).Type = 11 Then
      'picture field
      Print #nFileHnd, "   Begin VB.OLE oleField" & i
      Print #nFileHnd, "      DataField      = """ & sTmp & """"
      Print #nFileHnd, "      DataSource     = ""Data1"""
      Print #nFileHnd, "      Height         = 285"
      Print #nFileHnd, "      Left           = 2040"
      Print #nFileHnd, "      OLETypeAllowed = 1"
      Print #nFileHnd, "      Top            = " & (i * 320) + 40
      Print #nFileHnd, "      Width          = 3375"
      Print #nFileHnd, "   End"
      lstOLECtls.AddItem i
    Else
      Print #nFileHnd, "   Begin VB.TextBox txtField" & i
      Print #nFileHnd, "      DataField  = """ & sTmp & """"
      Print #nFileHnd, "      DataSource = ""Data1"""
      If mrecRS.Fields(sTmp).Type = 12 Then
        Print #nFileHnd, "      Height     = 310"
      Else
        Print #nFileHnd, "      Height     = 285"
      End If
      Print #nFileHnd, "      Index      = " & i
      Print #nFileHnd, "      Left       = 2040"
      If mrecRS.Fields(sTmp).Type = 10 Then
        Print #nFileHnd, "      MaxLength   = " & mrecRS.Fields(sTmp).Size
      End If
      If mrecRS.Fields(sTmp).Type = 12 Then
        Print #nFileHnd, "      MultiLine   = True"
      End If
      If mrecRS.Fields(sTmp).Type = 12 Then
        Print #nFileHnd, "      ScrollBars  = 2"
      End If
      Print #nFileHnd, "      Top        = " & (i * 320) + 40
      Print #nFileHnd, "      Text       = """""
      If mrecRS.Fields(sTmp).Type < 10 Then
        'numeric or date
        Print #nFileHnd, "      Width      = 1935"
      Else
        'string or memo
        Print #nFileHnd, "      Width      = 3375"
      End If
      Print #nFileHnd, "   End"
    End If
  Next
  nButtonTop = (((i - 1) * 320) + 40) + 340
  'add the data control and buttons
  Print #nFileHnd, "   Begin VB.Data Data1"
  Print #nFileHnd, "      Align        = 2"
  Print #nFileHnd, "      Caption      = """""
  Print #nFileHnd, "      Connect      = """ & mdbCurrentDB.Connect & """"
  Print #nFileHnd, "      DatabaseName = """ & mdbCurrentDB.Name & """"
  Print #nFileHnd, "      RecordSource = """ & cboRecordSource.TEXT & """"
  Print #nFileHnd, "   End"
  Print #nFileHnd, "   Begin VB.CommandButton cmdAdd"
  Print #nFileHnd, "      Caption      = ""&Add"""
  Print #nFileHnd, "      Height       = 300"
  Print #nFileHnd, "      Left         = 120"
  Print #nFileHnd, "      Top          = " & nButtonTop
  Print #nFileHnd, "      Width        = 975"
  Print #nFileHnd, "   End"
  Print #nFileHnd, "   Begin VB.CommandButton cmdDelete"
  Print #nFileHnd, "      Caption      = ""&Delete"""
  Print #nFileHnd, "      Height       = 300"
  Print #nFileHnd, "      Left         = 1200"
  Print #nFileHnd, "      Top          = " & nButtonTop
  Print #nFileHnd, "      Width        = 975"
  Print #nFileHnd, "   End"
  Print #nFileHnd, "   Begin VB.CommandButton cmdRefresh"
  Print #nFileHnd, "      Caption      = ""&Refresh"""
  Print #nFileHnd, "      Height       = 300"
  Print #nFileHnd, "      Left         = 2280"
  Print #nFileHnd, "      Top          = " & nButtonTop
  Print #nFileHnd, "      Width        = 975"
  Print #nFileHnd, "   End"
  Print #nFileHnd, "   Begin VB.CommandButton cmdUpdate"
  Print #nFileHnd, "      Caption      = ""&Update"""
  Print #nFileHnd, "      Height       = 300"
  Print #nFileHnd, "      Left         = 3360"
  Print #nFileHnd, "      Top          = " & nButtonTop
  Print #nFileHnd, "      Width        = 975"
  Print #nFileHnd, "   End"
  Print #nFileHnd, "   Begin VB.CommandButton cmdClose"
  Print #nFileHnd, "      Caption      = ""&Close"""
  Print #nFileHnd, "      Height       = 300"
  Print #nFileHnd, "      Left         = 4440"
  Print #nFileHnd, "      Top          = " & nButtonTop
  Print #nFileHnd, "      Width        = 975"
  Print #nFileHnd, "   End"
  Print #nFileHnd, "End"
  Print #nFileHnd, ""
  Print #nFileHnd, "Attribute VB_Name = ""frm" & txtFormName.TEXT & """"
  Print #nFileHnd, "Attribute VB_Creatable = False"
  Print #nFileHnd, "Attribute VB_Exposed = False"
  Print #nFileHnd, "Option Explicit"
  Print #nFileHnd, ""
  'add the code to the form
  WriteFrmCode nFileHnd
  Close nFileHnd
  'add the new form to the project
  gobjIDEAppInst.ActiveProject.AddFile gobjIDEAppInst.LastUsedPath & "\" & txtFormName & ".FRM"
  'set the form back to defaults
  txtFormName.TEXT = ""
  cboRecordSource.TEXT = ""
  'try to set focus back to the form
  Me.SetFocus
  txtFormName.SetFocus
  Exit Sub
BuildFErr:
  MsgBox Error$
  Exit Sub
End Sub