Pop up alert vb 6 - vb6

Can someone help me. I'm having a hard time with this. All I need is to display an alert message whenever the medicines expired.My problem is when I got two or more expired medicines it doesn't alert all.Instead it alerts one medicine.Please help.
here is my code
Private Sub Form_Activate()
On Error Resume Next
With Main
.Text4 = Adodc1.Recordset.Fields("MedicineName")
.Text1.Text = Adodc1.Recordset.Fields("genericname")
.Text3.Text = Adodc1.Recordset.Fields("StockQuantity")
.Combo3 = Adodc1.Recordset.Fields("Expmonth")
.Combo4 = Adodc1.Recordset.Fields("Expday")
.Combo5 = Adodc1.Recordset.Fields("Expyear")
End With
Dim expirationdate As Date
expirationdate = CDate(Combo3 & "/" & Combo4 & "/" & Combo5)
datepicker.Value = Format(Now, "MMM-DD-yyyy")
If datepicker > expirationdate Then
MsgBox Text4.Text & " is expired ", vbExclamation, "Warning!"
If MsgBox("Do you want to dispose " & Text4 & "?", vbQuestion + vbYesNo, "Message") = vbYes Then
Adodc1.Recordset.Delete
ElseIf vbNo Then
Exit Sub
End If
End If
End Sub
Private Sub Form_Load()
Adodc1.CommandType = adCmdUnknown
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\clinic.mdb" & ";Persist Security Info=False"
Adodc1.RecordSource = "select * from inventory order by Expyear asc"
Adodc1.Refresh
Adodc1.Refresh
End sub

You need to loop through all of the records in your recordset. Currently, you're operating on the FIRST record only.
Do Until Adodc1.Recordset.EOF
' Assign values to textboxes, test date, etc.
' Fetch the next record...
Adodc1.Recordset.MoveNext
Loop

Bond is correct, you need to iterate over your recordset to display the message for each record that is expired.
Private Sub Form_Activate()
Dim expirationdate As Date
On Error Resume Next '<-- this is going to cause a problem if you never check for errors
Adodc1.Recordset.MoveFirst 'make sure the control is positioned on the first record
Do While Adodc1.Recordset.EOF = False 'loop over all of the records
With Main
.Text4.Text = Adodc1.Recordset.Fields("MedicineName")
.Text1.Text = Adodc1.Recordset.Fields("genericname")
.Text3.Text = Adodc1.Recordset.Fields("StockQuantity")
.Combo3 = Adodc1.Recordset.Fields("Expmonth")
.Combo4 = Adodc1.Recordset.Fields("Expday")
.Combo5 = Adodc1.Recordset.Fields("Expyear")
End With
expirationdate = CDate(Combo3 & "/" & Combo4 & "/" & Combo5)
datepicker.Value = Format(Now, "MMM-DD-yyyy")
If datepicker > expirationdate Then
MsgBox Text4.Text & " is expired ", vbExclamation, "Warning!"
If MsgBox("Do you want to dispose " & Text4 & "?", vbQuestion + vbYesNo, "Message") = vbYes Then
Adodc1.Recordset.Delete
End If
End If
Adodc1.Recordset.MoveNext
Loop
End Sub

Related

How can I show a space between the first and last name in my email attachment file name?

