sql - Excel VBS/SQL 完全混乱

Question

好的，所以在我之前的问题中，我遇到了随机语法错误的问题。事实证明，代码要糟糕得多，但充满了似乎相同的语法。

我“继承”了这段代码并且对如何修复它一无所知。我是 SQL 的新手，但我显然对学习很感兴趣。在这一点上，我可能会为一个简单的解决方案付费。

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 = "[e-mail]"
emailObj.To = "[e-mail]"
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

我为大量的代码道歉，如果有人知道更好的方法，请告诉我。SMSS 对我大喊大叫。:(

标签： sqlsql-serverexcelvba

Answer 1

虽然我没有深入研究您的代码以查找特定问题，但请考虑两种最佳实践方法来帮助您定位和解决语法问题。

1. 完整的错误处理：将所有例程包装在错误处理中，以在运行时引发异常和错误。此外，合并将显示 TSQL 语法失败的特定行的DBEngine 错误。

   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
   

2. SQL PARAMETERIZATION：除了防止 SQL 注入之外，参数化查询可以说更具可读性和可维护性，因为您将数据变量和 SQL 代码分开以避免语法问题，例如不正确的引号或连接。此外，对于INSERT查询，为清楚起见显式定义列。

   使用 ADO，使用命令对象来定义参数和执行动作。

   ' 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