Wrox Programmer Forums
| Search | Today's Posts | Mark Forums Read
Excel VBA Discuss using VBA for Excel programming.
Welcome to the p2p.wrox.com Forums.

You are currently viewing the Excel VBA section of the Wrox Programmer to Programmer discussions. This is a community of software programmers and website developers including Wrox book authors and readers. New member registration was closed in 2019. New posts were shut off and the site was archived into this static format as of October 1, 2020. If you require technical support for a Wrox book please contact http://hub.wiley.com
  #1 (permalink)  
Old April 6th, 2005, 08:41 AM
Registered User
Points: 48, Level: 1
Points: 48, Level: 1 Points: 48, Level: 1 Points: 48, Level: 1
Activity: 0%
Activity: 0% Activity: 0% Activity: 0%
 
Join Date: Feb 2005
Location: frederick, md, .
Posts: 6
Thanks: 0
Thanked 0 Times in 0 Posts
Default VB6/Excel/SQL

Below is my VB6 code. The stored procedures section I want to change to be just a sql query. I have bolded it. I don't want to use a stored procedure. Just a sql query to query a table. I am not sure how to reformat this. Can you 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
Private rsPrgRecords As ADODB.Recordset
Private rsSrvPrgRecords 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 iRow As Integer
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 = "1/18/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 = "1/18/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 sServerName As String
    Dim iServerCounts As Integer
    Dim sProgramName As String
    Dim iProgramCounts As Integer
    Dim sServerNames As String
    Dim sProgramNames As String
    Dim iSrvPrgCounts 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=tmiller1;PASSWORD=homecall;Data Source=HCHZNDB01;Initial Catalog=Pwhcprod01"
        .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
'Name of Stored Procedure
    cmdGetRecords.CommandText = "pdsv_Get_Server_Stats1"
'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, "Server_Name", ","; "Counts"
    Do Until rsSrvRecords.EOF
        With rsSrvRecords
            sServerName = .Fields("Server_Name")
            iServerCounts = .Fields("Counts")
        End With
        Print #1, sServerName, ","; iServerCounts
        rsSrvRecords.MoveNext
    Loop

'Define ADO Environment to create Program File RecordSet
    Set cmdGetRecords = New ADODB.Command 'create command object
    Set cmdGetRecords.ActiveConnection = con 'set command object to active connection
    cmdGetRecords.CommandTimeout = 0
'Name of Stored Procedure
    cmdGetRecords.CommandText = "pdsv_Get_Server_Stats1"
'Command Type (Stored Procedure)
    cmdGetRecords.CommandType = adCmdStoredProc
'Build Parameter List for Program File
    sFileID = "2"
    Set prmRecord = cmdGetRecords.CreateParameter("@FileID", adChar, adParamInput, 1, sFileID)
    cmdGetRecords.Parameters.Append prmRecord
'Run Stored Procedure to Create Recordset
    Set rsPrgRecords = cmdGetRecords.Execute

'Loop to Create Program Counts
    Print #1#, " "
    Print #1, "Program_Name", ","; "Counts"
    Do Until rsPrgRecords.EOF
        With rsPrgRecords
            sProgramName = .Fields("Program_Name")
            iProgramCounts = .Fields("Counts")
        End With
        Print #1, RTrim(sProgramName), ","; iProgramCounts
        rsPrgRecords.MoveNext
    Loop

'Define ADO Environment to create Server/Program RecordSet
    Set cmdGetRecords = New ADODB.Command 'create command object
    Set cmdGetRecords.ActiveConnection = con 'set command object to active connection
    cmdGetRecords.CommandTimeout = 0
'Name of Stored Procedure
    cmdGetRecords.CommandText = "pdsv_Get_Server_Stats1"
'Command Type (Stored Procedure)
    cmdGetRecords.CommandType = adCmdStoredProc
'Build Parameter List for Server/Program File
    sFileID = "3"
    Set prmRecord = cmdGetRecords.CreateParameter("@FileID", adChar, adParamInput, 1, sFileID)
    cmdGetRecords.Parameters.Append prmRecord
'Run Stored Procedure to Create Recordset
    Set rsSrvPrgRecords = cmdGetRecords.Execute

