big problem with form PLEASE HELP


J

James

This will be long winded but please bear with me: I need some help. I have
an access program with will take the information from my DB2 database from
and AIX system and copy it to a table in access. Everything has been
working fine until hurricane Gustav. during that time (from 8/29 - 9/3) the
database did not update. On 9/4 - 9/8, after rebooting the access pc the
updates continued to work. it again died on 9/9 - present.
Part of the script checks for the reports (known as CFS) at 6:00 AM each
morning and pulls the information from the previous day (i.e. on 8/2 it
pulls info from 8/1). If you look at some the comments in the text below, i
can change the date and CFS # to pull the previous day if it does not run
overnight for whatever reason. In doing so, I can't get it to pull any
information. I can go to the DB2 system and pull all the CFS for the dates
I'm missing so I know the data is there. Please let me know if there is
something simple I am missing or if there is a simple correction needed to
be made to fix this issue. The code is below.

Option Compare Database



Private Sub Detail_Click()



End Sub



Private Sub firstday_BeforeUpdate(Cancel As Integer)



End Sub



Private Sub Form_Load()

Dim day1

'day1 = Now()

'to add a missing date change day1 to 1 day before todays date

'if today is 10/18/2007, change day1 to day1 = #10/17/2007#

day1 = "09/02/2008 6:00 am"

day1 = DateValue(day1) & " 6:00 am"

Me.firstday = day1

day1 = 0

End Sub



Private Sub Form_Timer()

Dim cadstampdate, cadstamptime, primary, cfs, code, incadd, dispo, dispatch,
calltaker, item, last4, getcfs, officer

Dim sqlfull, dbsfull, rstfull

Dim sqlfull_sub, dbsfull_sub, rstfull_sub

Dim sqlfull_cfs, dbsfull_cfs, rstfull_cfs

Dim sqlfull_item, dbsfull_item, rstfull_item

Dim sqldb2_dr, dbsdb2_dr, rstdb2_dr

Dim sqldb2_cfs, dbsdb2_cfs, rstdb2_cfs

Dim sqldb2_sub, dbsdb2_sub, rstdb2_sub

Dim count, todayhr, mm, dd, yy, day1, day2

Dim stDocName As String



'put a stop on me.timerinterval. to put stop click on the

'left side bar and put a red dot on it. hit F8 to advance to

'next line and hit F5 to continue.

Me.TimerInterval = 0



todayhr = Now()

todayhr = Hour(todayhr)

day1 = Me.firstday

day2 = Now()

If DateDiff("d", day1, day2) >= 1 Then

If todayhr = "9" Then

getcfs = DateAdd("d", -1, Trim(Now()))

If Month(getcfs) < 10 Then

mm = "0" & Left(getcfs, 1)

If Day(getcfs) < 10 Then

dd = "0" & Mid(getcfs, 3, 1)

yy = Mid(getcfs, 7, 2)

Else

dd = Mid(getcfs, 3, 2)

yy = Mid(getcfs, 8, 2)

End If

Else

mm = Left(getcfs, 2)

If Day(getcfs) < 10 Then

dd = "0" & Mid(getcfs, 4, 1)

yy = Mid(getcfs, 8, 2)

Else

dd = Mid(getcfs, 4, 2)

yy = Mid(getcfs, 9, 2)

End If

End If

'just flip the ' between the 2 and enter the date you want to append

'in the slot if want 10/13/2007 use getcfs = "101307-*"

getcfs = "090308-*"

'getcfs = mm & dd & yy & "-*"

GoSub gofullitem

GoSub gofullcfs

GoSub gofullsub

GoSub fullimport

Me.firstday = day2

Me.secondday = Now()

End If

End If



Me.TimerInterval = 9999

Exit Sub





gofullitem:

sqlfull_item = "SELECT full_item.item, full_item.cfs from full_item;"

Set dbsfull_item = CurrentDb

Set rstfull_item = dbsfull_item.OpenRecordset(sqlfull_item)

GoSub goitem

