I am trying to create a new table from a form. I need to have dynamic table name and dynamic field names. I have tried to change the strtablename to an object with no luck. I am getting an error 91. any help is appreciated.
Private Sub cmdNewTable_Click()
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim NewField As Field
Dim strNewTable As String
Dim objNewTable As Object
Dim x As Long
Dim y As Long
Dim strFieldName As String
Dim FieldTyoe As String
strNewTable = InputBox("Enter Table Name")
If strNewTable = vbNullString Then GoTo Skip:
'Create New Table
Set tdf = db.CreateTableDef(strNewTable)
y = InputBox("Enter amount of fields to add")
For x = 1 To y
With tdf
strFieldName = InputBox("Enter field Name")
strfieldType = InputBox("Enter Field Type 1-Text 2-Integer 3-Long 4-
Single 5-Double 6-Decimal 7-Date 8-Currency 9-Yes/No 10-Memo")
If strfieldType = 1 Then strfieldType = "dbText"
If strfieldType = 2 Then strfieldType = "dbInteger"
If strfieldType = 3 Then strfieldType = "dbLong"
If strfieldType = 4 Then strfieldType = "dbSingle"
If strfieldType = 5 Then strfieldType = "dbDouble"
If strfieldType = 6 Then strfieldType = "dbDecimal"
If strfieldType = 7 Then strfieldType = "dbDate"
If strfieldType = 8 Then strfieldType = "dbCurrency"
If strfieldType = 9 Then strfieldType = "dbBoolean"
If strfieldType = 10 Then strfieldType = "dbMemo"
Debug.Print strFieldName
Debug.Print strfieldType
Stop
.Fields.Append .CreateField(strFieldName, strfieldType)
End With
First check your declaration: Dim FieldTyoe As String
That's a typo. Make sure to use Option Explicit. Make it Dim strfieldType As String.
Then look at this: If strfieldType = 1
This is an illegal evaluation.
To fix, put the number in quotes:
If strfieldType = "1"
You end your With block, but I don't see Next x or End Sub. You need error handling here as well in case the user input is invalid. What if they use a reserved character or word?
Related
Given below is the working code. Previously I was using the .Name property that didn't work.
Previous code:
For Each s In rs.Fields
word = Replace(strArray(count), """", "")
count = count + 1
'the below line shows error
s.Name = word
Next
New Complete working code. It opens a dialog for user to select the .csv file and then imports all the data into the table from that csv file.
strMsg = "Select the file from which you want to import data"
mypath = GetPath(strMsg, True)
mypath = mypath
Dim strFilename As String: strFilename = mypath
Dim strTextLine As String
Dim strArray() As String
Dim count As Integer
Dim regex As New RegExp
regex.IgnoreCase = True
regex.Global = True
'This pattern matches only commas outside quotes
'Pattern = ",(?=([^"]*"[^"]*")*(?![^"]*"))"
regex.Pattern = ",(?=([^""]*""[^""]*"")*(?![^""]*""))"
Dim iFile As Integer: iFile = FreeFile
Open strFilename For Input As #iFile
Dim db As DAO.Database
Dim rs As DAO.Recordset
Set db = CurrentDb
count = 0
Do Until EOF(1)
Line Input #1, strTextLine
count = 0
'regex.replaces will replace the commas outside quotes with <???> and then the
'Split function will split the result based on our replacement
On Error GoTo ErrHandler
strTextLine = regex.Replace(strTextLine, "<???>")
strArray = Split(regex.Replace(strTextLine, "<???>"), "<???>")
Set rs = db("AIRLINES").OpenRecordset
Dim word As Variant
With rs
.AddNew
For Each s In rs.Fields
word = Replace(strArray(count), """", "")
count = count + 1
'the below line shows error
s.Value = word
Next
.Update
.Close
End With
lpp:
Loop
db.Close
Close #iFile
MsgBox ("Imported Successfully")
Exit Sub
ErrHandler:
Resume lpp
Don't use the Name property. Use Value.
How are you populating the array? If it has base index of 0, then increment Count after setting the field value.
I've been trying to write to my database and it's nearly complete the only problem Im having is with the radio values as there are two question asked within the webform both with a response of Yes or No. I found an example of this on stackover flow which was
Dim rbval As Integer
If RadioButton1.Checked Then
rbval = 1
Else
rbval = 2
End If
cmd.Parameters.Add(New SqlParameter("#ethics", SqlDbType.Int))
cmd.Parameters("#ethics").Value = rbval
But it didn't work and kept providing me with an error message and highlighting the cmd.ExecuteNonQuery section of the code. I then tried to play with it and put in:
Dim rbval As Integer
If RadYes0.Checked Then
rbval = 1
Else
rbval = 2
End If
cmd.Parameters.Add("#TeaAndCoffee", SqlDbType.Text).Value = RadYes0.Text
And it did work when I selected "Yes" but when I selected "No" the Yes value kept storing in the database and I can see where I went wrong from the code because its always going to select yes from the one I tried to fix. I was wondering if anyone had any suggestions? below is the full code
Dim Con As SqlConnection
Dim cmd As SqlCommand
Dim recordsAffected As String
Dim cmdstring As String = "INSERT [Event Table](EventTypeID, EventName, VenueName, NumberOfGuests, Date, ClientAddress, WeddingName, BuildingAddress, Canapes, Starter, MainCourse, Dessert, TeaAndCoffee) Values(#EventTypeID, #EventName, #VenueName, #NumberOfGuests, #Date, #ClientAddress, #WeddingName, #BuildingAddress, #Canapes, #Starter, #MainCourse, #Dessert, #TeaAndCoffee)"
Con = New SqlConnection("Data Source=.\SQLEXPRESS;AttachDbFilename=|DataDirectory|\YellowDoor.mdf;Integrated Security=True;User Instance=True")
cmd = New SqlCommand(cmdstring, Con)
cmd.Parameters.Add("#EventTypeID", SqlDbType.Text).Value = EventTypeDD.SelectedValue
cmd.Parameters.Add("#EventName", SqlDbType.Text).Value = EventNametxt.Text
cmd.Parameters.Add("#VenueName", SqlDbType.Text).Value = VenueLoDD.SelectedValue
cmd.Parameters.Add("#NumberOfGuests", SqlDbType.Int).Value = CInt(NumOfGtxt.Text)
cmd.Parameters.Add("#Date", SqlDbType.Int).Value = CInt(DateTxt.Text)
cmd.Parameters.Add("#ClientAddress", SqlDbType.Text).Value = txtAddress.Text
cmd.Parameters.Add("#WeddingName", SqlDbType.Text).Value = txtWedding.Text
cmd.Parameters.Add("#BuildingAddress", SqlDbType.Text).Value = txtBAddress.Text
cmd.Parameters.Add("#Canapes", SqlDbType.Text).Value = txtCanapes.Text
cmd.Parameters.Add("#Starter", SqlDbType.Text).Value = txtStarter.Text
cmd.Parameters.Add("#MainCourse", SqlDbType.Text).Value = txtMainCourse.Text
cmd.Parameters.Add("#Dessert", SqlDbType.Text).Value = txtDessert.Text
Dim rbval As Integer
If RadYes0.Checked Then
rbval = 1
Else
rbval = 2
End If
cmd.Parameters.Add("#TeaAndCoffee", SqlDbType.Text).Value = RadYes0.Text
Con.Open()
recordsAffected = cmd.ExecuteNonQuery
Con.Close()
Response.Redirect("MenuForm.aspx")
End Sub
Look at your table column type in your SQL database. If it's a bit (the most logic way) it's as simple as a pie:
cmd.Parameters.Add("#Yourparam", SqlDbType.Bit).Value = IIf (Radyes0.Checked,1,0)
For Char type:
cmd.Parameters.Add("#Yourparam", SqlDbType.Char).Value = IIf (Radyes0.Checked,"Y","N")
For NVarchar type:
cmd.Parameters.Add("#Yourparam", SqlDbType.Nvarchar).Value = IIf (Radyes0.Checked,"Yes","No")
A simple look at your table design will tell you whichever sentence you need. Use always the same datatype of your database.
By the way: The reason because this example
Dim rbval As Integer
If RadYes0.Checked Then
rbval = 1
Else
rbval = 2
End If
cmd.Parameters.Add("#TeaAndCoffee", SqlDbType.Text).Value = RadYes0.Text
Always saved Yes to your database, is because radiobutton.text gives the text label of the radiobutton, I believe you had a radiobutton for yes and a radiobutton for no, right?
Please forgive the sloppy coding, but I was thrown onto a project to get data from a spreadsheet to SQL server and the deadline has been missed. I was able to initial get my first dataswipe using a SELECT statement, but I can't seem to switch it over to an UPDATE.
Here's the code. I get the runtime error 3704 operation not allowed when object is closed at the line rstRecordset.AddNew
Public cnnConn As ADODB.Connection
Public rstRecordset As ADODB.Recordset
Public cmdCommand As ADODB.Command
Public Const Server As String = "datguy"
Public SQLQuery As String
Option Explicit
Sub testupinsertupdate()
Dim wkb As Workbook
Dim wks As Worksheet
Dim sel As Range
Set wkb = ActiveWorkbook
Set wks = Sheets(1)
Set sel = Selection
With wks
'Declaration unit
Dim dataitem As String
Dim yr As Integer
Dim yrmax As Integer
Dim rxcount As Integer
Dim row As Integer
Dim col As String
Dim cleanup As String
Dim sqlrxcount As String
dataitem = .Range("B3").Value
yr = 6 'data only needs to go back to 2006
yrmax = .Range("C7").End(xlToRight).row + yr 'declarative count to the Right-Of-File
rxcount = 7
row = .Range("A" & .Rows.Count).End(xlUp).row 'declarative count to EOF
col = .Range("C6").End(xlToRight).Column
cleanup = "Data Unavailable"
sqlrxcount = .Range("A" & rxcount).Value
Set cnnConn = New ADODB.Connection
cnnConn.ConnectionString = "driver={SQL Server};server=" & Server & ";database=database;Trusted_Connection=Yes"
cnnConn.ConnectionTimeout = 800
cnnConn.Open
For rxcount = 7 To row
Set cmdCommand = New ADODB.Command
Set cmdCommand.ActiveConnection = cnnConn
With cmdCommand
.CommandTimeout = 0
.CommandText = "UPDATE table SET " & dataitem & " = '" & Cells(col).Value & "' WHERE RX_ID = '" & sqlrxcount & "'"
.CommandType = adCmdText
.Execute
Debug.Print cmdCommand.State
End With
Debug.Print cmdCommand.State
Set rstRecordset = New ADODB.Recordset
Set rstRecordset.ActiveConnection = cnnConn
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
col = ("C" & rxcount)
For yr = 6 To yrmax
rstRecordset.AddNew '*** error pops!
rstRecordset.Fields("RX_ID") = Range("A" & rxcount).Value
rstRecordset.Fields("YEAR_REPORTED") = yr + 2000
If Range(col).Value = cleanup Then
rstRecordset.Fields(dataitem) = Null
Else: rstRecordset.Fields(dataitem) = Range(col).Value
End If
'debug line to show results
Debug.Print Range("A" & rxcount).Value, yr + 2000, Range(col).Value
col = Range(col).Offset(0, 1).Address
Next yr
Next rxcount
rstRecordset.UpdateBatch
rstRecordset.Close
cnnConn.Close
End With
End Sub
I don't feel like I'm doing the operations in order, but I'm just trying to get the initial load and then will worry about maintenance later. Why isn't the object(I assume this is the recordset) open when it was opened three lines before?
You are attempting to open a recordset based on an update not a select
rstRecordset.Open cmdCommand, , adOpenStatic, adLockBatchOptimistic
should be something like
rstRecordset.Open "select * from table",cnnconn, adOpenStatic, adLockBatchOptimistic
How do I change 12 and 13 to fill in with 'ARCH' and 14 to 36 to fill in with 'ENVD'? This goes on with over 4000 subjects, and 10000 rows changing at random times. How can I tell ms access to write some letters until it sees a new set of letter, then write those until it sees a new set?
IF you have an autonumber field, it can be done simpler. for now I assume you don't have an AutoNumber field and have done it with a reading one record at a time.
You have to change the tblname to your actual table name on line 8th
Sub test()
Dim cn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim sql As String
Dim val As String
Set cn = CurrentProject.Connection
rs.CursorLocation = adUseClient
sql = "SELECT * FROM tblname"
rs.Open sql, cn, adOpenDynamic, adLockOptimistic
With rs
If Not .EOF Then
val = !field3
.MoveNext
Do
If !field3 = "" Then
!field3 = val
.Update
Else
val = !field3
End If
.MoveNext
Loop Until .EOF
End If
End With
End Sub
Anybody have some VBA code that will store a byte array into a MySQL blob column?
Here is some code. Requires a reference to Microsoft Active Data Objects 2.x Library. It uses the OLE DB provider for MySQL (Might need to install that on the client machine).
Sub StoreBLOB(data() As Byte, key As Double)
'stores the BLOB byte array into the row identified by the key
'requires reference to Microsoft Active Data Objects 2.x Library
On Error GoTo handler:
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim conStr As String
Dim strSQL As String
'have it return only the record you want to store your blob
strSQL = strSQL & "SELECT * FROM YOURTABLE WHERE KEY = " & key
'setup connection
conStr = conStr & "Provider=MySQLProv;"
conStr = conStr & "Data Source=mydb;"
conStr = conStr & "User Id=myUsername;"
conStr = conStr & "Password=myPassword;"
con.ConnectionString = conStr
con.Open
rs.Open strSQL, con, adOpenDynamic, adLockOptimistic
If rs.RecordCount > 1 Then
Err.Raise 1001, "StoreBLOB", "Too many records returned from dataset. Check to make sure you have the right key value"
Else
Err.Raise 1002, "StoreBLOB", "No Records found that match the key"
End If
rs.Fields("BLOBFIELDNAME").Value = data
rs.Update 'store the contents to the database
rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
Exit Sub
handler:
Err.Raise 1003, "StoreBLOB", "Unexpected Error in StoreBLOB. Check that server is running"
End Sub
Assuming you are using ADO to access mysql, there's a KB article on the subject.
I have some code, I replicated the mysql_real_escape_string_quote C function in VBA so that one can escape the necessary characters and build your SQL as you would for regular text:
Function mysql_real_escape_string_quote(toStr() As Byte, fromStr() As Byte, length As Long, quote As String) As Long
mysql_real_escape_string_quote = 0
Dim CharMap() As Byte: CharMap = StrConv(String(256, 0), vbFromUnicode)
CharMap(0) = Asc("0"): CharMap(39) = Asc("'"): CharMap(34) = Asc(""""): CharMap(8) = Asc("b"): CharMap(10) = Asc("n"): CharMap(13) = Asc("r"):
CharMap(9) = Asc("t"): CharMap(26) = Asc("z"): CharMap(92) = Asc("\"): CharMap(37) = Asc("%"): CharMap(95) = Asc("_"):
Dim i As Long: Dim n As Long: n = 0
If length > UBound(fromStr) + 1 Then Exit Function
For i = 0 To length - 1 '---count escapable chars before redim---
n = n + 1
If CharMap(fromStr(i)) <> 0 Then n = n + 1
Next i
ReDim toStr(n - 1) As Byte
n = 0
For i = 0 To length - 1 '---test chars---
If CharMap(fromStr(i)) = 0 Then
toStr(n) = fromStr(i)
Else '---escape char---
toStr(n) = Asc(quote): n = n + 1
toStr(n) = CharMap(fromStr(i))
End If
n = n + 1
Next i
mysql_real_escape_string_quote = n
End Function
Function mysql_real_escape_string(InputString As String) As String
mysql_real_escape_string = ""
Dim toStr() As Byte: Dim fromStr() As Byte
fromStr = StrToChar(InputString)
If mysql_real_escape_string_quote(toStr, fromStr, UBound(fromStr) + 1, "\") = 0 Then Exit Function
mysql_real_escape_string = StrConv(toStr(), vbUnicode)
End Function
Function StrToChar(str As String) As Byte()
Dim ans() As Byte
ans = StrConv(str, vbFromUnicode)
ReDim Preserve ans(Len(str)) As Byte
ans(Len(str)) = 0
StrToChar = ans
End Function
Sub testit()
Dim toStr() As Byte: Dim fromStr() As Byte
fromStr = StrToChar("hello world's")
MsgBox (mysql_real_escape_string_quote(toStr, fromStr, UBound(fromStr) + 1, "\"))
MsgBox (mysql_real_escape_string("hello world's"))
For i = 0 To UBound(toStr)
Debug.Print i & " " & toStr(i)
Next i
End Sub
It's been optimized for large amounts of data without a ridiculous amount of conditionals (ifs).