VB6 with Excel write using SQL query
I have a program that I am creating to run in VB6. It will write to an Excel template that is created and it will use a basic SQL query for the information. Here is my code. I get at the very beginning of my variables a compile error and it is on the variable Private con. So, what other errors after that I have no idea. Please help!!!!
Option Explicit
'ADO Variables
Private con As ADODB.Connection
Private cmdGetRecords As ADODB.Command
Private prmRecord As ADODB.Parameter
Private rsRecords As ADODB.Recordset
Private rsCounts As ADODB.Recordset
Private rsSrvRecords As ADODB.Recordset
'Report Variables
Dim dStart As Date
Dim dEnd As Date
Dim sMonth As String
Dim strMonth As String
Dim sDay As String
Dim sPath As String
Dim strPath As String
Dim sFile As String
Dim sFileID As String
Dim sFileName As String
Dim sFileTime As String
Dim sExcelFile As String
Dim sDate As String
Dim sTime As String
Dim WorkBook As Object
Dim bMonthSame As Boolean
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub Form_Load()
Call GetDates
If sDay = "Monday" Then
Call CreateMonthlyDir
End If
Call CreateWeeklyDir
Call GetFileNames
Call GetData
Call CreateWorkSheet
Call ModifyWorkBook
Call EndProgram
End Sub
Private Sub GetDates()
Dim CurrentDate As Date
Dim strDay As String
'Get Dates for Directory Naming Scheme
CurrentDate = "4/01/2005"
strDay = Weekday(CurrentDate)
Select Case strDay
Case vbMonday
sDay = "Monday"
dStart = DateAdd("d", 0, Now)
dEnd = DateAdd("d", 6, Now)
Case vbTuesday
sDay = "Tuesday"
dStart = DateAdd("d", -1, Now)
dEnd = DateAdd("d", 5, Now)
Case vbWednesday
sDay = "Wednesday"
dStart = DateAdd("d", -2, Now)
dEnd = DateAdd("d", 4, Now)
Case vbThursday
sDay = "Thursday"
dStart = DateAdd("d", -3, Now)
dEnd = DateAdd("d", 3, Now)
Case vbFriday
sDay = "Friday"
dStart = DateAdd("d", -4, Now)
dEnd = DateAdd("d", 2, Now)
End Select
'Get Month Name(s) for Directory Naming Scheme
sMonth = Format$(dStart, "mmm")
strMonth = Format$(dEnd, "mmm")
If sMonth = strMonth Then
bMonthSame = True
Else
bMonthSame = False
End If
dStart = "4/01/2005"
End Sub
Private Sub CreateMonthlyDir()
Dim strPrevWeek As String
Dim strPrevMonth As String
Dim strCurMonth As String
Dim strDir As String
Dim strSource As String
Dim strDest As String
Dim sDir As String
Dim sFiles As String
Dim sFileNames As String
Dim sResult As String
Dim i As Integer
'Check to see if Monthly Directory Needs to be Created
strPrevWeek = DateAdd("d", -7, dStart)
strPrevMonth = DatePart("m", strPrevWeek)
strCurMonth = DatePart("m", dStart)
If strPrevMonth = strCurMonth Then
Exit Sub
End If
'Create Previous Monthly Directory
strDir = Format$(strPrevWeek, "mmm")
strDest = "\\Homeboy\Common\Horizon User Reports\Monthly\" & strDir
sFileNames = "*.xls"
sResult = Dir$(strDest & "\" & sFileNames)
If sResult = "" Then
MkDir strDest
Dir1.Path = strDest
'Get Weekly Directory Listings
strSource = "\\Homeboy\Common\Horizon User Reports\Weekly\"
Dir1.Path = strSource
i = 0
'Copy Files from Weekly Directory Listing to Monthly Directory
For i = 0 To Dir1.ListCount - 1
sDir = Dir1.List(i)
sFiles = Dir$(sDir & "\*.xls")
Do Until Len(sFiles) = 0
FileCopy sDir & "\" & sFiles, strDest & "\" & sFiles
sFiles = Dir()
Loop
Next i
End If
End Sub
Private Sub CreateWeeklyDir()
Dim sStart As String
Dim sEnd As String
Dim sDir As String
Dim sFileName As String
Dim sResult As String
'Check to see if Weekly Directory has been Created
sStart = Format$(dStart, "d")
sEnd = Format$(dEnd, "d")
If bMonthSame = True Then
sDir = sMonth & " " & sStart & " - " & sEnd
Else
sDir = sMonth & " " & sStart & " - " & strMonth & " " & sEnd
End If
sPath = "\\Homeboy\Common\Horizon User Reports" & sDir
sFileName = "*.xls"
sResult = Dir$(sPath & "\" & sFileName)
'Create Weekly Directory if it does not exist
If sResult = "" Then
sPath = "\\Homeboy\Common\Horizon User Reports"
'MkDir sPath
End If
'Set Network Path
Dir1.Path = sPath
End Sub
Private Sub GetFileNames()
'Set EXCEL Application
Set WorkBook = CreateObject("Excel.Application")
'Set Network Mapping Drive for Template File and Text Files
strPath = "\\Homeboy\Common\Horizon User Reports"
Dir1.Path = strPath
'File Naming Scheme for Text File
sFileTime = Format$(Time, "hhmmss")
sFile = sFileTime & ".txt"
'File Naming Scheme for EXCEL Files
sFileName = "ServerStats" & Format$(Now, "mmdd") & "_" & sFileTime & ".xls"
sExcelFile = "ServerStats" & Format$(Now, "mmdd") & ".xls"
'EXCEL File Title Headings
sDate = Format$(Now, "mmm d yyyy")
sTime = Time
End Sub
Private Sub GetData()
Dim sLicenseName As String
Dim iLicenseCounts As Integer
'Open Text File for Output
Open strPath & "\" & sFile For Output As #1
'Connect to Sql Server
Set con = New ADODB.Connection
With con
.ConnectionString = "PROVIDER=SQLOLEDB;USER ID=XXXXXXX;PASSWORD=XXXXXXX;Data Source=HCHZNDB01;Initial Catalog=XXXXXXXX"
.ConnectionTimeout = 0
.Open
End With
'Define ADO Environment to create Server RecordSet
Set cmdGetRecords = New ADODB.Command 'create command object
Set cmdGetRecords.ActiveConnection = con 'set command object to active connection
cmdGetRecords.CommandTimeout = 0
'SQL Statement
cmdGetRecords.CommandText = "SELECT UsrCurPgm.[pgmnam] " & _
"FROM UsrCurPgm WHERE UsrCurPgm.[pgmnam] = clinical.exe"
'Command Type (Stored Procedure)
cmdGetRecords.CommandType = adCmdStoredProc
'Build Parameter List for Server File
sFileID = "1"
Set prmRecord = cmdGetRecords.CreateParameter("@FileID", adChar, adParamInput, 1, sFileID)
cmdGetRecords.Parameters.Append prmRecord
'Run Stored Procedure to Create Recordset
Set rsSrvRecords = cmdGetRecords.Execute
'Loop to Create Server Counts
Print #1, "License_Usage", ","; "Counts"
Do Until rsSrvRecords.EOF
With rsSrvRecords
sServerName = .Fields("License_Usage")
iServerCounts = .Fields("Counts")
End With
Print #1, sLicenseName, ","; iLicenseCounts
rsSrvRecords.MoveNext
Loop
'Close SQL Server Connection
con.Close
'Close Output Text File
Close #1
'Initialize Recordsets
Set rsSrvRecords = Nothing
End Sub
Private Sub CreateWorkSheet()
Dim sPos As String
Dim FileSize As Long
'Format into EXCEL SpreadSheet
Workbooks.OpenText FileName:=strPath & "\" & sFile, _
Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False _
, Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), _
Array(2, 2), Array(3, 2)), TrailingMinusNumbers:=True
'Bold and Paint Column Headings for Server Name Section
Rows("1:1").Select
Selection.Font.Bold = True
With Selection.Interior
.ColorIndex = 6
.Pattern = xlSolid
End With
'AutoSize Columns
Columns("A:A").EntireColumn.AutoFit
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
'Save Working EXCEL Spreadsheet
ActiveWorkbook.SaveAs FileName:=strPath & "\" & sFileName, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Close Working EXCEL Spreadsheet
ActiveWorkbook.Close (True)
'Close EXCEL Application
WorkBook.Quit
'Verify Working EXCEL Spreadsheet was created
FileSize = FileLen(strPath & "\" & sFileName)
If FileSize > 0 Then
Kill strPath & "\" & sFile
Else
MsgBox "An error occurred creating the Working Spreadsheet"
End If
End Sub
Private Sub ModifyWorkBook()
Dim sResult As String
Dim strTime As String
Dim FileSize As Long
'Create Today's Workbook from Template
sResult = Dir$(sPath & "\" & sExcelFile)
If sResult = "" Then
Workbooks.Open FileName:=strPath & "\" & "Template.xls"
ActiveWorkbook.SaveAs FileName:=sPath & "\" & sExcelFile, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close (True)
End If
'Get Time to select correct Worksheet
strTime = Format$(Time, "hh")
'Open Working File
Workbooks.Open FileName:=strPath & "\" & sFileName
Cells.Select
Selection.Copy
'Open Master File
Workbooks.Open FileName:=sPath & "\" & sExcelFile
'Select Worksheet based on the hour of the day
Select Case strTime
Case "11"
Sheets("1100").Select
Case "12"
Sheets("1200").Select
Case "13"
Sheets("100").Select
Case "14"
Sheets("200").Select
Case "15"
Sheets("300").Select
Case "16"
Sheets("400").Select
Case "17"
Sheets("500").Select
End Select
'Populate Selected Worksheet based on the hour of day
Cells.Select
ActiveSheet.Paste
Application.CutCopyMode = False
'Format Selected Worksheet
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = "&""Arial,Bold""Server Stats" & Chr(10) & sDate & " at " & sTime
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = "Page &P"
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.75)
.RightMargin = Application.InchesToPoints(0.75)
.TopMargin = Application.InchesToPoints(1)
.BottomMargin = Application.InchesToPoints(1)
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = True
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
.PrintErrors = xlPrintErrorsDisplayed
End With
'Go to Top of File
Range("A1").Select
'Save EXCEL Master Spreadsheet
ActiveWorkbook.Save
'Close Working EXCEL Spreadsheet
ActiveWorkbook.Close (True)
'Close EXCEL Application
WorkBook.Quit
'Verify Master EXCEL Spreadsheet was Modified
FileSize = FileLen(sPath & "\" & sExcelFile)
If FileSize > 0 Then
DoEvents
Else
MsgBox "An error occurred modifying the Server Stats Spreadsheet"
End If
End Sub
Private Sub EndProgram()
'Delete Working SpreadSheet
Kill strPath & "\" & sFileName
'Unload the Form
Unload Me
End Sub
|