dbsfull_item.Close

Set rstfull_item = Nothing

Set recfull_item = Nothing

Return

Exit Sub





goitem:

sqldb2_drn = "SELECT KENADM_CADDRNDB2.DR_NMBR, KENADM_CADDRNDB2.drn_NMBR
FROM KENADM_CADDRNDB2 where kenadm_caddrndb2.drn_nmbr like " & Chr(34) &
getcfs & Chr(34) & ";"

Set dbsdb2_drn = CurrentDb

Set rstdb2_drn = dbsdb2_drn.OpenRecordset(sqldb2_drn)

count = rstdb2_drn.RecordCount

Do While rstdb2_drn.EOF = False

cfs = rstdb2_drn![drn_nmbr]

item = Trim(rstdb2_drn![dr_nmbr])

If mm < 10 Then

item = Mid([item], 14, 2) & "0" & Mid([item], 16, 1) & Right([item],
5)

Else

item = Mid([item], 13, 2) & Mid([item], 15, 2) & Right([item], 5)

End If

rstfull_item.AddNew

rstfull_item![item] = item

rstfull_item![cfs] = cfs

rstfull_item.update

item = ""

cfs = ""

rstdb2_drn.MoveNext

Loop

dbsdb2_drn.Close

Set rstdb2_drn = Nothing

Set recdb2_drn = Nothing

Return

Exit Sub





gofullcfs:

sqlfull_cfs = "SELECT full_cfs.cfs, full_cfs.code, full_cfs.address,
full_cfs.apt, full_cfs.call_taker, full_cfs.dispatcher, full_cfs.primary,
full_cfs.dispo, full_cfs.stampdate, full_cfs.stamptime from full_cfs;"

Set dbsfull_cfs = CurrentDb

Set rstfull_cfs = dbsfull_cfs.OpenRecordset(sqlfull_cfs)

GoSub gocfs

dbsfull_cfs.Close

Set rstfull_cfs = Nothing

Set recfull_cfs = Nothing

Return

Exit Sub





gocfs:

sqldb2_cfs = "SELECT KENADM_CADCFSDB2.CFS_NUMBR,
KENADM_CADCFSDB2.INC_CODE, KENADM_CADCFSDB2.ADDRESS,
KENADM_CADCFSDB2.APT_NUMBER, KENADM_CADCFSDB2.CALL_TAKER,
KENADM_CADCFSDB2.DISPATCHER, KENADM_CADCFSDB2.PRIUNIT,
KENADM_CADCFSDB2.FINALDISP, KENADM_CADCFSDB2.STMP_RCVD FROM KENADM_CADCFSDB2
where KENADM_CADCFSDB2.CFS_NUMBR like " & Chr(34) & getcfs & Chr(34) & ";"

Set dbsdb2_cfs = CurrentDb

Set rstdb2_cfs = dbsdb2_cfs.OpenRecordset(sqldb2_cfs)

count = rstdb2_cfs.RecordCount

rstdb2_cfs.MoveFirst

Do While rstdb2_cfs.EOF = False



cfs = Trim(rstdb2_cfs![cfs_numbr])

code = Trim(rstdb2_cfs![INC_CODE])

Address = Trim(rstdb2_cfs![Address])

apt = Trim(rstdb2_cfs![APT_NUMBER])

calltaker = Trim(rstdb2_cfs![call_taker])

dispatch = Trim(rstdb2_cfs![dispatcher])

primary = Trim(rstdb2_cfs![PRIUNIT])

dispo = Trim(rstdb2_cfs![FINALDISP])

cadstampdate = Left((rstdb2_cfs![stmp_rcvd]), 10)

cadstamptime = Mid((rstdb2_cfs![stmp_rcvd]), 12, 5)

cadstampdate = Mid(cadstampdate, 6, 2) & "/" & Mid(cadstampdate, 9, 2) &
"/" & Left(cadstampdate, 4)

rstfull_cfs.AddNew

rstfull_cfs![cfs] = cfs

rstfull_cfs!
Code:
 = code