My Excel database generates a word document (when a button is clicked) from data the user enters into the database and opens an outlook email with the document attached automatically. When the email pops up with the attachment, the attachment name always has %20 in between the first and last name. I know this is because there is a blank space between the first and last name. Is there a way to remove the %20 and keep the blank space?
My Code
Option Explicit
Sub CreateWordDocuments()
'CREATE A WORD DOCUMENT TO TRANSFER INFORMATION FROM FILTERED
DATA
INTO A WORD TEMPLATE
Dim VSCRow, VSCCol, LastRow, TemplRow, MonthNumber, FromMonth,
ToMonth, DaysOfMonth, FromDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim WordContent As Word.Range
With Sheet5
If .Range("B3").Value = Empty Then
MsgBox "Please select the correct template from the drop down
list"
.Range("F4").Select
Exit Sub
End If
TemplRow = .Range("B3").Value ' Set the Template Value
TemplName = .Range("F4").Value ' Set Template Name
MonthNumber = .Range("V4").Value 'Set the Month Number
FromMonth = .Range("W4").Value
ToMonth = .Range("Y4").Value
DaysOfMonth = .Range("AA4").Value
FromDays = .Range("AC4").Value
ToDays = .Range("AF4").Value
DocLoc = Sheet10.Range("F" & TemplRow).Value ' Word Document
Filename
'Open Word Template
On Error Resume Next 'If Word is already open
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
' Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If
LastRow = .Range("E99999").End(xlUp).Row 'Determine the last Row
For VSCRow = 8 To LastRow
MonthNumber = .Range("X" & VSCRow).Value
DaysOfMonth = .Range("AF" & VSCRow).Value
If TemplName <> .Range("Z" & VSCRow).Value And MonthNumber >=
FromMonth And MonthNumber <= ToMonth And DaysOfMonth >= FromDays
And DaysOfMonth <= ToDays Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc,
ReadOnly:=False) ' Open Template
For VSCCol = 5 To 42 'Move through the colunms for
information
TagName = .Cells(7, VSCCol).Value 'Tag Name
TagValue = .Cells(VSCRow, VSCCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = TagValue
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Forward:True,
Wrap:=wdFindContinue
End With
Next VSCCol
If .Range("H4").Value = "PDF" Then
FileName = ThisWorkbook.Path & "\" & .Range("E" &
VSCRow).Value & ".pdf" ' Create full filename and path with
current
workbook
WordDoc.ExportAsFixedFormat OutputFileName:=FileName,
ExportFormat:=wdExportFormatPDF
WordDoc.Close False
Else:
FileName = ThisWorkbook.Path & "\" & .Range("E" &
VSCRow).Value & ".docx"
WordDoc.SaveAs FileName
End If
.Range("Z" & VSCRow).Value = TemplName 'Template Name to use
.Range("AA" & VSCRow).Value = Now
If .Range("S4").Value = "Email" Then
Set OutApp = CreateObject("Outlook.Application") 'Create Outlook
Application
Set OutMail = OutApp.CreateItem(0) 'Create The Email
With OutMail
.To = Sheet5.Range("Y" & VSCRow).Value
.Subject = "Performance Metrics Verification, " &
Sheet5.Range("R"
& VSCRow).Value & " - " & Sheet5.Range("S" & VSCRow).Value & ", "
& Sheet5.Range("T" & VSCRow).Value.Body = "Good afternoon, " &
Sheet5.Range("E" & VSCRow).Value & ",here are your " &
Sheet5.Range("R" & VSCRow).Value & " - " &
Sheet5.Range("S" & VSCRow).Value & ", " & Sheet5.Range("T" &
VSCRow).Value & " performance metrics as captured by the WFW
database systems. Please review and sign. Comments may be
included
in the email body. Please return to me by COB " &
Sheet5.Range("AG"
& VSCRow).Value & ", If this date falls on a holiday, return on
the
next business day following the holiday."
.Attachments.Add FileName
.Display 'To send without displaying .Display to .Send
End With
Else
WordDoc.PrintOut
WordDoc.Close
End If
Kill (FileName) 'Deletes the PDF or Word that was just
created
End If '3 conditions are met
Next VSCRow
WordApp.Quit
End With
End Sub
Attachment with %20 between name

user login form vb6 error

