Excel Generate reports

T

thoma

New Member
Joined
May 19, 2016
Messages
1
Rich (BB code): 
Option Explicit
Public ans As String
Private Declare Function FindWindow Lib "User32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetWindowLong Lib "User32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "User32" _
Alias "SetWindowLongA" (ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
Private Declare Function DrawMenuBar Lib "User32" ( _
ByVal hwnd As Long) As Long
 
Public conn As ADODB.Connection
Public mytablers As ADODB.Recordset
Public cnpath As String
Public i As Integer, q As String, modmax As Integer, planmax As Integer
Public pwd As String
Public lvl2 As Integer
 
 
Sub allborders(sel As Range)
With sel.Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
End With
End Sub
Sub headerformat(sel As Range)
sel.Interior.Color = RGB(239, 109, 59)
End Sub
Sub selectentirerow(sel As Range)
Range(sel, sel.End(xlToRight)).Select
End Sub
Sub addwh()
UserForm1.show
End Sub
Sub addtrain()
UserForm2.show
End Sub
Sub addmodule()
UserForm3.show
End Sub
Sub addplan()
UserForm4.show
End Sub
 
Sub RemoveCaption(objForm As Object)
         Dim lStyle          As Long
    Dim hMenu           As Long
    Dim mhWndForm       As Long
         If Val(Application.Version) < 9 Then
        mhWndForm = FindWindow("ThunderXFrame", objForm.Caption) 'XL97
    Else
        mhWndForm = FindWindow("ThunderDFrame", objForm.Caption) 'XL2000+
    End If
    lStyle = GetWindowLong(mhWndForm, -16)
    lStyle = lStyle And Not &HC00000
    SetWindowLong mhWndForm, -16, lStyle
    DrawMenuBar mhWndForm
   End Sub
Sub showshapes(lvl As Integer)
Dim sh As Shape
Select Case lvl
Case Is = 1
    For Each sh In ActiveSheet.Shapes
        sh.Visible = True
    Next sh
Case Is = 2
    ActiveSheet.Shapes("Rounded Rectangle 1").Visible = False
    ActiveSheet.Shapes("Rounded Rectangle 3").Visible = False
    ActiveSheet.Shapes("Rounded Rectangle 6").Visible = False
    ActiveSheet.Shapes("Rounded Rectangle 5").Visible = False
    ActiveSheet.Shapes("Rounded Rectangle 7").Visible = False
    ActiveSheet.Shapes("Rounded Rectangle 10").Visible = False
    ActiveSheet.Shapes("Rounded Rectangle 9").Visible = False
End Select
   
   
   
End Sub
Sub assignplan()
UserForm6.show
End Sub
 
End sub1
Sub showtrainees()
pwd = "Thomas"
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "Trainee", conn, adOpenDynamic, adLockPessimistic
Range("a13").CopyFromRecordset mytablers
For i = 1 To mytablers.Fields.Count
    Cells(12, i) = mytablers.Fields(i - 1).Name
Next i
Rows(12).Font.Bold = True
Cells.EntireColumn.AutoFit
Call GblModule.selectentirerow(Range("a12"))
Call GblModule.headerformat(Selection)
Call GblModule.allborders(Range("a12").CurrentRegion)
Range("A13").Select
ActiveWindow.FreezePanes = True
mytablers.Close
Set conn = Nothing
End Sub
Sub showWarehouse()
pwd = "Thomas"
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
 
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "Warehouse", conn, adOpenDynamic, adLockPessimistic
Range("a13").CopyFromRecordset mytablers
For i = 1 To mytablers.Fields.Count
    Cells(12, i) = mytablers.Fields(i - 1).Name
Next i
Rows(12).Font.Bold = True
Cells.EntireColumn.AutoFit
Call GblModule.selectentirerow(Range("a12"))
Call GblModule.headerformat(Selection)
Call GblModule.allborders(Range("a12").CurrentRegion)
Range("A13").Select
ActiveWindow.FreezePanes = True
mytablers.Close
Set conn = Nothing
End Sub
Sub showModules()
pwd = "Thomas"
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "Modules", conn, adOpenDynamic, adLockPessimistic
Range("a13").CopyFromRecordset mytablers
For i = 1 To mytablers.Fields.Count
    Cells(12, i) = mytablers.Fields(i - 1).Name
Next i
Rows(12).Font.Bold = True
Cells.EntireColumn.AutoFit
Call GblModule.selectentirerow(Range("a12"))
Call GblModule.headerformat(Selection)
Call GblModule.allborders(Range("a12").CurrentRegion)
Range("A13").Select
ActiveWindow.FreezePanes = True
Columns(3).ColumnWidth = 30
mytablers.Close
Set conn = Nothing
End Sub
 
Sub showPlans()
pwd = "Thomas"
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
q = "SELECT Plans.PlanID, Plans.PlanName, Plans.PlanDescription, Plans.PlanCreator, Plans.PlanCreationDate, Modules.ModuleID, Modules.ModuleName, Modules.ModuleDescription FROM (PlanModule INNER JOIN Plans ON PlanModule.PlanModuleID = Plans.PlanModuleID) INNER JOIN Modules ON PlanModule.ModuleID = Modules.ModuleID;"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
Range("a13").CopyFromRecordset mytablers
For i = 1 To mytablers.Fields.Count
    Cells(12, i) = mytablers.Fields(i - 1).Name
Next i
Rows(12).Font.Bold = True
Cells.EntireColumn.AutoFit
Call GblModule.selectentirerow(Range("a12"))
Call GblModule.headerformat(Selection)
Call GblModule.allborders(Range("a12").CurrentRegion)
Range("A13").Select
ActiveWindow.FreezePanes = True
Columns(3).ColumnWidth = 20
Columns(8).ColumnWidth = 30
mytablers.Close
Set conn = Nothing
End Sub
End sub2
Option Explicit
Sub editTrainee()
On Error GoTo Errdef
If Range("a12").Value <> "EmpID" Then
    MsgBox "Please check the command you wish to execute", vbOKOnly, "TraineeSystem"
    Exit Sub
End If
If ActiveCell.Row <= 12 Or ActiveCell.Value = "" Or ActiveCell.Column > 1 Then
    MsgBox "Please select employee ID make changes", vbOKOnly, "TraineeSystem"
    Exit Sub
End If
Dim emp As Long, j As Integer
emp = ActiveCell.Value
 
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
mytablers.Open "Trainee", conn, adOpenDynamic, adLockPessimistic
mytablers.MoveFirst
j = ActiveCell.Row
'mytablers.Find "Emp=" & ActiveCell.Value
mytablers.Find "EmpID=" & emp
For i = 1 To 6
    mytablers.Fields(i).Value = Cells(j, i + 1)
Next i
mytablers.Update
mytablers.Close
Set conn = Nothing
MsgBox "Record Successfully Updated!", vbOKOnly, "TraineeSystem"
Exit Sub
 
Errdef:
MsgBox "Transactional error, please contact Admin", vbOKOnly, "TraineeSystem"
End Sub
Sub editWarehouse()
On Error GoTo Errdef
If Range("a12").Value <> "WHCode" Then
    MsgBox "Please check the command you wish to execute", vbOKOnly, "TraineeSystem"
    Exit Sub
End If
If ActiveCell.Row <= 12 Or ActiveCell.Value = "" Or ActiveCell.Column > 1 Then
    MsgBox "Please select Warehouse Code to make changes", vbOKOnly, "TraineeSystem"
    Exit Sub
End If
Dim wh As Long, j As Integer
wh = ActiveCell.Value
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
mytablers.Open "Warehouse", conn, adOpenDynamic, adLockPessimistic
mytablers.MoveFirst
j = ActiveCell.Row
mytablers.Find "WHCode=" & wh
For i = 1 To 2
    mytablers.Fields(i).Value = Cells(j, i + 1)
Next i
mytablers.Update
mytablers.Close
Set conn = Nothing
MsgBox "Record Successfully Updated!", vbOKOnly, "TraineeSystem"
Exit Sub
 
Errdef:
MsgBox "Transactional error, please contact Admin", vbOKOnly, "TraineeSystem"
End Sub
Sub editModule()
On Error GoTo Errdef
If Range("a12").Value <> "ModuleID" Then
    MsgBox "Please check the command you wish to execute", vbOKOnly, "TraineeSystem"
    Exit Sub
End If
If ActiveCell.Row <= 12 Or ActiveCell.Value = "" Or ActiveCell.Column > 1 Then
    MsgBox "Please select Module Name to make changes", vbOKOnly, "TraineeSystem"
    Exit Sub
End If
Dim ml As Integer, j As Integer
ml = ActiveCell.Value
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
mytablers.Open "Modules", conn, adOpenDynamic, adLockPessimistic
mytablers.MoveFirst
j = ActiveCell.Row
mytablers.Find "ModuleId=" & ml
For i = 2 To 5
    mytablers.Fields(i).Value = Cells(j, i + 1)
Next i
mytablers.Update
mytablers.Close
Set conn = Nothing
MsgBox "Record Successfully Updated!", vbOKOnly, "TraineeSystem"
Exit Sub
 
Errdef:
MsgBox "Transactional error, please contact Admin", vbOKOnly, "TraineeSystem"
End Sub
For 1
Rich (BB code): 
Option Explicit
 
Private Sub CommandButton1_Click()
On Error GoTo BtnError
If Me.TextBox1.Value = "" Or Me.TextBox2.Value = "" Or Me.TextBox3.Value = "" Then
    MsgBox "Fields cant be left blank", vbOKOnly, "TraineeSystem"
    Me.TextBox1.SetFocus
    Exit Sub
End If
 
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "Warehouse", conn, adOpenDynamic, adLockPessimistic
mytablers.AddNew
mytablers.Fields(0) = Me.TextBox1.Value
mytablers.Fields(1) = Me.TextBox2.Value
mytablers.Fields(2) = Me.TextBox3.Value
mytablers.Update
mytablers.Close
Set conn = Nothing
MsgBox "Warehouse Successfully Added", vbOKOnly, "TraineeSystem"
ans = MsgBox("Refresh the warehouse list!", vbYesNo, "TraineeSystem")
If ans = vbYes Then
    Call Module1.showWarehouse
End If
Unload Me
Exit Sub
 
BtnError:
If Err.Number = -2147217887 Then
    MsgBox "The WH Code already exists", vbOKOnly, "TraineeSystem"
    Unload Me
Else
    MsgBox "Critical error, please contact admin", vbOKOnly, "TraineeSystem"
    Unload Me
End If
 
End Sub
 
Private Sub CommandButton2_Click()
Me.TextBox1.Value = ""
Me.TextBox2.Value = ""
Me.TextBox3.Value = ""
End Sub
 
Private Sub CommandButton3_Click()
Unload Me
End Sub
 
Private Sub UserForm_Initialize()
Call RemoveCaption(Me)
 
Me.Label1.Caption = Format(VBA.Date, "dd-mmm-yyyy")
End Sub
For 2

Rich (BB code): 
Option Explicit
 
Private Sub CommandButton1_Click()
On Error GoTo BtnError
If Me.TextBox1.Value = "" Or Me.TextBox2.Value = "" Or Me.TextBox3.Value = "" Or Me.TextBox4.Value = "" Or Me.ComboBox1.Value = "" Then
    MsgBox "Mandatory Fields cant be left blank", vbOKOnly, "TraineeSystem"
    Me.TextBox1.SetFocus
    Exit Sub
End If
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "Trainee", conn, adOpenDynamic, adLockPessimistic
mytablers.AddNew
mytablers.Fields(0) = Me.TextBox1.Value
mytablers.Fields(1) = Me.TextBox2.Value
mytablers.Fields(2) = Me.TextBox3.Value
mytablers.Fields(3) = Me.ComboBox1.Value
mytablers.Fields(4) = Me.TextBox4.Value
mytablers.Fields(5) = Me.ComboBox2.Value
mytablers.Fields(6) = Me.ComboBox3.Value
mytablers.Fields(8) = "Free"
mytablers.Update
mytablers.Close
Set conn = Nothing
MsgBox "Trainee Successfully Added", vbOKOnly, "TraineeSystem"
ans = MsgBox("Refresh the trainee list!", vbYesNo, "TraineeSystem")
If ans = vbYes Then
    Call Module1.showtrainees
End If
Unload Me
Exit Sub
 
BtnError:
If Err.Number = -2147217887 Then
    MsgBox "The trainee already exists", vbOKOnly, "TraineeSystem"
    Unload Me
Else
    MsgBox "Critical error, please contact admin", vbOKOnly, "TraineeSystem"
    Unload Me
End If
End Sub
 
Private Sub CommandButton2_Click()
'Me.TextBox1.Value = ""
'Me.TextBox2.Value = ""
'Me.TextBox3.Value = ""
Application.ScreenUpdating = False
Unload Me
UserForm2.show
End Sub
 
Private Sub CommandButton3_Click()
Unload Me
End Sub
 
Private Sub UserForm_Initialize()
Call RemoveCaption(Me)
Me.Label1.Caption = Format(VBA.Date, "dd-mmm-yyyy")
With Me.ComboBox1
    .Clear
    .AddItem "Select Operative"
    .AddItem "Transport Operative"
    .AddItem "Goods-in Operative"
End With
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
mytablers.Open "Warehouse", conn, adOpenDynamic, adLockPessimistic
i = 0
Me.ComboBox2.Clear
Me.ComboBox3.Clear
Do While Not mytablers.EOF
    Me.ComboBox2.AddItem mytablers.Fields(0).Value
    Me.ComboBox3.AddItem mytablers.Fields(0).Value
    mytablers.MoveNext
Loop
End Sub
For 3



Rich (BB code): 
Option Explicit
 
Private Sub CommandButton1_Click()
'mODULE IDS START FROM 700 DEFAULT
On Error GoTo BtnError
If Me.TextBox1.Value = "" Or Me.TextBox3.Value = "" Or Me.TextBox4.Value = "" Or Me.TextBox5.Value = "" Then
    MsgBox "Mandatory Fields cant be left blank", vbOKOnly, "TraineeSystem"
    Me.TextBox1.SetFocus
    Exit Sub
End If
If InStr(1, TextBox1.Value, " ", vbTextCompare) <> 0 Then
    MsgBox "Module name cant have spaces!", vbOKOnly, "TraineeSystem"
    Me.TextBox1.SetFocus
    Exit Sub
End If
 
'Get maxmoduleID from Modules
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
q = "select max(ModuleID) from modules;"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
modmax = mytablers.Fields(0)
mytablers.Close
Set conn = Nothing
'******
 
 
'Add new module to Modules
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "Modules", conn, adOpenDynamic, adLockPessimistic
mytablers.AddNew
mytablers.Fields(0) = modmax + 1
mytablers.Fields(1) = Me.TextBox1.Value
mytablers.Fields(2) = Me.TextBox2.Value
mytablers.Fields(3) = Me.TextBox3.Value
mytablers.Fields(4) = Me.TextBox4.Value
mytablers.Fields(5) = Me.TextBox5.Value
mytablers.Fields(6) = VBA.Date
mytablers.Fields(7) = Application.UserName
mytablers.Update
mytablers.Close
Set conn = Nothing
MsgBox "Module Successfully Added", vbOKOnly, "TraineeSystem"
ans = MsgBox("Refresh the Module list!", vbYesNo, "TraineeSystem")
If ans = vbYes Then
    Call Module1.showModules
End If
Unload Me
Exit Sub
 
BtnError:
If Err.Number = -2147217887 Then
    MsgBox "The Module already exists", vbOKOnly, "TraineeSystem"
    Unload Me
Else
    MsgBox "Critical error, please contact admin", vbOKOnly, "TraineeSystem"
    Unload Me
End If
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Unload Me
UserForm3.show
End Sub
 
Private Sub CommandButton3_Click()
Unload Me
End Sub
 
Private Sub UserForm_Initialize()
Call RemoveCaption(Me)
Me.Label1.Caption = Format(VBA.Date, "dd-mmm-yyyy")
End Sub
For 4
Rich (BB code): 
Option Explicit
 
Private Sub CommandButton1_Click()
'Planmodule IDS START FROM 1500 DEFAULT
'PlanIDs start from 2000 default
On Error GoTo BtnError
If Me.TextBox1.Value = "" Then
    MsgBox "Mandatory Fields cant be left blank", vbOKOnly, "TraineeSystem"
    Me.TextBox1.SetFocus
    Exit Sub
End If
'check if atleast 1 module is selected
If Me.ListBox2.ListCount < 0 Then
    MsgBox "Please select atleast one module"
    Me.TextBox1.SetFocus
    Exit Sub
End If
 
'Get maxmoduleID from PlanModules and maxplanid from plan
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
q = "select max(PlanModuleID) from PlanModule;"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
modmax = mytablers.Fields(0)
mytablers.Close
q = "select max(PlanID) from Plans;"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
planmax = mytablers.Fields(0)
mytablers.Close
Set conn = Nothing
'******
 
 
'Add records to PlanModules
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "PlanModule", conn, adOpenDynamic, adLockPessimistic
For i = 0 To ListBox2.ListCount - 1
mytablers.AddNew
mytablers.Fields(0) = modmax + 1
mytablers.Fields(1) = Me.ListBox2.List(i)
Next i
mytablers.Update
mytablers.Close
Set conn = Nothing
 
'add new record to Plan
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
mytablers.Open "Plans", conn, adOpenDynamic, adLockPessimistic
mytablers.AddNew
mytablers.Fields(0) = planmax + 1
mytablers.Fields(1) = Me.TextBox1.Value
mytablers.Fields(2) = Me.TextBox2.Value
mytablers.Fields(3) = modmax + 1
mytablers.Fields(4) = Application.UserName
mytablers.Fields(5) = VBA.Date
mytablers.Update
mytablers.Close
Set conn = Nothing
 
 
MsgBox "Plan Successfully Added", vbOKOnly, "TraineeSystem"
ans = MsgBox("Refresh the Plan list!", vbYesNo, "TraineeSystem")
If ans = vbYes Then
    Call Module1.showPlans
End If
Unload Me
Exit Sub
 
BtnError:
If Err.Number = -2147217887 Then
    MsgBox "The Module already exists", vbOKOnly, "TraineeSystem"
    Unload Me
Else
    MsgBox "Critical error, please contact admin", vbOKOnly, "TraineeSystem"
    Unload Me
End If
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Unload Me
UserForm4.show
End Sub
 
Private Sub CommandButton3_Click()
Unload Me
End Sub
 
Private Sub CommandButton4_Click()
Me.ListBox2.Clear
For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then Me.ListBox2.AddItem Me.ListBox1.List(i)
Next i
End Sub
 
Private Sub CommandButton5_Click()
For i = 0 To Me.ListBox2.ListCount - 1
    If Me.ListBox2.Selected(i) = True Then Me.ListBox2.RemoveItem (i)
Next i
End Sub
 
 
Private Sub UserForm_Initialize()
Call RemoveCaption(Me)
Me.Label1.Caption = Format(VBA.Date, "dd-mmm-yyyy")
 
'fill list box
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
q = "SELECT modules.moduleID FROM Modules ORDER BY modules.moduleID DESC;"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
With Me.ListBox1
.Clear
Do While Not mytablers.EOF
    .AddItem mytablers.Fields(0)
    mytablers.MoveNext
Loop
End With
mytablers.Close
Set conn = Nothing
End Sub
For 5
Rich (BB code): 
Option Explicit
 
Private Sub CommandButton1_Click()
pwd = "Thomas"
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
ThisWorkbook.Sheets("Reports").Range("A12:DA1048576").Clear
q = "select Accesslevel from Users where UserName='" & Me.TextBox1.Value & "' and Pword='" & Me.TextBox2.Value & "';"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
If mytablers.EOF Then
    MsgBox "Invalid Login"
Else
    MsgBox "Welcome " & Me.TextBox1.Value
    lvl2 = mytablers.Fields(0).Value
    Sheets("Reports").Visible = True
    Sheets("Welcome").Visible = False
    ThisWorkbook.Sheets("Reports").Range("c2").Value = Me.TextBox1.Value
    ThisWorkbook.Sheets("Reports").Select
End If
mytablers.Close
conn.Close
Set conn = Nothing
Call GblModule.showshapes(lvl2)
Unload Me
End Sub
Private Sub CommandButton2_Click()
Unload Me
End Sub
 
 
 
Private Sub Label2_Click()
 
End Sub
 
Private Sub UserForm_Click()
 
End Sub
For 6
Rich (BB code): 
Option Explicit
 
Private Sub CommandButton1_Click()
On Error GoTo BtnError
If Me.TextBox1.Value = "" Or Me.TextBox2.Value = "" Or Me.ComboBox1.Value = "" Then
    MsgBox "Mandatory Fields cant be left blank", vbOKOnly, "TraineeSystem"
    Me.TextBox1.SetFocus
    Exit Sub
End If
'check if atleast 1 employee is selected
If Me.ListBox2.ListCount < 0 Then
    MsgBox "Please select atleast one Employee"
    Me.TextBox1.SetFocus
    Exit Sub
End If
 
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
mytablers.Open "Trainee", conn, adOpenDynamic, adLockPessimistic
For i = 0 To Me.ListBox2.ListCount - 1
        mytablers.Find "EmpID=" & VBA.Left(Me.ListBox2.List(0), 6) & " "
        If Not mytablers.EOF Then
            mytablers.Fields(7).Value = VBA.Left(Me.ComboBox1.Value, 4)
            mytablers.Fields(8).Value = "Plan Assigned"
            mytablers.Fields(9).Value = Me.TextBox1.Value
            mytablers.Fields(10).Value = Me.TextBox2.Value
        End If
Next i
mytablers.Update
mytablers.Close
conn.Close
Set conn = Nothing
'******
 
 
 
 
MsgBox "Plan Successfully Assigned", vbOKOnly, "TraineeSystem"
ans = MsgBox("Refresh the Trainee list!", vbYesNo, "TraineeSystem")
If ans = vbYes Then
    Call Module1.showtrainees
End If
Unload Me
Exit Sub
 
BtnError:
If Err.Number = -2147217887 Then
    MsgBox "The Module already exists", vbOKOnly, "TraineeSystem"
    Unload Me
Else
    MsgBox "Critical error, please contact admin", vbOKOnly, "TraineeSystem"
    Unload Me
End If
End Sub
Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
Unload Me
UserForm6.show
End Sub
 
Private Sub CommandButton3_Click()
Unload Me
End Sub
 
Private Sub CommandButton4_Click()
Me.ListBox2.Clear
For i = 0 To Me.ListBox1.ListCount - 1
    If Me.ListBox1.Selected(i) = True Then Me.ListBox2.AddItem Me.ListBox1.List(i)
Next i
End Sub
 
Private Sub CommandButton5_Click()
For i = 0 To Me.ListBox2.ListCount - 1
    If Me.ListBox2.Selected(i) = True Then Me.ListBox2.RemoveItem (i)
Next i
End Sub
Private Sub SpinButton1_SpinDown()
Me.TextBox1.Value = Format(CDate(Me.TextBox1.Value) - CDate(SpinButton1.SmallChange), "dd-mmm-yyyy")
End Sub
 
Private Sub SpinButton1_SpinUp()
Me.TextBox1.Value = Format(CDate(Me.TextBox1.Value) + CDate(SpinButton1.SmallChange), "dd-mmm-yyyy")
End Sub
 
 
Private Sub SpinButton2_SpinDown()
Me.TextBox2.Value = Format(CDate(Me.TextBox2.Value) - CDate(SpinButton1.SmallChange), "dd-mmm-yyyy")
 
End Sub
 
Private Sub SpinButton2_SpinUp()
Me.TextBox2.Value = Format(CDate(Me.TextBox2.Value) + CDate(SpinButton1.SmallChange), "dd-mmm-yyyy")
 
End Sub
 
Private Sub UserForm_Initialize()
Call RemoveCaption(Me)
Me.Label1.Caption = Format(VBA.Date, "dd-mmm-yyyy")
 
'FILL PLann box
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
q = "SELECT PlanID,PlanName from Plans ORDER BY PlanID DESC;"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
With Me.ComboBox1
.Clear
Do While Not mytablers.EOF
    .AddItem mytablers.Fields(0) & "-" & mytablers.Fields(1)
    mytablers.MoveNext
Loop
End With
mytablers.Close
Set conn = Nothing
 
'fill dates
Me.TextBox1.Value = Format(VBA.Date, "dd-mmm-yyyy")
Me.TextBox2.Value = Format(VBA.Date, "dd-mmm-yyyy")
 
'fill list box
Set conn = New ADODB.Connection
Set mytablers = New ADODB.Recordset
conn.Provider = "Microsoft.ace.oledb.12.0"
pwd = "Thomas"
conn.Properties("jet OLEDB:Database Password") = pwd
cnpath = ThisWorkbook.Sheets("Reports").Range("j2").Value
conn.Open cnpath
q = "SELECT Trainee.EmpID, Trainee.First_Name, Trainee.Last_Name FROM Trainee WHERE (((Trainee.CurrentStatus)='Free')) ORDER BY Trainee.EmpID DESC;"
mytablers.Open q, conn, adOpenDynamic, adLockPessimistic
With Me.ListBox1
.Clear
Do While Not mytablers.EOF
    .AddItem mytablers.Fields(0) & "-" & mytablers.Fields(1) & " " & mytablers.Fields(2)
    mytablers.MoveNext
Loop
End With
mytablers.Close
Set conn = Nothing
End Sub
 
Last edited by a moderator:

Excel Facts

Can Excel fill bagel flavors?
You can teach Excel a new custom list. Type the list in cells, File, Options, Advanced, Edit Custom Lists, Import, OK
Sort by date Sort by votes
Welcome to the forum.

What is your actual question?
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Adodb Method 'Open' of object '_Recordset' failed
Replies
4
Views
1K
Micron
M
T
  • Question Question
Using SQL to extract results
Replies
2
Views
252
tiredofit
T
G
  • Question Question
VB Issue pulling data with date specific
Replies
4
Views
369
Trevor G
Trevor G
K
  • Question Question
Help Needed
2
Replies
13
Views
291
kwavic
K
M
  • Question Question
What am I doing Wrong?
Replies
6
Views
244
MBarrett
M

Forum statistics

Threads
1,223,275
Messages
6,171,119
Members
452,381
Latest member
Nova88

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top