Below is my code help me see got what error that make it got run time error . when debug it show AppExcel.ActiveWorkbook.Save.
Private Sub cmdPrint_Click()
Dim sql As String
Dim sql1 As String
Dim rs As adodb.Recordset
If Trim(Combo1.Text) = "ALL" Then
sql = sql1 & " "
ElseIf Trim(Combo1.Text) = "MGMT" Then
sql1 = sql1 & " and b.staff_joblevel = 'MGMT' "
ElseIf Trim(Combo1.Text) = "EXEC" Then
sql1 = sql1 & " and b.staff_joblevel = 'EXEC' "
ElseIf Trim(Combo1.Text) = "NEXE" Then
sql1 = sql1 & " and b.staff_joblevel = 'NEXE' "
ElseIf Trim(Combo1.Text) = "OPER" Then
sql1 = sql1 & " and b.staff_joblevel = 'OPER' "
End If
If Trim(Combo2.Text) = "ALL" Then
SQL2 = " "
ElseIf Trim(Combo2.Text) = "1" Then
SQL2 = " and recycle_badge = 1 "
ElseIf Trim(Combo2.Text) = "0" Then
SQL2 = " and recycle_badge = 0 "
End If
sql = "select a.returned_id, a.date_insert, b.staff_no, b.staff_name, b.staff_joblevel, (b.staff_branch+b.staff_division+b.staff_dept+b.staff_section) as costblock, b.staff_group, c.sec_shortname " _
& "from staff_badgeReturn as a " _
& "join staff as b on (b.staff_no = a.staff_no) " _
& "join section as c on (c.sec_compcode = b.staff_comp and c.sec_brchcode = b.staff_branch and c.sec_divcode = b.staff_division and c.sec_deptcode = b.staff_dept and c.sec_code = b.staff_section) " _
& "where date_insert >= '" & dtpick4 & "' " _
& "and date_insert <= '" & dtpick5 & "' " & sql1 & SQL2
Set rs = New adodb.Recordset
With rs
.ActiveConnection = cnUnisemsql
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open sql
End With
FileName = "BadgeReturn.xls"
Dim row As Integer
row = 4
If rs.RecordCount > 0 Then
If OpenExcel(FileName) Then
Set wSheet = AppExcel.Sheets(1)
AppExcel.Sheets(1).Name = "BadgeReturn"
With wSheet
ProgressBar.Visible = True
ProgressBar.Max = rs.RecordCount
ProgressBar.Value = 0
Do Until rs.EOF
.Cells(row, 1) = rs!Staff_no
.Cells(row, 2) = rs!staff_Name
.Cells(row, 3) = rs!CostBlock
.Cells(row, 4) = rs!staff_joblevel
.Cells(row, 5) = rs!sec_shortname
.Cells(row, 6) = rs!staff_group
.Cells(row, 7) = rs!returned_id
.Cells(row, 8) = rs!date_insert
rs.MoveNext
row = row + 1
ProgressBar.Value = ProgressBar.Value + 1
Loop
End With
End If
Else
MsgBox "No record have found"
Exit Sub
End If
AppExcel.ActiveWorkbook.Save
AppExcel.Visible = True
Close EndExcel
End Sub
Private Sub cmdSearch_Click()
Dim sql As String
Dim sql1 As String
Dim rs As adodb.Recordset
sql1 = ""
SQL2 = ""
If (Trim(txtSStaffNo) <> "") Then
sql1 = sql1 & "and staff_no = '" & Trim(txtSStaffNo) & "' "
End If
If (Trim(txtSReturnID) <> "") Then
SQL2 = SQL2 & "and returned_id = '" & Trim(txtSReturnID) & "' "
End If
sql = "SELECT * FROM staff_badgeReturn " _
& "WHERE date_insert >= '" & Format(dtpick1, "dd/MMM/yyyy") & "' " _
& "and date_insert <= '" & Format(dtpick2, "dd/MMM/yyyy") & "' " & sql1 & SQL2
Set rs = New adodb.Recordset
With rs
.ActiveConnection = cnUnisemsql
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open sql
End With
dgData.AllowAddNew = True
dgData.AllowUpdate = True
dgData.AllowDelete = True
If Not rs.EOF Then
Set dgData.DataSource = rs
dgData.DataChanged = True
dgData.Refresh
Else
Set dgData.DataSource = rs
dgData.Refresh
End If
dgData.Columns("Id").Locked = True
dgData.Columns("StaffNo").Locked = False
dgData.Columns("ReturnedID").Locked = False
dgData.Columns("RecycleBadge").Locked = False
dgData.Columns("RecycleBadge").Button = True
dgData.Columns("Date").Button = True
End Sub
Private Sub dgData_ButtonClick(ByVal ColIndex As Integer)
Dim iRow As Integer
Dim iCount As Integer
With dgData
iRow = .row
If ColIndex = dgData.Columns("RecycleBadge").ColIndex Then
List1.Clear
List1.AddItem "1"
List1.AddItem "0"
List1.Top = .Top + .RowTop(iRow) + .RowHeight
List1.Left = .Left + .Columns(ColIndex).Left
List1.Visible = True
List1.SetFocus
ElseIf ColIndex = dgData.Columns("Date").ColIndex Then
dtpick3.Top = .Top + .RowTop(iRow) + .RowHeight
dtpick3.Left = .Left + .Columns(ColIndex).Left
dtpick3.Visible = True
dtpick3.SetFocus
End If
End With
End Sub
Private Sub dtpick3_CallbackKeyDown(ByVal KeyCode As Integer, ByVal Shift As Integer, ByVal CallbackField As String, CallbackDate As Date)
dgData.Columns("Date").Text = dtpick3
dtpick3.Visible = False
End Sub
Private Sub dtpick3_Change()
dgData.Columns("Date").Text = dtpick3
dtpick3.Visible = False
End Sub
Private Sub Form_Load()
Dim sql As String
Dim rs As adodb.Recordset
sql = "select * from staff_badgeReturn " _
& "where date_insert >= '" & Format(DateTime.Now, "dd/MMM/yyyy") & "'"
Set rs = New adodb.Recordset
With rs
.ActiveConnection = cnUnisemsql
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open sql
End With
dgData.AllowAddNew = True
dgData.AllowUpdate = True
dgData.AllowDelete = True
If Not rs.EOF Then
Set dgData.DataSource = rs
dgData.DataChanged = True
dgData.Refresh
Else
Set dgData.DataSource = rs
dgData.Refresh
End If
dgData.Columns("Id").Locked = True
dgData.Columns("StaffNo").Locked = False
dgData.Columns("ReturnedID").Locked = False
dgData.Columns("RecycleBadge").Locked = False
dgData.Columns("RecycleBadge").Button = True
dgData.Columns("Date").Button = True
Combo1.Text = "ALL"
Combo2.Text = "ALL"
dtpick1 = Format(DateTime.Now, "dd/MMM/yyyy")
dtpick2 = Format(DateTime.Now, "dd/MMM/yyyy")
dtpick4 = Format(DateTime.Now, "dd/MMM/yyyy")
dtpick5 = Format(DateTime.Now, "dd/MMM/yyyy")
End Sub
Private Sub List1_LostFocus()
List1.Visible = False
End Sub
Private Sub dtpick3_LostFocus()
dtpick3.Visible = False
End Sub
'''Private Sub txtBadgeNo_KeyDown(KeyCode As Integer, Shift As Integer)
'''
''' If KeyCode = vbKeyReturn Then
'''
''' If txtBadgeNo.Text = "" Then
''' MsgBox "Please key a badge no"
''' Exit Sub
''' End If
'''
''' Dim sql As String
''' Dim rs As ADODB.Recordset
'''
''' sql = ""
''' sql = sql & "select b.id, b.returned_id, a.staff_name, a.staff_no from staff as a "
''' sql = sql & "left join staff_badgeReturn as b on (b.staff_no = a.staff_no) "
''' sql = sql & "where a.staff_no = '" & txtBadgeNo & "'"
'''
''' Set rs = New ADODB.Recordset
''' With rs
''' .ActiveConnection = cnUnisemsql
''' .CursorType = adOpenStatic
''' .Open sql
''' End With
'''
''' If rs.RecordCount = 0 Then
''' MsgBox "No record found"
'''
''' cmdSave.Enabled = False
''' cmdupdate.Enabled = False
''' cmddelete.Enabled = False
''' Else
'''
''' If IsNull(rs!returned_id) Then
'''
''' lblStaffName = rs!staff_Name
''' txtBadgeNo = rs!staff_no
''' txtReturnID = ""
'''
''' cmdSave.Enabled = True
''' cmdupdate.Enabled = False
''' cmddelete.Enabled = False
''' Else
''' txtID = rs!id
''' txtStaffName = rs!staff_Name
''' txtBadgeNo = rs!staff_no
''' txtReturnID = rs!returned_id
'''
''' cmdSave.Enabled = False
''' cmdupdate.Enabled = True
''' cmddelete.Enabled = True
''' End If
''' End If
'''
'''
'''
''' End If
'''
'''End Sub
Private Sub List1_Click()
dgData.Columns("RecycleBadge").Text = List1.Text
List1.Visible = False
End Sub
Private Sub txtFBadgeNo_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyReturn Then
Dim sql As String
Dim rs As adodb.Recordset
sql = "select b.staff_name, (b.staff_branch+b.staff_division+b.staff_dept+b.staff_section) as costblock, c.sec_shortname from staff as b " _
& "join section as c on (c.sec_compcode = b.staff_comp and c.sec_brchcode = b.staff_branch and c.sec_divcode = b.staff_division and c.sec_deptcode = b.staff_dept and c.sec_code = b.staff_section) " _
& "where b.staff_no = '" & Trim(txtFBadgeNo) & "'"
Set rs = New adodb.Recordset
With rs
.ActiveConnection = cnUnisemsql
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open sql
End With
If (rs.RecordCount > 0) Then
lblStaffName = rs!staff_Name
lblSupvCode = rs!sec_shortname
lblCostBlock = rs!CostBlock
Else
lblStaffName = ""
lblSupvCode = ""
lblCostBlock = ""
End If
Set rs = Nothing
sql = "select * from staff_badgeReturn " _
& "where staff_no = '" & Trim(txtFBadgeNo) & "'"
Set rs = New adodb.Recordset
With rs
.ActiveConnection = cnUnisemsql
.CursorType = adOpenStatic
.LockType = adLockOptimistic
.Open sql
End With
dgData.AllowAddNew = True
dgData.AllowUpdate = True
dgData.AllowDelete = True
If Not rs.EOF Then
Set dgData.DataSource = rs
dgData.DataChanged = True
dgData.Refresh
Else
Set dgData.DataSource = rs
dgData.Refresh
End If
dgData.Columns("Id").Locked = True
dgData.Columns("StaffNo").Locked = False
dgData.Columns("ReturnedID").Locked = False
dgData.Columns("RecycleBadge").Locked = False
dgData.Columns("RecycleBadge").Button = True
dgData.Columns("Date").Button = True
End If
End Sub