Visual Basic 4 Unleashed/Visual_Basic_4_Unleashed_SAMS_Publishing_1995.iso/source/chap34/contacts.frm

Visual Basic Form | 1995-09-12 | 20.9 KB | 654 lines

VERSION 4.00
Begin VB.Form frmContacts
   BackColor       =   &H00C0C0C0&
   Caption         =   "Contact Manager"
   ClientHeight    =   4605
   ClientLeft      =   1800
   ClientTop       =   1785
   ClientWidth     =   7275
   BeginProperty Font
      name            =   "MS Sans Serif"
      charset         =   0
      weight          =   700
      size            =   8.25
      underline       =   0   'False
      italic          =   0   'False
      strikethrough   =   0   'False
   EndProperty
   Height          =   5295
   Icon            =   "frmContacts.frx":0000
   Left            =   1740
   LinkTopic       =   "Form1"
   ScaleHeight     =   4605
   ScaleWidth      =   7275
   Top             =   1155
   Width           =   7395
   Begin VB.CommandButton cmdReport
      Caption         =   "&Report"
      Height          =   375
      HelpContextID   =   13
      Left            =   6120
      TabIndex        =   13
      Top             =   3480
      Width           =   855
   End
   Begin VB.CommandButton cmdCancel
      Caption         =   "&Cancel"
      Enabled         =   0   'False
      Height          =   375
      HelpContextID   =   10
      Left            =   6120
      TabIndex        =   10
      Top             =   1680
      Width           =   855
   End
   Begin VB.CommandButton cmdDelete
      Caption         =   "&Delete"
      Height          =   375
      HelpContextID   =   11
      Left            =   6120
      TabIndex        =   11
      Top             =   2280
      Width           =   855
   End
   Begin VB.CommandButton cmdAdd
      Caption         =   "&Add "
      Height          =   375
      HelpContextID   =   8
      Left            =   6120
      TabIndex        =   8
      Top             =   480
      Width           =   855
   End
   Begin VB.CommandButton cmdSave
      Caption         =   "&Save"
      Enabled         =   0   'False
      Height          =   375
      HelpContextID   =   9
      Left            =   6120
      TabIndex        =   9
      Top             =   1080
      Width           =   855
   End
   Begin VB.CommandButton cmdQuery
      Caption         =   "&Query"
      Height          =   375
      HelpContextID   =   12
      Left            =   6120
      TabIndex        =   12
      Top             =   3000
      Width           =   855
   End
   Begin VB.Frame Frame2
      BackColor       =   &H000080FF&
      Caption         =   "Company Information"
      Height          =   1695
      HelpContextID   =   6
      Left            =   360
      TabIndex        =   16
      Top             =   960
      Width           =   5535
      Begin VB.TextBox txtZip
         BackColor       =   &H00FFFFFF&
         DataField       =   "Zip"
         DataSource      =   "dtaContacts"
         ForeColor       =   &H00000000&
         Height          =   285
         Left            =   3960
         TabIndex        =   5
         Text            =   "txtZip"
         Top             =   1200
         Width           =   1455
      End
      Begin VB.TextBox txtState
         BackColor       =   &H00FFFFFF&
         DataField       =   "State"
         DataSource      =   "dtaContacts"
         ForeColor       =   &H00000000&
         Height          =   285
         Left            =   3360
         TabIndex        =   4
         Text            =   "txtState"
         Top             =   1200
         Width           =   495
      End
      Begin VB.TextBox txtCity
         BackColor       =   &H00FFFFFF&
         DataField       =   "City"
         DataSource      =   "dtaContacts"
         ForeColor       =   &H00000000&
         Height          =   285
         Left            =   480
         TabIndex        =   3
         Text            =   "txtCity"
         Top             =   1200
         Width           =   2775
      End
      Begin VB.TextBox txtAddress
         BackColor       =   &H00FFFFFF&
         DataField       =   "Address"
         DataSource      =   "dtaContacts"
         ForeColor       =   &H00000000&
         Height          =   285
         Left            =   480
         TabIndex        =   2
         Text            =   "txtAddress"
         Top             =   840
         Width           =   4935
      End
      Begin VB.TextBox txtName
         BackColor       =   &H00FFFFFF&
         DataField       =   "Company"
         DataSource      =   "dtaContacts"
         ForeColor       =   &H00000000&
         Height          =   285
         Left            =   480
         TabIndex        =   1
         Text            =   "txtCompany"
         Top             =   480
         Width           =   4935
      End
   End
   Begin VB.Frame Frame1
      BackColor       =   &H00C0C0C0&
      Caption         =   "Contact"
      Height          =   975
      HelpContextID   =   7
      Left            =   360
      TabIndex        =   14
      Top             =   2880
      Width           =   5535
      Begin VB.PictureBox picPhone
         Appearance      =   0  'Flat
         BackColor       =   &H00C0C0C0&
         BorderStyle     =   0  'None
         ForeColor       =   &H80000008&
         Height          =   495
         Left            =   240
         Picture         =   "frmContacts.frx":030A
         ScaleHeight     =   495
         ScaleWidth      =   495
         TabIndex        =   18
         Top             =   240
         Width           =   495
      End
      Begin VB.TextBox Text8
         BackColor       =   &H00FFFFFF&
         DataField       =   "Phone"
         DataSource      =   "dtaContacts"
         Height          =   285
         Left            =   960
         TabIndex        =   7
         Text            =   "txtPhone"
         Top             =   600
         Width           =   4455
      End
      Begin VB.TextBox txtContact
         BackColor       =   &H00FFFFFF&
         DataField       =   "Contact"
         DataSource      =   "dtaContacts"
         Height          =   285
         Left            =   960
         TabIndex        =   6
         Text            =   "txtContact"
         Top             =   240
         Width           =   4455
      End
      Begin VB.Label lblPhone
         Appearance      =   0  'Flat
         AutoSize        =   -1  'True
         BackColor       =   &H00C0FFFF&
         BorderStyle     =   1  'Fixed Single
         Caption         =   "AutoDial"
         ForeColor       =   &H80000008&
         Height          =   255
         Left            =   120
         TabIndex        =   20
         Top             =   720
         Visible         =   0   'False
         Width           =   795
      End
   End
   Begin VB.Data dtaContacts
      Align           =   2  'Align Bottom
      Caption         =   "Contact Browser"
      Connect         =   ""
      DatabaseName    =   "C:\VB40\SAMS\Contacts.mdb"
      Exclusive       =   0   'False
      Height          =   300
      Left            =   0
      Options         =   0
      ReadOnly        =   0   'False
      RecordsetType   =   1  'Dynaset
      RecordSource    =   "Contacts"
      Top             =   4305
      Width           =   7275
   End
   Begin VB.Frame Frame3
      BackColor       =   &H00C0C0C0&
      Caption         =   "Code"
      Height          =   615
      Left            =   360
      TabIndex        =   17
      Top             =   240
      Width           =   1335
      Begin VB.TextBox txtCode
         BackColor       =   &H00FF0000&
         BorderStyle     =   0  'None
         DataField       =   "Code"
         DataSource      =   "dtaContacts"
         BeginProperty Font
            name            =   "MS Sans Serif"
            charset         =   0
            weight          =   700
            size            =   9.75
            underline       =   0   'False
            italic          =   0   'False
            strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00FFFFFF&
         Height          =   285
         HelpContextID   =   4
         Left            =   120
         TabIndex        =   0
         Text            =   "txtCode"
         Top             =   240
         Width           =   975
      End
   End
   Begin MSCommLib.MSComm MSComm1
      Left            =   1800
      Top             =   3960
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
      CDTimeout       =   0
      CommPort        =   1
      CTSTimeout      =   0
      DSRTimeout      =   0
      DTREnable       =   -1  'True
      Handshaking     =   0
      InBufferSize    =   1024
      InputLen        =   0
      Interval        =   1000
      NullDiscard     =   0   'False
      OutBufferSize   =   512
      ParityReplace   =   "?"
      RThreshold      =   0
      RTSEnable       =   0   'False
      Settings        =   "9600,n,8,1"
      SThreshold      =   0
   End
   Begin MSComDlg.CommonDialog CommonDialog1
      Left            =   1080
      Top             =   3960
      _Version        =   65536
      _ExtentX        =   847
      _ExtentY        =   847
      _StockProps     =   0
   End
   Begin Crystal.CrystalReport CrystalReport1
      Left            =   360
      Top             =   3960
      _ExtentX        =   741
      _ExtentY        =   741
      _StockProps     =   0
      ReportFileName  =   ""
      Destination     =   0
      WindowLeft      =   100
      WindowTop       =   100
      WindowWidth     =   490
      WindowHeight    =   300
      WindowTitle     =   ""
      WindowBorderStyle=   2
      WindowControlBox=   -1  'True
      WindowMaxButton =   -1  'True
      WindowMinButton =   -1  'True
      CopiesToPrinter =   1
      PrintFileName   =   ""
      PrintFileType   =   0
      SelectionFormula=   ""
      GroupSelectionFormula=   ""
      Connect         =   ""
      UserName        =   ""
      ReportSource    =   0
      BoundReportHeading=   ""
      BoundReportFooter=   0   'False
   End
   Begin VB.Label Label1
      Caption         =   "Contacts"
      Height          =   255
      Left            =   3360
      TabIndex        =   19
      Top             =   240
      Width           =   1215
   End
   Begin MSDBCtls.DBCombo dbcContacts
      Bindings        =   "frmContacts.frx":0614
      DataSource      =   "dtaContacts"
      Height          =   315
      HelpContextID   =   5
      Left            =   3360
      TabIndex        =   15
      Top             =   480
      Width           =   2535
      _Version        =   65536
      _ExtentX        =   4471
      _ExtentY        =   556
      _StockProps     =   77
      ForeColor       =   0
      BackColor       =   16777215
      Style           =   2
      ListField       =   "Contact"
      BoundColumn     =   "Contact"
   End
   Begin VB.Menu mnuFile
      Caption         =   "&File"
      Begin VB.Menu mnuImport
         Caption         =   "&Import"
         HelpContextID   =   1
      End
      Begin VB.Menu mnuExport
         Caption         =   "&Export"
         HelpContextID   =   2
      End
      Begin VB.Menu mnuSep1
         Caption         =   "-"
      End
      Begin VB.Menu mnuSetUp
         Caption         =   "&Program Setup"
         HelpContextID   =   3
      End
      Begin VB.Menu mnuSep2
         Caption         =   "-"
      End
      Begin VB.Menu mnuExit
         Caption         =   "E&xit"
      End
   End
   Begin VB.Menu mnuHelp
      Caption         =   "&Help"
      Begin VB.Menu mnuContents
         Caption         =   "&Contents..."
      End
      Begin VB.Menu mnuAbout
         Caption         =   "&About Contact Manager..."
      End
   End
