Complete chaos in Excel VBS/SQL

Question

Ok so in my previous question, I was having issues with a random syntax error. Well turns out the code is much worse, but filled with what seems to be the same syntax.

I "inherited" this code and have 0 idea how to fix it. I'm a fresh noob to SQL but I'm obviously interested in learning. At this point I'd probably pay for an easy solution.

Public Code As Integer
Private Sub Workbook_Open()
'this sub resets the worksheet for another PO to be requested

On Error GoTo Catch

Dim Conn
Dim RS
Dim SQL
Dim ActCons As Integer

'open connection to DB
Set Conn = CreateObject("ADODB.Connection")
Conn.Open = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=Purchases;Data Source=tiftonserver;Use Procedure for Prepare=1;Auto "

'recheck # of active sessions in case someone else opened request while filling out this users last request
SQL = "select * from Purchases.dbo.Sessions"
Set RS = Conn.Execute(SQL)
ActCons = RS.Fields(1)

SQL = "select top 1 PONum from Purchases.dbo.POs order by PONum desc"
Set RS = Conn.Execute(SQL)

Range("H12").Value = RS.Fields(0) + ActCons

'unlock user data fields
Worksheets("P.O.").Range("B16:G29").Locked = False
Worksheets("P.O.").Range("F7:H10").Locked = False
Worksheets("P.O.").Range("C12:E12").Locked = False

'clear previous PO request information
Range("B16", "G29").Select
Selection.ClearContents
Range("B34", "G37").Select
Selection.ClearContents
Range("F7").Select
Selection.ClearContents
Range("C12").Select
Selection.ClearContents

'set user name and date based on windows login and date/time
Range("A34").Value = Application.UserName
Range("A38").Value = Date

Range("F7").Select 'set active selection at Vendor

Worksheets("P.O.").Protect UserInterfaceOnly:=True
Exit Sub

Catch:
Set Conn = CreateObject("ADODB.Connection")
Conn.Open = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=Purchases;Data Source=tiftonserver;Use Procedure for Prepare=1;Auto "
SQL = "Update Purchases.dbo.Sessions Set Active = Active - 1"
Set RS = Conn.Execute(SQL)
MsgBox ("An Error has occured and your PO Request has NOT been processed")
MsgBox "Error " & Err.Number & vbCrLf & Err.Description
ThisWorkbook.Close
End Sub


Sub CommandButton1_Click()

'set the filename to be passed to DB_Update
FileName = "\\tiftonserver\purchaserequests$\" & TextBox1 & ".pdf"
Worksheets("P.O.").Unprotect

Sheets("P.O.").Select
Print_Save
DB_Update (FileName)
Workbook_Open 'reset the workbook for additional POs
Unload Me 'close form for continued use


End Sub



Private Sub CommandButton2_Click()
Unload Me
End Sub

Sub Print_Save()

PrintSetting = True
Dim ru As String
'set up server path
ru = "something\"
 Range("A1:H39").Select
 Selection.ExportAsFixedFormat Type:=xlTypePDF, _
 FileName:=ru & Range("H12") & ".pdf", _
 Quality:=xlQualityStandard, IncludeDocProperties:=True, _
 IgnorePrintAreas:=False, OpenAfterPublish:=False

PrintSetting = False
End Sub

Sub DB_Update(FileName)

Dim RowCount As Integer
Dim Conn
Dim RS
Dim SQL
Dim Code As Long
Dim Preamble As Long
Dim postamble As Long

'open connection to DB Server
Set Conn = CreateObject("ADODB.Connection")
Conn.Open = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=Purchases;Data Source=tiftonserver;Use Procedure for Prepare=1;Auto "


RowCount = 16
Range("B16:B29").Select 'selects all rows that can have user data
Do While Not IsEmpty(ActiveCell) 'loop until there is a blank line indicating that there are no more line items

desc = Cells(RowCount, 2).Value

 pos = InStr(Cells(RowCount, 2).Value, "'") > 0
  If pos <> 0 Then
     desc = Replace(Cells(RowCount, 2).Value, "'", "''")
  End If

'create the SQL Query statement to add the PO Details to DB
    SQL = "insert into Purchases.dbo.PODetails values(" & Range("H12").Value & "," & Cells(RowCount, 1) _
    & "," & Cells(RowCount, 6) & "," & Cells(RowCount, 7) & ",'" & _
    desc & "')"
    Set RS = Conn.Execute(SQL) 'execute the query
    ActiveCell.Offset(1, 0).Select
    RowCount = RowCount + 1
Loop

'create random authorization code for this PO Request.
'generate 2 random numbers and the multiply them together to generate the final code
Randomize
Preamble = Int((99 - 10 + 1) * Rnd + 10) * 3
postamble = Int((9999 - 1000 + 1) * Rnd + 1000)
Code = Preamble * postamble

'insert the new PO Request summary into the DB including the authorization code
Dim Report As Worksheet
Set Report = Excel.ActiveSheet
SQL = "insert into Purchases.dbo.POs values(" & Range("H12").Value & "," & Range("H30").Value & "," & Excel.WorksheetFunction.Sum(Report.Range("F16:F29")) & ",'" & Range("A34").Value & _
"','" & Range("F7").Value & "','" & Range("C12").Value & "','" & Range("A38").Value & ",0," & Code & ")"
'MsgBox SQL
Set RS = Conn.Execute(SQL)