hi,
i write programme in vb6 and depend on ms access database
i create table in ms access (users)
then i make module :-
Public DB As New ADODB.Connection
Public RS As New ADODB.Recordset
Public RSS As New ADODB.Recordset
Public SQLS As String
Public UserNames As String
Public UserPassword As String
Sub POOLCONNECTION()
If DB.State = adStateOpen Then DB.Close
DB.Provider = "Microsoft.JET.OLEDB.4.0"
DB.Open App.Path & "\data.mdb"
End Sub
and i make some forms for user :-
1- i make check user form to create administrator user for the first time to use. if there are no records this form will create admin user
code:-
Private Sub Form_Load()
Text1 = " "
Text2 = " "
Text3 = " "
POOLCONNECTION
SQLS = " Select * From Users "
If RS.State = adStateOpen Then RS.Close
RS.Open SQLS, DB, adOpenKeyset, adLockPessimistic
If Not RS.RecordCount = 0 Then
FRMLOGIN.Show
Unload Me
End If
End Sub
Private Sub save_Click()
If Text1 = " " Then
MsgBox " Sorry, You Must Type Username ", vbCritical + vbMsgBoxRight, "Error"
Text1.SetFocus
Exit Sub
End If
If Text2 = " " Then
MsgBox " Please Type Old Password ", vbCritical + vbMsgBoxRight, " Error "
Text2.SetFocus
Exit Sub
End If
SaveMsg = MsgBox(" åá ÊÑíÏ ÇäÔÇÁ ãÏíÑ ááäÙÇã ?", vbQuestion + vbMsgBoxRight + vbYesNo, " Êã ÇáÍÝÙ ")
If SaveMsg = vbYes Then
RS.AddNew
RS![UserName] = Text1
RS![Password] = Text2
RS![GAdd] = True
RS![GEdit] = True
RS![GPrint] = True
RS![GCreateUser] = True
RS![GDelete] = True
RS.Update
MsgBox " Êã ÍÝÙ ÇáÈíÇäÇÊ", vbInformation + vbMsgBoxRight, " Saved "
' Save This Informations
UserNames = Text1
UserPassword = Text2
' Long Main
Set RS = Nothing
Set DB = Nothing
MDIForm1.Show
Unload Me
End If
End Sub
for the second time use after i have making adimn user login form show and i try to login with the admin user .. eof didn't read the records
login code :
Private Sub Command1_Click()
If Text1 = "" Or Text2 = "" Then
MsgBox " ÚÝæÇ íÌÈ ßÊÇÈÉ ÇÓã ÇáãÓÊÎÏã æßáãÉ ÇáãÑæÑ ", vbCritical + vbMsgBoxRight, " ÎØà Ýì ÇáÏÎæá"
Exit Sub
End If
SQLS = "Select * From Users Where Username = ' " & Text1 & " ' And Password = ' " & Text2 & " ' "
If RS.State = adStateOpen Then RS.Close
RS.Open SQLS, DB, adOpenKeyset, adLockPessimistic
If RS.EOF Then
MsgBox " Sorry, The Username And Password Is Wrong ! ", vbCritical + vbMsgBoxRight, " Error Login "
Else
Set RS = Nothing
Set DB = Nothing
MDIForm1.Show
Unload Me
End If
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
POOLCONNECTION
End Sub
Private Sub text1_keypress(keyAscii As Integer)
If keyAscii = 13 Then
Text2.SetFocus
End If
End Sub
Private Sub text2_keypress(keyAscii As Integer)
If keyAscii = 13 Then
Command1.SetFocus
End If
End Sub
Remove unnecessary spaces before and after texts:
SQLS = "Select * From Users Where Username = '" & Text1 & "' And Password = '" & Text2 & "' "

Duplicate error in current scope vb 6