Attribute VB_Name = "frmContacts"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Dim sLastRecord As String
Private Sub cmdAdd_Click()
    sLastRecord = dtaContacts.Recordset.Bookmark
    cmdAdd.Enabled = False
    cmdSave.Enabled = True
    cmdCancel.Enabled = True
    dtaContacts.Recordset.AddNew
    txtCode.SetFocus
End Sub
Private Sub cmdCancel_Click()
cmdCancel.Enabled = False
cmdSave.Enabled = False
cmdAdd.Enabled = True
dtaContacts.Recordset.Bookmark = sLastRecord
End Sub
Private Sub cmdQuery_Click()
  frmQuery.Show
End Sub
Private Sub cmdDelete_Click()
 If MsgBox("OK To Delete?", vbQuestion + vbYesNo, "Deleting " & txtContact) = vbYes Then
 dtaContacts.Recordset.Delete
 dtaContacts.Recordset.MovePrevious
 End If
End Sub
Private Sub cmdReport_Click()
CrystalReport1.Destination = 0
CrystalReport1.ReportFileName = "C:\VB40\SAMS\CONTACTS.RPT"
CrystalReport1.Action = 1
End Sub
Private Sub cmdSave_Click()
    dtaContacts.Recordset.Update
    cmdSave.Enabled = False
    cmdCancel.Enabled = False
    cmdAdd.Enabled = True
