Posts by xiaowang

Private Sub SubmitButton1_Click()

    If TextBox1.Text = "" Then
    Cancel = 1
    MsgBox "Please fill in the necessary"
    TextBox1.SetFocus
    Exit Sub
    End If
    If TextBox3.Text = "" Then
    Cancel = 1
    MsgBox "Please fill in the necessary"
    TextBox3.SetFocus
    Exit Sub
    End If
    If DTPicker1.Value = "" Then
    Cancel = 1
    MsgBox "Please fill in the necessary"
    DTPicker1.SetFocus
    Exit Sub
    End If
    If TextBox2.Text = "" Then
    Cancel = 1
    MsgBox "Please fill in the necessary"
    TextBox2.SetFocus
    Exit Sub
    End If
    If scanitemtextbox1.Text = "" Then
    Cancel = 1
    MsgBox "Please fill in the necessary"
    scanitemtextbox1.SetFocus
    Exit Sub
    End If
Worksheets("Equipment_Database").Activate
Range("T1").Value = scanitemtextbox1.Text 'user scans a barcode and outputs words into T1
Range("T2").Value = WorksheetFunction.Match(Range("T1").Value, Range("A:A"), 0) 'matches T1
Set random = Cells((Range("T2").Value), 1) 
Range("T3").Value = random.Address(RowAbsolute:=False) 'finds the address of T2
If Range(Range("T3").Value).Offset(0, 7).Value = 0 Then
MsgBox "Unable to withdraw due to insufficient equiupment/item is not registered "
Unload Me
Mainpage.Show
Else
Worksheets("Equipment_Database").Range(Range("T3").Value).Offset(, 3).Value = "No"
Worksheets("Equipment_Database").Range(Range("T3").Value).Offset(, 4).Value = Range(Range("T3").Value).Offset(, 4).Value + 1
Worksheets("Equipment_Database").Range(Range("T3").Value).Offset(, 7).Value = Range(Range("T3").Value).Offset(, 7).Value - 1

Worksheets("Withdrawal_data").Activate
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 'Check for empty rows and sets sheet 2 as the relevant sheet to output to'
Cells(erow, 1) = TextBox1.Text 'output to whatever cell thats empty in column 1'
Cells(erow, 2) = TextBox3.Text 'output to whatever cell thats empty in column 2'
Cells(erow, 3) = DTPicker1.Value 'output to whatever cell thats empty in column 3'
Cells(erow, 4) = TextBox2.Text 'output to whatever cell thats empty in column 4'
Cells(erow, 6) = scanitemtextbox1.Text 'output to whatever cell thats empty in column 6'
Unload Me
Mainpage.Show

End Sub

Sub eMail()
Dim lRow As Integer
Dim i As Integer
Dim toDate As Date
Dim toList As String
Dim eSubject As String
Dim eBody As String
Dim Sheets As Worksheet
Dim OutApp, OutMail As Object


With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With




lRow = Cells(rows.Count, 6).End(xlUp).Row


For i = 2 To lRow
  If (Cells(i, 1)) <> "" And CDate(Cells(i, 3)) - Date <= 7 And CDate(Cells(i, 3)) - Date > 0 And Cells(i, 7) = "" Then '<--------------------------------------------- change this range
     Set OutApp = CreateObject("Outlook.Application")
     Set OutMail = OutApp.CreateItem(0)

        toList = Cells(i, 4)    'gets the recipient from col D
        eSubject = "Reminder to return tools on " & Cells(i, 3)
        
        eBody = "Hello " & Cells(i, 1) & "," & vbNewLine & vbNewLine & _
            "Do remember to return " & Cells(i, 6) & vbNewLine & vbNewLine & _
            "Sincerely, " & vbNewLine & _
            "Admin"


        On Error Resume Next
        With OutMail
        .To = toList
        .CC = ""
        .BCC = ""
        .Subject = eSubject
        .Body = eBody
        
        .Display   ' ********* Creates draft emails. Comment this out when you are ready
        '.Send     '********** UN-comment this when you  are ready to go live
        
        End With
 
 
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
 Cells(i, 7) = "Mail Sent " & Date + Time 'Marks the row as "email sent in Column A"
End If
Next i


ActiveWorkbook.Save


With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With
End Sub

Option Explicit

Sub Check_ID()
' Updated Version Dec 29, 2019
    Dim ID, res
    Dim i As Integer, rowls As Integer
    
    ID = Range("H1").Value
    rowls = Sheet1.Cells(rows.Count, 2).End(xlUp).Row
    
    res = Application.Match(ID, Sheet1.Range("A1:A" & rowls), 0)
    
    If Not IsError(res) Then
        Range("H2") = Cells(res, 2)
        Range("H3") = Cells(res, 3)
        Range("H4") = Cells(res, 4)
        MsgBox " Data has been updated ... "
    Else
        MsgBox "You do need to be registered beforehand "
    End If
    
End Sub

Option Explicit

Sub check_id()
    On Error GoTo ErrorHandler
    Dim name As String
    Dim i As Integer
    Dim rowls As Integer
    Dim Department As String
    Dim eMail As String

    ID = Range("H1")
    name = Range("H2")
    eMail = Range("H3")
    Department = Range("H4")

    name = Application.WorksheetFunction.VLookup(ID, Sheet1.Range("A2:D1002"), 2, False)
    eMail = Application.WorksheetFunction.VLookup(ID, Sheet1.Range("A2:D1002"), 3, False)
    Department = Application.WorksheetFunction.VLookup(ID, Sheet1.Range("A2:D1002"), 4, False)
    rowls = Cells(Rows.Count, 2).End(x1up).Row

    For i = 1 To rowls

        If Application.WorksheetFunction.VLookup(ID, Range("A2:D1001"), 2, False) = Cells(i, 2) Then
            MsgBox "You have been registered beforehand "
        Else
            MsgBox "Not Ok"    ' Never invoked
        End If
    Next i
    Exit Sub

ErrorHandler:
    Response = MsgBox("You have not registered an account yet please approach the administrator.", vbOKOnly, "Unknown user")

    If Response = vbOK Then

        Mainpage.Show
    ElseIf Response = vbCancel Then
        Mainpage.Show

    End If
End Sub