Can someone help me. I'm trying to display an alert msgbox with two different recordset in one form so whenever there is an expired medicine it will both display and alert at the same time. But it gives me an error "Duplicate error in current scope"
In this line
Dim expirationdate As Date
Do While Not Adodc2.Recordset.EOF = True
'----------'
Private Sub Form_Activate()
Dim expirationdate As Date
Me.AutoRedraw = True
Adodc1.Recordset.MoveFirst
Do While Not Adodc1.Recordset.EOF = True
With Main
.Text4.Text = "" & Adodc1.Recordset.Fields("MedicineName")
.Text1.Text = Adodc1.Recordset.Fields("genericname")
.Text3.Text = Adodc1.Recordset.Fields("StockQuantity")
.Combo3.Text = Adodc1.Recordset.Fields("Expmonth")
.Combo4.Text = Adodc1.Recordset.Fields("Expday")
.Combo5.Text = Adodc1.Recordset.Fields("Expyear")
End With
expirationdate = CDate(Combo3 & "/" & Combo4 & "/" & Combo5)
datepicker.Value = Format(Now, "MMM-DD-yyyy")
If datepicker > expirationdate Then
MsgBox Text4.Text & " is Expired! ", vbExclamation, "Warning"
If MsgBox("Do you want to dispose " & Text4 & "?", vbQuestion + vbYesNo, "Message") = vbYes Then
Adodc1.Recordset.Delete
Else
Exit Sub
End If
End If
Adodc1.Recordset.MoveNext
Loop
'________________'
Dim expirationdate As Date
Me.AutoRedraw = True
Adodc2.Recordset.MoveFirst
Do While Not Adodc2.Recordset.EOF = True
With Main
.Text10 = Adodc2.Recordset.Fields("roomno")
.Text11 = "" & Adodc2.Recordset.Fields("MedicineName")
.Text2 = Adodc2.Recordset.Fields("GenericName")
.Text12.Text = Adodc2.Recordset.Fields("StockQuantity")
.Combo10 = Adodc2.Recordset.Fields("Expmonth")
.Combo11 = Adodc2.Recordset.Fields("Expday")
.Combo12 = Adodc2.Recordset.Fields("Expyear")
End With
expirationdate = CDate(Combo10 & "/" & Combo11 & "/" & Combo12)
datepicker2.Value = Format(Now, "MMM-DD-yyyy")
If datepicker2 < expirationdate Then
MsgBox "OK!", vbInformation, "Working"
Else
MsgBox "Medicine Expired!.", vbExclamation, " Warning!"
If MsgBox("Do you want to delete " & Text11 & "?", vbQuestion + vbYesNo, "Message") = vbYes Then
Adodc2.Recordset.Delete
Exit Sub
End If
End If
Adodc2.Recordset.MoveNext
Loop
End Sub
Try this. You are sometimes relying on the default properties of your controls. This is generally bad, so I added the properties. I also removed the Exit Sub line. If the user clicks No you don't want to exit the sub, you want to continue looping through the Adodc2 Recordset.
Me.AutoRedraw = True
Adodc2.Recordset.MoveFirst
Do While Not Adodc2.Recordset.EOF = True
With Main
.Text10.Text = Adodc2.Recordset.Fields("roomno")
.Text11.Text = "" & Adodc2.Recordset.Fields("MedicineName")
.Text2.Text = Adodc2.Recordset.Fields("GenericName")
.Text12.Text = Adodc2.Recordset.Fields("StockQuantity")
.Combo10.Text = Adodc2.Recordset.Fields("Expmonth")
.Combo11.Text = Adodc2.Recordset.Fields("Expday")
.Combo12.Text = Adodc2.Recordset.Fields("Expyear")
End With
expirationdate = CDate(Combo10.Text & "/" & Combo11.Text & "/" & Combo12.Text)
datepicker2.Value = Format(Now, "MMM-DD-yyyy")
If datepicker2.Value < expirationdate Then
MsgBox "OK!", vbInformation, "Working"
Else
MsgBox "Medicine Expired!.", vbExclamation, " Warning!"
If MsgBox("Do you want to delete " & Text11.Text & "?", vbQuestion + vbYesNo, "Message") = vbYes Then
Adodc2.Recordset.Delete
End If
End If
Adodc2.Recordset.MoveNext
Loop

Get AutoFilter sort criteria and apply on second sheet