End Sub
Private Sub cbxNames_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then cmdFind.Value = True
End Sub
Private Sub dbcContacts_Click(Area As Integer)
Dim sCriteria As String
sCriteria = "Contact = '" & dbcContacts & "'"
dtaContacts.Recordset.FindFirst sCriteria
End Sub
Private Sub Form_Activate()
'dbcContacts.TEXT = dtaContacts.Recordset("Contact")
End Sub
Sub DialOut(sCallNumber As String)
On Error GoTo LocalHandler
MSComm1.CommPort = 2
MSComm1.Settings = "9600,N,8,1"
MSComm1.InputLen = 0
MSComm1.PortOpen = True
MSComm1.Output = "AT" + Chr$(13)
    dummy = DoEvents()
Loop Until MSComm1.InBufferCount >= 2
MSComm1.InBufferCount = 0
MSComm1.Output = "ATDT" + sCallNumber + Chr$(13)
MsgBox "Pick Up The Phone And Click OK", vbExclamation, "Dialing: " & sCallNumber & "..."
MSComm1.PortOpen = False
Exit Sub
LocalHandler:
  MsgBox Error$(Err), vbCritical, "Modem Communications Error!"
  Exit Sub
End Sub
Sub ExportFile(sFileOut As String)
Dim dbContacts As Database
Dim rsContacts As Recordset
Dim iFileNumber As Integer
Dim iRecordNumber As Integer
Dim NL As String
Dim CurrentRecord As ContactRecord
On Error GoTo LocalHandler
NL = Chr$(13) & Chr$(10)
Set dbContacts = OpenDatabase("c:\vb40\sams\contacts.mdb")
Set rsContacts = dbContacts.OpenRecordset("Contacts", dbOpenDynaset)
rsContacts.MoveFirst
iFileNumber = FreeFile
Open sFileOut For Random As #iFileNumber Len = Len(CurrentRecord)
Do Until rsContacts.EOF
iRecordNumber = iRecordNumber + 1
CurrentRecord.code = rsContacts("Code")
CurrentRecord.Company = rsContacts("Company")
CurrentRecord.Address = rsContacts("Address")
CurrentRecord.City = rsContacts("City")
CurrentRecord.State = rsContacts("State")
CurrentRecord.Zip = rsContacts("Zip")
CurrentRecord.Contact = rsContacts("Contact")
CurrentRecord.Phone = rsContacts("Phone")
CurrentRecord.NewLine = NL
Put #iFileNumber, iRecordNumber, CurrentRecord   ' Write record to file.
rsContacts.Delete
rsContacts.MoveNext
dtaContacts.Refresh
Close #iFileNumber
rsContacts.Close
dbContacts.Close
MsgBox "Table Has Been Emptied!", vbInformation, "Data Export Successful!"
Exit Sub
LocalHandler:
  MsgBox Error$(Err), vbCritical, "File Export Error"
  Exit Sub
