Jason Bodine
2012-02-27 05:31:36 UTC
Hi all,
As I stated in another thread, I'm working on version 4 of a program I
first developed back in the 90s. In this version, I'm using an Access
database so that the program can handle multiple user profiles.
I have no problem creating the database using ADOX or creating the
user "Admin." I also have no problem bringing up my profile creation
dialog. The problem comes when the user clicks the OK button to
create the profile. I don't know if the problem is in the
CreateProfile sub or cmdOK_Click event of frmAccount, or something in
the coding of frmSelect, which is supposed to pop up after the new
account is created in order for the user to select a profile to load,
but for some reason, running the program and clicking OK on frmAccount
causes VB6 to freeze and stop responding. Anyway, here's all the code
in question. Hopefully, someone can figure out what's wrong, because
I sure can't, lol!
Thanks,
Jason
'frmAccount Code:
Private Sub CreateProfile()
SetDB
Set Con = New ADODB.Connection
With Con
.Open sConnection, "Admin"
End With
Set Cmd = New ADODB.Command
With Cmd
.ActiveConnection = Con
.CommandText = "SELECT * FROM [User_Profiles]"
.CommandType = adCmdText
End With
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
.AddNew
.Fields(0) = txtUserName.Text
If chkEnablePassProt.Value = 1 Then
.Fields(1) = True
Else
.Fields(1) = False
End If
If txtPassword.Text = txtConfirm.Text Then
.Fields(2) = txtPassword.Text
Else
MsgBox "Password and Confirm Password do not match! Please
try again.", vbOKOnly + vbInformation, "Error"
.Close
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
Exit Sub
End If
If cmbQuestion.Text = "Enter Your Own Question" Or
cmbQuestion.Text = "" Then
MsgBox "This is a required field! Select a question from the
list or enter one of your own.", vbOKOnly + vbInformation, "Error"
.Close
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
Exit Sub
Else
.Fields(3) = cmbQuestion.Text
End If
If txtAnswer.Text <> "" Then
.Fields(4) = txtAnswer.Text
Else
MsgBox "This is a required field! Please enter an answer to
your selected question.", vbOKOnly + vbInformation, "Error"
.Close
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
Exit Sub
End If
.Fields(5) = txtEmail.Text
.Fields(6) = txtMobile1.Text
.Fields(7) = cmbServiceProvider.Text
.Fields(8) = txtSMSServer.Text
.Fields(9) = txtMMSServer.Text
If chkEmail.Value = 1 Then
.Fields(10) = True
Else
.Fields(10) = False
End If
If chkSMS.Value = 1 Then
.Fields(11) = True
Else
.Fields(11) = False
End If
If chkMMS.Value = 1 Then
.Fields(12) = True
Else
.Fields(12).Value = False
End If
If PicPath = "" Then
.Fields(13) = ""
Else
.Fields(13) = PicPath
End If
.Fields(14) = picDocBKG.BackColor
.Fields(15) = picFColor.BackColor
.Fields(16) = cmbFont.Text
.Fields(17) = txtFSize.Text
.Fields(18) = txtDocLMargin.Text
.Fields(19) = txtDocRMargin.Text
If chkDefaultProfile.Value = 1 Then
.Fields(20) = True
Else
.Fields(20) = False
End If
.Update
.Close
End With
Set Rec = Nothing
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
Do Until .EOF
If .Fields(0).Value <> txtUserName.Text Then
.Fields(20) = False
.Update
.MoveNext
End If
Loop
.Close
End With
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
End Sub
Private Sub cmdOK_Click()
Select Case Me.Caption
Case "Create New User Profile (First Run)"
CreateProfile
frmSelect.Show
Unload Me
Case Else 'Temporary until more
subs are written.
'Add More Code Here.
End Select
End Sub
' frmSelect Code:
Select Case cmbSelect.Text
Case "Admin"
MsgBox "'Admin' is a background process and cannot be
loaded. Please select another profile to load.", vbOKOnly +
vbInformation, "Error"
Case Else
SetDB
Set Con = New ADODB.Connection
With Con
.Open sConnection, "Admin"
End With
Set Cmd = New ADODB.Command
With Cmd
.ActiveConnection = Con
.CommandText = "SELECT * FROM [User_Profiles] WHERE
[User_Name]=" & cmbSelect.Text
.CommandType = adCmdText
End With
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
If .Fields(1).Value = True Then
frmLogin.Show
Else
frmSplash.Show
End If
.Close
End With
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
End Select
End Sub
Private Sub Form_Load()
Call ApplyDropShadow(Me.hWnd)
SetDB
Set Con = New ADODB.Connection
With Con
.Open sConnection, "Admin"
End With
Set Cmd = New ADODB.Command
With Cmd
.ActiveConnection = Con
.CommandText = "SELECT * FROM [User_Profiles]"
.CommandType = adCmdText
End With
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
Do Until .EOF
cmbSelect.AddItem .Fields(0)
.MoveNext
Loop
If .Fields(20) = True Then cmbSelect.Text = .Fields(0).Value
.Close
End With
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
End Sub
As I stated in another thread, I'm working on version 4 of a program I
first developed back in the 90s. In this version, I'm using an Access
database so that the program can handle multiple user profiles.
I have no problem creating the database using ADOX or creating the
user "Admin." I also have no problem bringing up my profile creation
dialog. The problem comes when the user clicks the OK button to
create the profile. I don't know if the problem is in the
CreateProfile sub or cmdOK_Click event of frmAccount, or something in
the coding of frmSelect, which is supposed to pop up after the new
account is created in order for the user to select a profile to load,
but for some reason, running the program and clicking OK on frmAccount
causes VB6 to freeze and stop responding. Anyway, here's all the code
in question. Hopefully, someone can figure out what's wrong, because
I sure can't, lol!
Thanks,
Jason
'frmAccount Code:
Private Sub CreateProfile()
SetDB
Set Con = New ADODB.Connection
With Con
.Open sConnection, "Admin"
End With
Set Cmd = New ADODB.Command
With Cmd
.ActiveConnection = Con
.CommandText = "SELECT * FROM [User_Profiles]"
.CommandType = adCmdText
End With
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
.AddNew
.Fields(0) = txtUserName.Text
If chkEnablePassProt.Value = 1 Then
.Fields(1) = True
Else
.Fields(1) = False
End If
If txtPassword.Text = txtConfirm.Text Then
.Fields(2) = txtPassword.Text
Else
MsgBox "Password and Confirm Password do not match! Please
try again.", vbOKOnly + vbInformation, "Error"
.Close
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
Exit Sub
End If
If cmbQuestion.Text = "Enter Your Own Question" Or
cmbQuestion.Text = "" Then
MsgBox "This is a required field! Select a question from the
list or enter one of your own.", vbOKOnly + vbInformation, "Error"
.Close
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
Exit Sub
Else
.Fields(3) = cmbQuestion.Text
End If
If txtAnswer.Text <> "" Then
.Fields(4) = txtAnswer.Text
Else
MsgBox "This is a required field! Please enter an answer to
your selected question.", vbOKOnly + vbInformation, "Error"
.Close
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
Exit Sub
End If
.Fields(5) = txtEmail.Text
.Fields(6) = txtMobile1.Text
.Fields(7) = cmbServiceProvider.Text
.Fields(8) = txtSMSServer.Text
.Fields(9) = txtMMSServer.Text
If chkEmail.Value = 1 Then
.Fields(10) = True
Else
.Fields(10) = False
End If
If chkSMS.Value = 1 Then
.Fields(11) = True
Else
.Fields(11) = False
End If
If chkMMS.Value = 1 Then
.Fields(12) = True
Else
.Fields(12).Value = False
End If
If PicPath = "" Then
.Fields(13) = ""
Else
.Fields(13) = PicPath
End If
.Fields(14) = picDocBKG.BackColor
.Fields(15) = picFColor.BackColor
.Fields(16) = cmbFont.Text
.Fields(17) = txtFSize.Text
.Fields(18) = txtDocLMargin.Text
.Fields(19) = txtDocRMargin.Text
If chkDefaultProfile.Value = 1 Then
.Fields(20) = True
Else
.Fields(20) = False
End If
.Update
.Close
End With
Set Rec = Nothing
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
Do Until .EOF
If .Fields(0).Value <> txtUserName.Text Then
.Fields(20) = False
.Update
.MoveNext
End If
Loop
.Close
End With
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
End Sub
Private Sub cmdOK_Click()
Select Case Me.Caption
Case "Create New User Profile (First Run)"
CreateProfile
frmSelect.Show
Unload Me
Case Else 'Temporary until more
subs are written.
'Add More Code Here.
End Select
End Sub
' frmSelect Code:
Select Case cmbSelect.Text
Case "Admin"
MsgBox "'Admin' is a background process and cannot be
loaded. Please select another profile to load.", vbOKOnly +
vbInformation, "Error"
Case Else
SetDB
Set Con = New ADODB.Connection
With Con
.Open sConnection, "Admin"
End With
Set Cmd = New ADODB.Command
With Cmd
.ActiveConnection = Con
.CommandText = "SELECT * FROM [User_Profiles] WHERE
[User_Name]=" & cmbSelect.Text
.CommandType = adCmdText
End With
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
If .Fields(1).Value = True Then
frmLogin.Show
Else
frmSplash.Show
End If
.Close
End With
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
End Select
End Sub
Private Sub Form_Load()
Call ApplyDropShadow(Me.hWnd)
SetDB
Set Con = New ADODB.Connection
With Con
.Open sConnection, "Admin"
End With
Set Cmd = New ADODB.Command
With Cmd
.ActiveConnection = Con
.CommandText = "SELECT * FROM [User_Profiles]"
.CommandType = adCmdText
End With
Set Rec = New ADODB.Recordset
With Rec
.CursorType = adOpenStatic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open Cmd
Do Until .EOF
cmbSelect.AddItem .Fields(0)
.MoveNext
Loop
If .Fields(20) = True Then cmbSelect.Text = .Fields(0).Value
.Close
End With
Set Rec = Nothing
Set Cmd = Nothing
Con.Close
Set Con = Nothing
End Sub