I'm trying to see if I can programatically trap an AutoFilter sort event, get the sort criteria and then apply that same sort criteria to an AutoFilter in a second worksheet.
So far it seems as though I have to trigger the Worksheet_Calculate() event. And this I've done. Then I have to check if the AutoFilter sort criteria was changed. If it wasn't, exit sub. If it was, collect the criteria and run it through a separate sub, which does the exact same sorting on an AutoFilter in a separate worksheet.
The general idea is that whenever one of these two AutoFilters are sorted, the AutoFilter in the other sheet should be sorted the exact same way.
I've tried to do something like this (I had to add an Excel formula to actually make the calculate event trigger):
Private Sub Worksheet_Calculate()
Dim wbBook as Workbook
Dim wsSheet as Worksheet
Dim rnData as Range
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("Sheet1")
With wsSheet
Set dnData = .UsedRange
End With
End Sub
But I can't seem to manage to collect the criteria, I've tried several things and adding a watch to the dnData doesn't even reveal any AutoFilter property. Can someone shed any light on this?
Here is a way to get the autofilter criteria:
Sub test()
Dim Header As Range
Dim sMainCrit As String, sANDCrit As String, sORCrit As String
Set Header = Range("A2:C2")
With Header.Parent.AutoFilter
With .Filters(Header.Column - .Range.Column + 1)
If Not .On Then
MsgBox ("no criteria")
Exit Sub
End If
sMainCrit = .Criteria1
If .Operator = xlAnd Then
sANDCrit = .Criteria2
ElseIf .Operator = xlOr Then
sORCrit = .Criteria2
End If
End With
End With
MsgBox ("Main criteria: " & sMainCrit & Chr(13) & "AND Criteria:" & sANDCrit & Chr(13) & "OR Criteria" & sORCrit)
End Sub
Adapted from ozgrid
Here are some notes on what I see as your requirements.
Dim rv As AutoFilter ''Object
Set rv = Sheet1.AutoFilter
''Just for curiosity
Debug.Print rv.Sort.Header
Debug.Print rv.Sort.SortFields.Count
Debug.Print rv.Sort.SortFields.Item(1).SortOn
Debug.Print rv.Sort.Rng.Address
Debug.Print rv.Sort.SortFields.Item(1).Key.Address
''One key only, but it is easy enough to loop and add others
Sheet2.Range(rv.Sort.Rng.Address).Sort _
key1:=Sheet2.Columns(rv.Sort.SortFields(1).Key.Column), _
Header:=xlYes
Found this code:
Sub ShowAutoFilterCriteria()
' John Green et. al: Excel 2000 VBA Programmer?s Reference, S. 379f
' 09.01.2005
Dim oAF As AutoFilter
Dim oFlt As Filter
Dim sField As String
Dim sCrit1 As String
Dim sCrit2 As String
Dim sMsg As String
Dim i As Integer
' Check if the sheet is filtered at all
If ActiveSheet.AutoFilterMode = False Then
MsgBox "The sheet does not have an Autofilter"
Exit Sub
End If
' Get the sheet?s Autofilter object
Set oAF = ActiveSheet.AutoFilter
' Loop through the Filters of the Autofilter
For i = 1 To oAF.Filters.Count
' Get the field name form the first row
' of the Autofilter range
sField = oAF.Range.Cells(1, i).Value
' Get the Filter object
Set oFlt = oAF.Filters(i)
' If it is on...
If oFlt.On Then
' Get the standard filter criteria
sMsg = sMsg & vbCrLf & sField & oFlt.Criteria1
' If it?s a special filter, show it
Select Case oFlt.Operator
Case xlAnd
sMsg = sMsg & " And " & sField & oFlt.Criteria2
Case xlOr
sMsg = sMsg & " Or " & sField & oFlt.Criteria2
Case xlBottom10Items
sMsg = sMsg & " (bottom 10 items)"
Case xlBottom10Percent
sMsg = sMsg & " (bottom 10%)"
Case xlTop10Items
sMsg = sMsg & " (top 10 items)"
Case xlTop10Percent
sMsg = sMsg & " (top 10%)"
End Select
End If
Next i
If msg = "" Then
' No filters are applied, so say so
sMsg = "The range " & oAF.Range.Address & " is not filtered."
Else
' Filters are applied, so show them
sMsg = "The range " & oAF.Range.Address & " is filtered by:" & sMsg
End If
' Display the message
MsgBox sMsg
End Sub
Works fine on my tests! I've changed a small part of it to support complex criteria:
' Get the standard filter criteria
If IsArray(oFlt.Criteria1) Then
Dim x As Integer
sMsg = sMsg & vbCrLf & sField
For x = 1 To UBound(oFlt.Criteria1)
sMsg = sMsg & "'" & oFlt.Criteria1(x) & "'"
Next x
Else
sMsg = sMsg & vbCrLf & sField & "'" & oFlt.Criteria1 & "'"
End If
Original link: http://www.vbaexpress.com/forum/archive/index.php/t-7564.html