End Sub
Sub ImportFile(sFileIn As String)
Dim dbContacts As Database
Dim rsContacts As Recordset
Dim iFileNumber, iRecordNumber As Integer
Dim iFileSize, iTotalRecords As Long
Dim CurrentRecord As ContactRecord
On Error GoTo LocalHandler
Set dbContacts = OpenDatabase("c:\vb40\sams\contacts.mdb")
Set rsContacts = dbContacts.OpenRecordset("Contacts", dbOpenDynaset)
iFileNumber = FreeFile
Open sFileIn For Random As iFileNumber Len = Len(CurrentRecord)
iFileSize = LOF(iFileNumber)
iTotalRecords = Int(iFileSize / Len(CurrentRecord))
iRecordNumber = 1
Do While iRecordNumber <= iTotalRecords
    Get iFileNumber, iRecordNumber, CurrentRecord
    rsContacts.AddNew
    rsContacts("Code") = CurrentRecord.code
    rsContacts("Company") = CurrentRecord.Company
    rsContacts("Address") = CurrentRecord.Address
    rsContacts("City") = CurrentRecord.City
    rsContacts("State") = CurrentRecord.State
    rsContacts("Zip") = CurrentRecord.Zip
    rsContacts("Contact") = CurrentRecord.Contact
    rsContacts("Phone") = CurrentRecord.Phone
    rsContacts.Update
    iRecordNumber = iRecordNumber + 1
rsContacts.Close
dtaContacts.Refresh
MsgBox "New Records Have Been Added!", vbInformation, "Data Import Successful!"
Exit Sub
LocalHandler:
  MsgBox Error$(Err), vbCritical, "File Import Error"
Exit Sub
End Sub
Private Sub Form_Load()
Dim iFileNumber As Integer
Dim sCompany, sUser, sConfigFile As String
On Error GoTo LocalHandler
sConfigFile = Dir("C:\vb40\sams\contacts.cfg")
If sConfigFile = "" Then
Me.Caption = "Contact Manager"
sConfigFile = "C:\vb40\sams\" & sConfigFile
iFileNumber = FreeFile
Open sConfigFile For Input As #iFileNumber
    If LOF(iFileNumber) > 0 Then
    Line Input #iFileNumber, sUser
    Line Input #iFileNumber, sCompany
    Close #iFileNumber
    Me.Caption = "Contact Manager: " + sUser + " At " + sCompany + ""
    Else
    Close #iFileNumber
    Me.Caption = "EVB Contact Manager"
    End If
