I need to load files eg excel, word etc documents to SQL Server 2008 so that they can be viewable/downloadable from a website. I need to be able to load and open the files from the access database and website.
Can anyone help, thank you.
Here is how I did it in an old project. You can strip away the progress bar stuff and some of the other stuff but you get the idea
Public Sub Upload_file_OLD(lMaterial_ID As Long, strFile_name As String)
'upload the file to the selected material ID.
Dim adStream As ADODB.Stream
Dim rst As ADODB.Recordset
On Error GoTo Error_trap
'check if we have an open connection, if we do use it
Select Case dbCon.State
Case adStateOpen
'connection is open, do nothing
Case adStateConnecting
'still conecting wait
Do Until dbCon.State = adStateOpen
Application.Echo True, "Connection to DB"
Loop
Case adStateClosed
'connection closed, try to open it
If Len(strSQL_con_string) = 0 Then
Set_SQL_con "MCTS"
End If
dbCon.ConnectionString = strSQL_con_string
dbCon.Provider = "sqloledb"
dbCon.Open
End Select
Me.acxProg_bar.Value = 0
Me.acxProg_bar.Visible = True
Me.Repaint
Set adStream = New ADODB.Stream
adStream.Type = adTypeBinary
adStream.Open
Me.acxProg_bar.Value = 10
Me.Repaint
adStream.LoadFromFile strFile_name
Me.acxProg_bar.Value = 50
Me.Repaint
Set rst = New ADODB.Recordset
rst.Open "SELECT Material_FS,Material_file_name, Material_size FROM tblMaterials WHERE Material_ID=" & lMaterial_ID, dbCon, adOpenKeyset, adLockOptimistic
Me.acxProg_bar.Value = 60
Me.Repaint
Me.txtFile_size = adStream.Size
rst.Fields("Material_FS").Value = adStream.Read
rst.Fields("Material_file_name").Value = GetFileName(strFile_name)
rst.Fields("Material_size").Value = adStream.Size
Me.acxProg_bar.Value = 90
Me.Repaint
rst.Update
rst.Close
dbCon.Close
Me.acxProg_bar.Value = 0
Me.acxProg_bar.Visible = False
Me.Repaint
Exit Sub
Error_trap:
If dbCon Is Nothing = False Then
If dbCon.State = adStateOpen Then dbCon.Close
End If
DoCmd.Hourglass False
MsgBox "An error happened in sub Upload_file, error description, " & Err.Description, vbCritical, "MCTS"
End Sub
I could not get the above code to work, but I did get this to work. SQL Server blob field is varbinary(max).
Upload:
Sub TestDocUpload()
Dim cmd As New ADODB.Command
Dim st As New ADODB.Stream
st.Type = adTypeBinary
st.Open
st.LoadFromFile "c:\temparea\18572.pdf"
With cmd
.CommandText = "Insert into tbldocuments(docblob, doctype) values (?, ?)"
.CommandType = adCmdText
.Parameters.Append .CreateParameter("#P1", adLongVarBinary, adParamInput, st.Size, st.Read)
.Parameters.Append .CreateParameter("#P2", adVarChar, adParamInput, 50, "CustPO")
End With
If cnlocal.State = 0 Then OpenNewLocalConnection
cmd.ActiveConnection = cnlocal
cmd.Execute
End Sub
Retrieve:
Sub TestReadDoc()
Dim myblob() As Byte
Dim rs As New ADODB.Recordset
If cnlocal.State = 0 Then OpenNewLocalConnection
rs.Open "tblDocuments", cnlocal, adOpenForwardOnly, adLockReadOnly
rs.MoveFirst
myblob = rs!DocBlob
Open "c:\temparea\output.pdf" For Binary Access Write As 1
Put #1, , myblob
Close #1
End Sub
Related
I have a vbs script that's failing to finish loading a file before moving on to the next steps. I've been using this code for 2+ years so this is likely due to my poor code and error handling - If the SSIS package fails to fully load, the procedure should kick out and alert me - Can someone point me in the right direction to make sure this package fully loads or if it fails, truncate the stage table and try again?
The file can range from 50mb to 1.2Gb
'******************************
Sub ReloadTable(strTableName)
'******************************
Dim wsh
Set wsh = CreateObject("WScript.Shell")
Dim waitOnReturn
waitOnReturn = True
Dim windowStyle
windowStyle = 0
Dim errorCode
Dim DTEXECStatus
'Truncate the stage table
ExecOnSQL "TRUNCATE TABLE essstage." & strTableName
'Run the SSIS package and wait until complete
errorCode = wsh.Run("dtexec /File ""\\server.dev.local\Data\SSIS SQL16\" & strTableName & ".dtsx"" ", windowStyle, waitOnReturn)
If errorCode = 0 Then
DTEXECStatus = "Success! " & strTableName
'MsgBox "Success! " & strTableName
Else
'Should exit the sub if this fails and notify me
DTEXECStatus = "FAILED!! " & strTableName
Create_NOTICE_Email
MsgBox "Failed! " & strTableName
'It'd be better if this repeated the steps to clear/attempt to reload again but who knows how to do that
Exit Sub
'ML: Added this END to the script to see if it'll stop erroring out
End If
End Sub
'******************************
Sub ExecOnSQL(cmdTxt)
'******************************
Dim strConnSQL
strConnSQL = "Provider=SQLOLEDB; Server=SQLSERVER.dev.LOCAL; Database=goldmouse; Trusted_Connection=Yes"
'Open the connection to the database
Dim cn
Set cn = CreateObject("ADODB.Connection")
cn.Open strConnSQL
'Set the command
Dim cmd
Set cmd = CreateObject("ADODB.Command")
Set cmd.ActiveConnection = cn
'Set the record Set
Dim rs
Set rs = CreateObject("ADODB.recordSet")
'Prepare the command
cmd.CommandText = cmdTxt
cmd.CommandType = 1 'adCmdText
cmd.CommandTimeout = 3000 '50 minutes
'cmd.CommandType = 4 'adCmdStoredProc
'Execute the command
Set rs = cmd.Execute
Set cmd = Nothing
'Close connections
cn.Close
Set cn = Nothing
End Sub
I have gone through a few tutorials already and my connection keeps failing, I have tried a lot of different ways of connecting.
I have a connection to mySQL through the mySQL workbench. I am using the IP address and the Port number and then my credentials to login. This works well and I am able to do the queries I need.
I am now trying to access this database through Excel, preferably through VBA. I tried to create a new connection but nothing I do seems to work. I am not sure what to put into my strConn string.
I am currently using:
Options Explicit
Private Sub CommandButton2_Click()
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim strConn As String
Set cn = New ADODB.Connection
strConn = "DRIVER={MySQL ODBC 5.3.7 Driver};" & _
"SERVER=XXX.XXX.X.X;" & _
"PORT=3306" & _
"DATABASE=cahier_de_lab;" & _
"UID=xxx;" & _
"PWD=xxx;" & _
"Option=3"
cn.Open strConn
' Find out if the attempt to connect worked.
If cn.State = adStateOpen Then
MsgBox "Welcome to Pubs!"
Else
MsgBox "Sorry. No Pubs today."
End If
' Close the connection.
cn.Close
End Sub
Thanks for your help!
Export from Excel to SQL Server.
Sub InsertInto()
'Declare some variables
Dim cnn As adodb.Connection
Dim cmd As adodb.Command
Dim strSQL As String
'Create a new Connection object
Set cnn = New adodb.Connection
'Set the connection string
cnn.ConnectionString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=True;Initial Catalog=Northwind;Data Source=Excel-PC\SQLEXPRESS"
'cnn.ConnectionString = "DRIVER=SQL Server;SERVER=Excel-PC\SQLEXPRESS;DATABASE=Northwind;Trusted_Connection=Yes"
'Create a new Command object
Set cmd = New adodb.Command
'Open the Connection to the database
cnn.Open
'Associate the command with the connection
cmd.ActiveConnection = cnn
'Tell the Command we are giving it a bit of SQL to run, not a stored procedure
cmd.CommandType = adCmdText
'Create the SQL
strSQL = "UPDATE TBL SET JOIN_DT = '2013-01-22' WHERE EMPID = 2"
'Pass the SQL to the Command object
cmd.CommandText = strSQL
'Execute the bit of SQL to update the database
cmd.Execute
'Close the connection again
cnn.Close
'Remove the objects
Set cmd = Nothing
Set cnn = Nothing
End Sub
OR . . . .
Import from SQL Server into Excel . . . . .
Sub Create_Connectionstring()
Dim objDL As MSDASC.DataLinks
Dim cnt As ADODB.Connection
Dim stConnect As String 'Instantiate the objects.
Set objDL = New MSDASC.DataLinks
Set cnt = New ADODB.Connection
On Error GoTo Error_Handling 'Show the Data-link wizard
stConnect = objDL.PromptNew 'Test the connection.
cnt.Open stConnect 'Print the string to the VBE Immediate Window.
Debug.Print stConnect 'Release the objects from memory.
exitHere:
cnt.Close
Set cnt = Nothing
Set objDL = Nothing
Exit Sub
Error_Handling: 'If the user cancel the operation.
If Err.Number = 91 Then
Resume exitHere
End If
End Sub
My apologies for the description, I have no idea how to name it properly
I have a few stored procedures (running on SQL2000) that provide me XML data as output. This all works fine and as expected, and I am using a VB module within my DTS to export and store the data. The reduced version of this file is as follows
set objStream = CreateObject( "ADODB.Stream" )
set objXML = CreateObject( "MSXML2.DOMDocument" )
set objConn = CreateObject( "ADODB.Connection" )
objConn.ConnectionTimeout = 3600
objConn.CommandTimeOut = 0
ObjConn.open(DTSGlobalVariables("ConnStringConso").Value)
set objComm = CreateObject( "ADODB.Command" )
objComm.ActiveConnection = objConn
objComm.CommandType = adCmdStoredProc
'Create the Stream object
set objStream = CreateObject( "ADODB.Stream" )
objStream.Open
objComm.Properties( "Output Stream" ) = objStream
' Execute the command
objComm.CommandText = "my_stored_procedure"
objComm.CommandTimeout = 3600
objComm.Execute ,, adExecuteStream
' Read the info returned adding the header and footer info
objStream.Position = 0
objXML.LoadXML("<?xml version='1.0'?>" & objStream.ReadText)
' Create the output XML file
xmlfile = filePath & "myfile.xml"
objXML.save( xmlfile )
So basically what this does is call the procedure, store the output in a stream and save the file, fairly straightforward and up till here no issue.
However, I would also need to be able to do this from my access front end, with VBA. So calling the procedure, wrapping the content and saving it as an XML file. Unfortunately my VBA knowledge is a bit rusty...
This is what I currently have :
Dim cnn As ADODB.Connection
Dim cmd As New ADODB.Command, rs As New ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.ConnectionString = "DRIVER=SQL Server;SERVER=myserver;DATABASE=myDatabase;uid=myID;pwd=myPW;Trusted_Connection=Yes"
cnn.Open cnn.ConnectionString
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cnn
.CommandType = adCmdStoredProc
.CommandText = "my_stored_procedure"
End With
rs.CursorType = adOpenStatic
rs.CursorLocation = adUseClient
rs.LockType = adLockOptimistic
rs.Open cmd
Debug.Print rs(0)
so far so good, I can open the procedure, I get data returned, but that's where my luck ends. The returned data seems to be limited to a certain number of characters (around 2000) and I'm struggling to save it as I want.
I tried below for quick and dirty test, but it appears to screw up my XML (all my attributes are suddenly double-double quoted) and as stated only a part of the content is exported, so any advice on how to do it properly would be highly appreciated
Dim myFile As String
myFile = "d:\output.xml"
Open myFile For Output As #1
Write #1, rs(0)
Close #1
Never mind, I found it myself in the meantime. I had 2 issues, the VBA ADODB works different as the VB variant, and as I was using FOR XML on my SQL Query the output apperantly was chopped in different rows. Hence why I only had partial output. Fiddling a bit with the streaming part in VBA and going through all records made it work. Not too sure this is the most optimal way so if there are ways to improve I'd be interested to know.
Dim cmd As New ADODB.Command, rs As New ADODB.Recordset
Dim cnn As ADODB.Connection
Set cnn = New ADODB.Connection
cnn.ConnectionString = "DRIVER=SQL Server;SERVER=myServer;DATABASE=myDB;uid=myID;pwd=myPW;Trusted_Connection=Yes"
cnn.Open cnn.ConnectionString
Set cmd = New ADODB.Command
With cmd
.ActiveConnection = cnn
.CommandType = adCmdStoredProc
.CommandText = myProc
End With
rs.CursorType = adOpenStatic
rs.CursorLocation = adUseClient
rs.LockType = adLockOptimistic
rs.Open cmd
Dim myXML As Variant
If Not (rs.EOF And rs.BOF) Then
rs.MoveFirst
Do Until rs.EOF = True
myXML = myXML & rs.Fields(0)
rs.MoveNext
Loop
End If
'Create the Stream object
Set objStream = CreateObject("ADODB.Stream")
With objStream
.Type = 2 'Text
.Charset = "utf-8"
.Open
.WriteText myXML
.SaveToFile (filePath & myXMLFile)
.Close
End With
I am trying to create a function that will check all the check boxes in a form with a
datasheet subform.
Since we moved to Office 2013 this code stopped working and it seems that moving to ADO is the only way.
Private Sub Toggle_Click()
Dim sfrm
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
sfrm = Me.Subform
Set cn = CurrentProject.Connection
'Dim rs As DAO.Recordset
'Set rs = Me.Subform.Form.RecordsetClone
rs.Open Me.Recordset
If (theTop = 0) Then
Else
Me.Subform.Form.AllowAdditions = False
Dim i As Integer
If (theHeight = 0) Then
If (sfrm![Ready?] = -1) Then
sfrm![Ready?] = 0
sfrm![Timestamp] = Null
Else
sfrm![Ready?] = -1
sfrm![Timestamp] = Date
End If
Else
On Error Resume Next
For i = theTop To rs.RecordCount
'If (i = 1) Then
'Else
'End If
'rs.MoveLast
'Do While Not rs.BOF
If (sfrm![Ready?] = -1) Then
sfrm![Ready?] = 0
sfrm![Timestamp] = Null
Else
sfrm![Ready?] = -1
sfrm![Timestamp] = Date
End If
'Me.Subform.Form.Recordset.MoveNext
rs.MoveNext
'Debug.Print sfrm![Routing Number]
'Loop
Next
End If
Me.Subform.Form.AllowAdditions = True
End If
End Sub
it seems that moving to ADO is the only way
With Access 2013, DAO remains the preferred way to interact with Access database objects from within the Access application itself. In my opinion it would be wise for you to investigate why the previous DAO code is failing (and how you might fix it) before embarking on a wholesale conversion of DAO code to ADO.
I just did a test in Access 2013. With [ParentTable}
[ChildTable]
and a form like this
I could toggle the [Selected?] status of the current subform records with the following code:
Option Compare Database
Option Explicit
Private Sub cmdToggleChildren_Click()
Dim rst As DAO.Recordset
Set rst = Me.ChildSubform.Form.Recordset
If Not (rst.BOF And rst.EOF) Then
rst.MoveFirst
Do Until rst.EOF
rst.Edit
rst![Selected?] = Not rst![Selected?]
rst.Update
rst.MoveNext
Loop
End If
Set rst = Nothing
End Sub
I've finished creating a database and it works perfectly on my computer. I'm using access 2013 and in my VBA code I have written error handler for each function/sub which I use in most databases.
However the users that it is designed for have Access run-time 2007 and every time i run it on their machine i get an un-trapped error "Execution of this application has stopped due to a run-time error".
Code for the command button.
Option Compare Database
Private Sub Command0_Click()
Dim ErrorStep As String
DoCmd.SetWarnings False
'-------------------------------------------------------------------------------------
' Procedure : Command0_Click
' Author : Chris Sparkes
' Date : 13/08/2013
'-------------------------------------------------------------------------------------
ErrorStep = "1 - Cleansing Records"
DoCmd.OpenQuery "qry1_3"
DoCmd.OpenQuery "qry4-7"
DoCmd.OpenQuery "qry9"
Call ExcelOutputReport
Exit_Command0_Click:
On Error GoTo 0
Exit Sub
Command0_Click_Error:
MsgBox "Error in procedure Command0_Click of VBA Document."
GoTo Exit_Command0_Click
On Error GoTo 0
End Sub
Public Function ExcelOutputReport()
Dim ErrorStep As String
DoCmd.SetWarnings False
'---------------------------------------------------------------------------------------
' Procedure : ExcelOutputReport
' Author : Chris Sparkes
' Date : 13/08/2013
'---------------------------------------------------------------------------------------
ErrorStep = "1 - Cleansing Records"
Dim dbLocal As DAO.Database
Dim tbloutput As DAO.Recordset
'DAO Declarations
Dim objExcel As New Excel.Application
Dim objWorkbook As Excel.Workbook
Dim objWorksheet As Excel.Worksheet
Dim IntCurrTask As Integer
Dim blurb As String
Set dbLocal = CurrentDb()
Set tbloutput = dbLocal.OpenRecordset("tbl_output")
Set objExcel = CreateObject("Excel.Application")
Set objWorkbook = objExcel.Workbooks.Open("G:\Enliven Sales Report\Envliven_Report_Template_1.xls")
Set objWorksheet = objWorkbook.Worksheets("Enliven")
objExcel.Visible = True
objWorkbook.Windows(1).Visible = True
tbloutput.MoveFirst
IntCurrTask = 2
Do While Not tbloutput.EOF
With objWorksheet
.Cells(IntCurrTask, 1).Value = tbloutput![CustomerOrderCode]
.Cells(IntCurrTask, 2).Value = tbloutput![CustomerCode]
.Cells(IntCurrTask, 3).Value = tbloutput![CustomerDescription]
.Cells(IntCurrTask, 4).Value = tbloutput![ItemCode]
.Cells(IntCurrTask, 5).Value = tbloutput![ItemDescription]
.Cells(IntCurrTask, 6).Value = tbloutput![DateOrderPlaced]
.Cells(IntCurrTask, 7).Value = tbloutput![CustomerDueDate]
.Cells(IntCurrTask, 8).Value = tbloutput![Quantity]
.Cells(IntCurrTask, 9).Value = tbloutput![ShippedQuantity]
End With
IntCurrTask = IntCurrTask + 1
tbloutput.MoveNext
Loop
tbloutput.Close
dbLocal.Close
DoCmd.SetWarnings True
Set tbloutput = Nothing
Set dbLocal = Nothing
Set objWorksheet = Nothing
Set objWorkbook = Nothing
Set objExcel = Nothing
Exit_ExcelOutputReport:
On Error GoTo 0
Exit Function
ExcelOutputReport_Error:
MsgBox "Error at in procedure ExcelOutputReport of VBA Document."
GoTo Exit_ExcelOutputReport
End Function
Has anyone got any ideas what may be causing this? The references should be fine as I'm using the same ones that I know have worked with different databases that I've made.
Thanks,
Chris
You have added error routines, but you did not activate them. At the beginning of your methods, add an On Error Goto statement:
Private Sub Command0_Click()
On Error Goto Command0_Click_Error
...
End Sub
Public Function ExcelOutputReport()
On Error Goto ExcelOutputReport_Error
...
End Sub
In your error routines, you should display (at least) the contents of Err.Description instead of a generic error message. Otherwise, you will have a really hard time tracking the source of errors. E.g.:
MsgBox "Error in procedure Command0_Click: " & Err.Description