rstfull_cfs![Address] = Address

rstfull_cfs![apt] = apt

rstfull_cfs![call_taker] = calltaker

rstfull_cfs![dispatcher] = dispatch

rstfull_cfs![primary] = primary

rstfull_cfs![dispo] = dispo

rstfull_cfs![stampdate] = cadstampdate

rstfull_cfs![stamptime] = cadstamptime

rstfull_cfs.update

cfs = ""

code = ""

Address = ""

apt = ""

calltaker = ""

dispatch = ""

primary = ""

dispo = ""

cadstampdate = ""

cadstamptime = ""

rstdb2_cfs.MoveNext

Loop

dbsdb2_cfs.Close

Set rstdb2_cfs = Nothing

Set recdb2_cfs = Nothing

Return

Exit Sub





gofullsub:

sqlfull_sub = "SELECT full_sub.unit, full_sub.last4, full_sub.name, 
full_sub.cfs from full_sub;"

Set dbsfull_sub = CurrentDb

Set rstfull_sub = dbsfull_sub.OpenRecordset(sqlfull_sub)

GoSub gounit

dbsfull_sub.Close

Set rstfull_sub = Nothing

Set recfull_sub = Nothing

Return

Exit Sub





gounit:

sqldb2_sub = "SELECT KENADM_CADSUBDB2.unt_number, 
KENADM_CADSUBDB2.sub_unit_id, KENADM_CADSUBDB2.sub_unit_desc, 
KENADM_CADSUBDB2.cfs_numbr from KENADM_CADSUBDB2 where 
KENADM_CADSUBDB2.cfs_numbr like " & Chr(34) & getcfs & Chr(34) & ";"

Set dbsdb2_sub = CurrentDb

Set rstdb2_sub = dbsdb2_sub.OpenRecordset(sqldb2_sub)

count = rstdb2_sub.RecordCount



Do While rstdb2_sub.EOF = False

primary = rstdb2_sub![unt_number]

cfs = rstdb2_sub![cfs_numbr]

last4 = rstdb2_sub![sub_unit_id]

officer = rstdb2_sub![sub_unit_desc]



rstfull_sub.AddNew

rstfull_sub![unit] = primary

rstfull_sub![cfs] = cfs

rstfull_sub![last4] = last4

rstfull_sub![Name] = officer



rstfull_sub.update

primary = ""

cfs = ""

officer = ""

last4 = ""

rstdb2_sub.MoveNext

Loop

dbsdb2_sub.Close

Set rstdb2_sub = Nothing

Set recdb2_sub = Nothing

Return

Exit Sub



fullimport:

Application.SetOption "confirm action queries", 0

Application.SetOption "confirm record changes", 0

Application.SetOption "confirm document deletions", 0



stDocName = "appendfull"

DoCmd.OpenQuery stDocName, acNormal, acEdit

stDocName = "updateunit"

DoCmd.OpenQuery stDocName, acNormal, acEdit

stDocName = "deletecfs"

DoCmd.OpenQuery stDocName, acNormal, acEdit

stDocName = "deletesub"

DoCmd.OpenQuery stDocName, acNormal, acEdit

stDocName = "deleteitem"

DoCmd.OpenQuery stDocName, acNormal, acEdit

stDocName = "updateshift"

DoCmd.OpenQuery stDocName, acNormal, acEdit

stDocName = "latechecker"

DoCmd.OpenQuery stDocName, acNormal, acEdit



Application.SetOption "confirm action queries", 1

Application.SetOption "confirm record changes", 1

Application.SetOption "confirm document deletions", 1

Return

Exit Sub



End Sub
 
Ad

Advertisements

J

John W. Vinson

This will be long winded

Excessively so, I fear. Asking unpaid volunteers to debug 800+ lines of
complex VBA code, without debugging tools, sample data, or detailed problem
descriptions is a bit unreasonable, isn't it?

Perhaps you'll need to hire someone to come in or remotely access your
database. Sorry I can't be more help!
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads


Top