End If
'Refresh
Exit Sub
LocalHandler:
  MsgBox Error$(Err), vbCritical, "Error Reading Setup File"
  Exit Sub
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblPhone.Visible = False
End Sub
Private Sub Form_Unload(Cancel As Integer)
RetVal = WinHelp(hwnd, dummy$, HELP_QUIT, 0)
End Sub
Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblPhone.Visible = False
End Sub
Private Sub Frame2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblPhone.Visible = False
End Sub
Private Sub mnuContents_Click()
RetVal = WinHelp(frmContacts.hwnd, "c:\vb40\hc\contacts.hlp", HELP_INDEX, CLng(0))
End Sub
Private Sub mnuExit_Click()
End Sub
Private Sub Form_DblClick()
frmGrid.Show
End Sub
Private Sub mnuExport_Click()
Dim sFileName As String
On Error GoTo LocalHandler
CommonDialog1.CancelError = True
CommonDialog1.DialogTitle = "Enter Export File Name"
CommonDialog1.Filter = "Export Data Files (*.DAT)|*.DAT|All Files (*.*)|*.*"
CommonDialog1.FilterIndex = 1
CommonDialog1.DefaultExt = "DAT"
CommonDialog1.InitDir = "C:\VB40\SAMS"
CommonDialog1.Action = 2
sFileName = CommonDialog1.filename
If sFileName <> "" Then
ExportFile sFileName
End If
Exit Sub
LocalHandler:
Exit Sub
End Sub
Private Sub mnuImport_Click()
Dim sFileName As String
On Error GoTo LocalHandler
CommonDialog1.CancelError = True
CommonDialog1.DialogTitle = "Select Data File For Import"
CommonDialog1.Filter = "Import Data Files (*.DAT)|*.DAT|All Files (*.*)|*.*"
CommonDialog1.FilterIndex = 1
CommonDialog1.InitDir = "C:\VB40\SAMS"
CommonDialog1.Action = 1
sFileName = CommonDialog1.filename
If sFileName <> "" Then
ImportFile sFileName
End If
Exit Sub
LocalHandler:
  Exit Sub
End Sub
Private Sub mnuSetUp_Click()
Dim sUser, sCompany As String
Dim iFileNumber As Integer
On Error GoTo LocalHandler
sUser = InputBox$("Please Enter Your Name: ", "Program Setup Information")
If sUser = "" Then Exit Sub
sCompany = InputBox("Please Enter The Name Of Your Company: ", "Program Setup Information")
If sCompany = "" Then Exit Sub
iFileNumber = FreeFile
Open "C:\vb40\sams\Contacts.Cfg" For Output As #iFileNumber
Print #iFileNumber, sUser
Print #iFileNumber, sCompany
Close #iFileNumber
Me.Caption = "Contact Manager: " & sUser & " At " & sCompany
Exit Sub
LocalHandler:
  MsgBox Error$(Err), vbCritical, "Error Creating Setup File"
  Exit Sub
End Sub
Private Sub picPhone_Click()
Dim sPhoneNumber As String
sPhoneNumber = dtaContacts.Recordset("PHONE")
If Mid(sPhoneNumber, 1, 1) = "(" Then
   sPhoneNumber = "1-" + sPhoneNumber
End If
DialOut sPhoneNumber
End Sub
Private Sub picPhone_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblPhone.Visible = True
End Sub
Private Sub Text8_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then txtCode.SetFocus
End Sub
Private Sub txtAddress_KeyPress(KeyAscii As Integer)
   If KeyAscii = 13 Then txtCity.SetFocus
End Sub
Private Sub txtCity_KeyPress(KeyAscii As Integer)
   If KeyAscii = 13 Then txtState.SetFocus
End Sub
Private Sub txtCode_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then txtName.SetFocus
End Sub
Private Sub txtContact_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then Text8.SetFocus
End Sub
Private Sub txtName_KeyPress(KeyAscii As Integer)
   If KeyAscii = 13 Then txtAddress.SetFocus
End Sub
Private Sub txtState_KeyPress(KeyAscii As Integer)
   If KeyAscii = 13 Then txtZip.SetFocus
End Sub
Private Sub txtZip_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then txtContact.SetFocus
End Sub