'lookup on hidden worksheet that references all user names with their email prefix
Email = Application.WorksheetFunction.VLookup(Range("A34"), Worksheets("Emails").Range("A2:B25").Value, 2, False)
Email = Email & "@someplace.com"
'extract just the PO Request number from the filename passed from Command_Click Sub
PO = Left(FileName, Len(FileName) - 4)
EmailPO = Right(PO, Len(PO) - 33)

'set up the email object to send the PDF of the request and the authorization code
Set emailObj = CreateObject("CDO.Message")
emailObj.From = "NoReply@someplace.com"
emailObj.To = "diego.e@someplace.com"
emailObj.Subject = "PO Request"
'set the msg to send as a mailto hyperlink that will create a new msg to send approval to the correct person automatically
emailObj.TextBody = "mailto:" & Email & "?subject=PO#" & EmailPO & "&Body=Approval_Code:" & Code
emailObj.AddAttachment FileName

'configure the email server information
Set emailConfig = emailObj.Configuration

'Perform email setup tasks

emailObj.Send

If Err.Number = 0 Then
    MsgBox "Your PO request has been processed and sent via email"
    Else: MsgBox "An ERROR has occured."
End If
End Sub

'prevent users from using the 'X' to close forms. They must use the command buttons
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = 0 Then Cancel = True
End Sub

I do apologise for the immense amount of code, and if anyone knows a better way, please tell me. SMSS Is screaming at me. :(

Posting your company code and email addresses here is unprofessional. At least there is `Integrated Security=SSPI` so we don't have to see your credential to database. — Lukasz Szozda, Jul 06 '18 at 16:14
I submitted an edit that takes out the vulnerable code in question. @RMathis you need to be careful and only post the code relevant to the error AND the error . . . . — Wookies-Will-Code, Jul 06 '18 at 16:20
I've approved the edit to strip away the confidential information, but I had to flag a moderator to remove the info from the edit history. — dwirony, Jul 06 '18 at 16:57
@Wookies-Will-Code You already saved him a lot of trouble he was about to get into. — vendettamit, Jul 06 '18 at 17:00
I'm, sorry. This is only the second time I've posted code here but you're right, I should be more careful. Thanks — RMathis, Jul 06 '18 at 17:17
Please explain what the problem is, you don't seem to do so in the post? — jkpieterse, Jul 06 '18 at 17:49
@jkpieterse The problem is that when I try to compile, I get Invalid Syntax errors on about half the lines. I have copied the code into notepad looking for any extra whitespaces but found none. I'm just at a loss. — RMathis, Jul 06 '18 at 17:53
It would help to let us know what those lines are. There is nothing I can spot that is wrong with your code. I tried the first subroutine on my system and after making a sheet named "P.O." it ran just fine... I mean it couldn't connect to a sql server I don't have, but it compiled and ran. — JNevill, Jul 06 '18 at 19:11
SSMS is screaming at you? VBA doesn't run in SSMS. Open Excel. Press Alt + F11 — David Cram, Jul 06 '18 at 19:16

Parfait · Answer 1 · 2018-07-06T19:52:22.370

While I did not dive deeply into your code to find specific issue, consider two best practice methods to help you locate and resolve your syntax issue.

COMPLETE ERROR HANDLING: Wrap ALL your routines in error handling to raise execptions and errors during runtime. Also, incorporate DBEngine errors that will show specific lines failing TSQL syntax.

Sub DB_Update(FileName)
On Error GoTo ErrorHandle

     '...full code...

Exit_Handle:
    ' RELEASE RESOURCES
    Set RS = Nothing: Set Conn = Nothing
    Exit Sub

ErrorHandle:
    Dim myerror As Error
    For Each myerror In DBEngine.Errors
        With myerror
            Msgbox .Number & " - " .Description, "RUNTIME ERROR", vbCritical
        End With
    Next myerror
    Resume Exit_Handle

End Sub

SQL PARAMETERIZATION: Beyond protecting against SQL injection, parameterized queries are arguably more readable and maintainable as you separate data variables and SQL code to avoid syntax issues such as improper quotes or concatenation. Also, for INSERT queries, explicitly define columns for clarity.

With ADO, use the command object to define parameters and execute action.

' PREPARED STATEMENT (NO VBA CONCATENATED DATA)
SQL = "INSERT INTO Purchases.dbo.PODetails (Col1, Col2, Col3, Col4, Col5) VALUES (?, ?, ?, ?, ?)"

Dim cmd As Object
Const adCmdText = 1, adParamInput = 1, adInteger = 3, adDecimal = 14, adVarChar = 200

Set cmd = CreateObject("ADODB.Command")

With cmd
   .ActiveConnection = Conn
   .CommandText = SQL
   .CommandType = adCmdText

   ' DEFINE PARAMETERS (NO QUOTES OR AMPERSANDS)
   .Parameters.Append .CreateParameter("param1", adInteger, adParamInput, , Range("H12").Value)
   .Parameters.Append .CreateParameter("param2", adInteger, adParamInput, , Cells(RowCount, 1))
   .Parameters.Append .CreateParameter("param3", adInteger, adParamInput, , Cells(RowCount, 6))
   .Parameters.Append .CreateParameter("param4", adInteger, adParamInput, , Cells(RowCount, 7))
   .Parameters.Append .CreateParameter("param5", adInteger, adParamInput, , desc)
End With

' EXECUTE ACTION
cmd.Execute

Complete chaos in Excel VBS/SQL

1 Answers1