'Loop to Create Server to Program Counts
    Print #1#, " "
    Print #1, "Server_Names", ","; "Program_Names", ","; "Counts"
    Do Until rsSrvPrgRecords.EOF
        With rsSrvPrgRecords
            sServerNames = .Fields("Server_Names")
            sProgramNames = .Fields("Program_Names")
            iSrvPrgCounts = .Fields("Counts")
        End With
        Print #1, sServerNames, ","; RTrim(sProgramNames), ","; iSrvPrgCounts
        rsSrvPrgRecords.MoveNext
    Loop

'Close SQL Server Connection
    con.Close

'Close Output Text File
    Close #1

'Initialize Recordsets
    Set rsSrvRecords = Nothing
    Set rsPrgRecords = Nothing
    Set rsSrvPrgRecords = 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
'Get Row Number to Bold and Paint Column Headings for Program Name Section
    iRow = 1
    sPos = "A" & iRow
    Range(sPos).Select
    Do Until Range(sPos).Value = "Program_Name "
        If Range(sPos).Value <> "Program_Name " Then
            iRow = iRow + 1
            sPos = "A" & iRow
        End If
    Loop
    Rows(iRow).Select
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
    End With
'Get Row Number to Bold and Paint Column Headings for Server Name to Program Name Section
    sPos = "A" & iRow
    Range(sPos).Select
    Do Until Range(sPos).Value = "Server_Names "
        If Range(sPos).Value <> "Server_Names " Then
            iRow = iRow + 1
            sPos = "A" & iRow
        End If
    Loop
    Rows(iRow).Select
    Selection.Font.Bold = True
    With Selection.Interior
        .ColorIndex = 6
        .Pattern = xlSolid
    End With
'AutoSize Columns
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$" & iRow & ":" & "$" & iRow
        .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 "1"
            Sheets("1000").Select
        Case "2"
            Sheets("1030").Select
        Case "3"
            Sheets("1100").Select
        Case "4"
            Sheets("200").Select
        Case "5"
            Sheets("230").Select
        Case "6"
            Sheets("300").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 = "$" & iRow & ":" & "$" & iRow
        .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





  #2 (permalink)  
Old April 6th, 2005, 02:07 PM
Friend of Wrox
 
Join Date: Nov 2004
Location: Port Orchard, WA, USA.
Posts: 1,621
Thanks: 1
Thanked 3 Times in 3 Posts
Default

1) Why do you not want to use stored procedures?

2) It is impossible to say how you would accomplish something that is
     currently in a stored procedure, without knowing what is in the
     stored procedure(s).

3) Your code
Code:
       Open strPath & "\" & sFile For Output As #1
     is a bad idea; you don’t know that the number 1 is available.
     You should use instead
Code:
       Dim fn As Integer
Code:
       fn = FreeFile
       Open strPath & "\" & sFile For Output As fn
        Then your print statements would be like
Code:
       Print fn
  #3 (permalink)  
Old April 6th, 2005, 02:10 PM
Registered User
Points: 48, Level: 1
Points: 48, Level: 1 Points: 48, Level: 1 Points: 48, Level: 1
Activity: 0%
Activity: 0% Activity: 0% Activity: 0%
 
Join Date: Feb 2005
Location: frederick, md, .
Posts: 6
Thanks: 0
Thanked 0 Times in 0 Posts
Default

Because I can't view that stored procedure to see what is in it to change it to what I need it to be. I have tried to find that procedure and have found it, but it only has an execute and the procedure. The company doesn't use the procedure anymore for it's intended use and I know it has a SQL code in it that I can alter, I just can't find it's path to do so. No one here can help me because they don't know SQL. At work that is.



Similar Threads
Thread Thread Starter Forum Replies Last Post
Problems with CurrentRegions (Excel) in VB6 I_See Excel VBA 0 June 22nd, 2006 01:51 PM
Using VB6 to add name to Excel Name Box aarmit10 Beginning VB 6 1 March 17th, 2006 05:47 AM
Writing to an Excel Worksheet in VB6 David Robinson Pro VB 6 1 August 27th, 2005 04:29 PM
VB6 with Excel write using SQL query tmiller1 Excel VBA 3 March 9th, 2005 01:26 AM
How can i open Excel From VB6 chiefouko Beginning VB 6 1 June 30th, 2003 08:28 AM





Powered by vBulletin®
Copyright ©2000 - 2020, Jelsoft Enterprises Ltd.
Copyright (c) 2020 John Wiley & Sons, Inc.