how to lock a system login after 3 failed attempts in vb6?

I already made security login that if failed 3 times the program will be terminated. However, I want to make a security login that will lock the system and the admin will be required to login instead.
Here's my code:
Dim nCnt As Integer
Dim nCnt2 As String
Private Sub cmdOk_Click()
nUsername = "username ='" & txtUsername.Text & "'"
npassword = txtPassword.Text
If nCnt < 2 Then
With adoLog.Recordset
.MoveFirst
.Find nUsername
If .EOF Then
MsgBox "Access Denied" & vbCrLf & "Please try again." & vbCrLf & vbCrLf & "Warning: You only have " & nCnt2 & " attempt.", vbCritical, "Terror"""
nCnt = nCnt + 1
nCnt2 = nCnt2 - 1
Label7.Caption = nCnt2
txtUsername.Text = ""
txtPassword.Text = ""
txtUsername.SetFocus
Else
If adoLog.Recordset.Fields("password").Value = npassword And adoLog.Recordset.Fields("flag").Value = 1 Then
Call Change_Flag
MsgBox "Access Granted"
cUser = adoLog.Recordset.Fields("name").Value
cPosition = adoLog.Recordset.Fields("position").Value
With adoHistory_Login.Recordset
.AddNew
.Fields("name").Value = cUser
.Fields("position").Value = cPosition
.Fields("time_login").Value = Time()
.Fields("date_login").Value = Date
.Fields("date_logout").Value = Date
.Update
Me.Refresh
frmMain.Show
frmMain.SetFocus
End With
Unload Me
txtUsername.Text = ""
txtPassword.Text = ""
Else
MsgBox "Access Denied" & vbCrLf & "Please try again." & vbCrLf & vbCrLf & "Warning: You only have " & nCnt2 & " attempt.", vbCritical, "Terror"""
nCnt = nCnt + 1
nCnt2 = nCnt2 - 1
Label7.Caption = nCnt2
txtUsername.Text = ""
txtPassword.Text = ""
txtUsername.SetFocus
End If
End If
End With
Else
Call block
End
End If
End Sub
Private Sub Change_Flag()
With adoLog.Recordset
.Fields("flag").Value = 0
End With
End Sub
Private Sub block()
MsgBox "You already used all attempt." & vbCrLf & "This will terminate the application.", vbCritical, "Terror"
End Sub
Private Sub Form_Initialize()
cmdOK.Enabled = False
txtPassword.Enabled = False
cmdRegister.Visible = False
If adoLog.Recordset.RecordCount <> 0 Then
cmdOK.Enabled = False
txtPassword.Enabled = False
txtUsername.Enabled = True
Else
cmdRegister.Visible = True
txtUsername.Enabled = False
End If
End Sub
Private Sub Form_Load()
nCnt2 = 2
Label7.Caption = nCnt2
End Sub
You will need to store an additional flag somewhere to indicate that login is denied and then check this flag before attempting the login. You will also need to store the account type and check to see if the account is allowed to log in even if this flag is set.
Are you wanting to lock out the full PC or the username that is being used?
Add a new column to the recordset for IsLocked and have it get set to true after the 3 logins (Make sure you provide some way for the admin to clear it back out though).
As soon as the username is used check IsLocked first before the password and kick it out immediately with the appropriate message.
Also, make sure you prevent the IsLocked from ever being set on the admin username.

Resources