My Access database is split into back and front-end.
I have created an Access form in the front-end that contains a textBox, a Browser button and a Relink button.
When I click Browse, file manager pops up to choose my .mdb file. After the file is choosen, the path to the file is displayed into the textBox.
What I want is when I press Relink button, it should take the path from textBox and link my back-end file to my front end.
Here is my code so far:
'browse button
Private Sub browseBtn_Click()
Dim objDialog As Object
set objDialog = Application.FileDialog(3)
With objDialog
.show
.AllowMultiSelect = False
If .SelectedItems.Count = 1 Then
'textFiled displays the path
Me.textField = .SelectedItems(1)
End If
End With
End Sub
'relink button
Private Sub linkBtn_Click()
Dim newConnection As String
Dim currentPath As String
currentPath = Me.textField
Dim tblDef As TableDef
tblDef.Connect = newConnection
tblDef.RefreshLink
End Sub
What is wrong with this?
I've figure it out in the end, here is the full code:
Private Sub browseBtn_Click()
Dim objDialog As Object
Set objDialog = Application.FileDialog(3)
With objDialog
.title = "Please select the backend file"
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 1 Then
Me.textField = .SelectedItems(1)
End If
End With
End Sub
Private Sub linkBtn_Click()
RefreshLinks (Me.textField)
End Sub
Public Function RefreshLinks(strFilename As String)
Dim dbs As dao.Database
Dim tdf As TableDef
Set dbs = CurrentDb
For Each tdf In dbs.TableDefs
If Len(tdf.Connect) > 0 Then
tdf.Connect = ";DATABASE=" & strFilename
Err = 0
On Error Resume Next
tdf.refreshlink
If Err <> 0 Then
RefreshLinks = False
Exit Function
End If
End If
Next tdf
RefreshLinks = True
End Function
Related
A few issues: Script is linked to a form ctrl button that runs Update Data every minute. This runs Copy Data and copies row A39:T39 and pastes that row in the other sheet. That is the intent. But it doesn't paste right. Need to past in a row not a column starting w/ a time stamp on the other sheet in A2. Stop Recording Data is linked to a form ctrl button to cancel Update Data but that doesn't work either.
Sub UpdateData()
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData"
CopyData
End Sub
Sub CopyData()
Dim sht1 As Worksheet, sht2 As Worksheet, cpyRng As Range, logRng As Long
Application.StatusBar = "Recording Dashboard Started"
Set sht1 = ThisWorkbook.Sheets("Dashboard")
Set sht2 = ThisWorkbook.Sheets("Log")
Set cpyRng = sht1.Range("A39:T39")
logRng = sht2.Cells(2, Columns.Count).End(xlToLeft).Column + 1
sht2.Range("A2") = Now
cpyRng.Copy sht2.Cells(2, logRng)
End Sub
Sub StopRecordingData()
Application.StatusBar = "Recording Dashboard Stopped"
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData", False
End Sub
Put this code into an own module.
To start logging, call StartRecordingData()
and for stopping call StopRecordingData()
Option Explicit
Dim boolLoggingActive As Boolean
Public Sub StartRecordingData()
Application.StatusBar = "Recording Dashboard Started"
boolLoggingActive = True
UpdateData
End Sub
Public Sub StopRecordingData()
Application.StatusBar = "Recording Dashboard Stopped"
boolLoggingActive = False
End Sub
Private Sub UpdateData()
If boolLoggingActive = True Then
Application.OnTime Now + TimeValue("00:01:00"), "UpdateData"
CopyData
End If
End Sub
Private Sub CopyData()
Dim sht1 As Worksheet, sht2 As Worksheet, cpyRng As Range, logRng As Long
Application.StatusBar = "Recording Dashboard Started"
Set sht1 = ThisWorkbook.Sheets("Dashboard")
Set sht2 = ThisWorkbook.Sheets("Log")
Set cpyRng = sht1.Range("A39:T39")
Dim rngLogTargetBeginningCell As Range
Set rngLogTargetBeginningCell = sht2.Rows(sht2.Rows.Count).Columns(1).End(xlUp).Offset(1, 0)
rngLogTargetBeginningCell = Now
Dim rngLastCellSelection As Range
Application.ScreenUpdating = False ' Stop Updating Graphic during data copy
Set rngLastCellSelection = Selection ' remember the last selection because pasting will change the active cell
cpyRng.Copy
rngLogTargetBeginningCell.Offset(0, 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False ' Remove the copy area marker
rngLastCellSelection.Select ' reselect the old cell
Application.ScreenUpdating = True ' update graphics again
End Sub
So, this is my interface:
This is my UserControl:
TextBox = Text1 / ComboBox = cmbAddExample
This is the code from UserControl:
Option Explicit
Dim cnn As Connection
Dim rs As Recordset
Dim sql As Command
Private Sub UserControl_Initialize()
Set rs = New Recordset
rs.CursorLocation = adUseServer
Call IniciarConexion
CargaIDTipoNumero
End Sub
Public Property Get AddType() As String
AddType = cmbAddExample.Text
End Property
Public Property Let AddType(ByVal Value As String)
cmbAddExample.Text = Value
End Property
Public Property Get AddNumber() As String
AddNumber = Text1.Text
End Property
Public Property Let AddNumber(ByVal Value As String)
Text1.Text = Value
End Property
Private Sub CargaIDTipoNumero()
cmbAddExample.Clear
rs.Open "SELECT idTipo, tipo FROM tipo_Numero", cnn, adOpenDynamic, adLockOptimistic
Do While rs.EOF = False
cmbAddExample.AddItem rs!tipo
cmbAddExample.ItemData(cmbAddExample.NewIndex) = rs!idTipo
rs.MoveNext
Loop
rs.Close
End Sub
Private Sub IniciarConexion()
Set cnn = New ADODB.Connection
With cnn
.CursorLocation = adUseClient
.Open "PROVIDER=MSDASQL;driver={SQL Server};server=server;uid=uid;pwd=pwd;database=database;"
End With
End Sub
In my form, I have these methods to connect and load data from SQLServer:
Private Sub Form_Load()
Set rs = New Recordset
rs.CursorLocation = adUseServer
Picture1.Visible = False
Call IniciarConexion
CargaIDTipoNumero
End Sub
Private Sub IniciarConexion()
Set cnn = New ADODB.Connection
With cnn
.CursorLocation = adUseClient
.Open "PROVIDER=MSDASQL;driver={SQL Server};server=server;uid=uid;pwd=pwd;database=database;"
End With
End Sub
Private Sub CargaIDTipoNumero()
cmbAddExample(indice).Clear
rs.Open "SELECT idTipo, tipo FROM tipo_Numero", cnn, adOpenDynamic, adLockOptimistic
Do While rs.EOF = False
cmbAddExample(indice).AddItem rs!tipo
cmbAddExample(indice).ItemData(cmbAddExample(indice).NewIndex) = rs!idTipo
rs.MoveNext
Loop
rs.Close
End Sub
So, the problem is as follows:
compilation error sub or function not defined
in line: cmbAddExample(indice).Clear
Finally, I have a "Guardar" button that saves the data in SQLServer:
Private Sub btnGuardar_Click()
Dim i As Integer
Dim id As Integer
Dim CM As ADODB.Command
For i = 0 To indice
id = cmbAddExample(i).ItemData(cmbAddExample(i).ListIndex)
Set CM = New ADODB.Command
Set CM.ActiveConnection = cnn
CM.CommandType = adCmdText
CM.CommandText = "INSERT INTO ejemplo (combo,nombre) VALUES (?,?)"
CM.Parameters.Append CM.CreateParameter("#txt", adInteger, , , id)
CM.Parameters.Append CM.CreateParameter("#comboDos", adInteger, , , Text1(i).Text)
CM.Execute , , adExecuteNoRecords
Next
End Sub
How do I load the ComboBox with the SQLServer data?
And how do I save them?
To load a combo inside a UserControl and later save the selection, I would add additional methods and properties to the UserControl:
Public Sub LoadAddType(ByVal Data As ADODB.Recordset)
cmbAddType.Clear
Data.MoveFirst
Do While Not Data.EOF
cmbAddType.AddItem Data!tipo
cmbAddType.ItemData(cmbAddType.NewIndex) = Data!idTipo
Data.MoveNext
Loop
End Sub
Public Sub LoadAddType2()
***or this could be in UserControl_Initialize()
cmbAddType.Clear
cmbAddType.AddItem "celular"
cmbAddType.AddItem "option2"
End Sub
Public Property Get AddTypeID() As Integer
AddTypeID = cmbAddType.ItemData(cmbAddType.ListIndex)
End Property
Keeping all the database connection and querying on the main form, you could then initialize your UserControls like this:
Private Sub Form_Load()
uc1(0).LoadAddType rs
End Sub
And every time you add a UserControl:
Private Sub btnAdd_Click()
uc1(indice).LoadAddType rs
End Sub
To save user selections, the general idea would be:
Private Sub btnGuardar_Click()
Dim i As Integer
Dim id As Integer
Dim sel As String
Dim CM As ADODB.Command
For i = 0 To indice
id = uc1(i).AddTypeID
sel = uc1(i).AddType
***with the retrieved data, build your CM object
Next
End Sub
Hello,
I need to find a way to import new data into a database which comprises of a SQL Server back end and an MS Access 2010 front end with linked tables to the back end, from the front end.
Ideally, this would involve a user clicking a button on a form in the front end and selecting an excel spreadsheet with new data to import, which would then be saved in the back end SQL Server tables.
I have created a vba module in the Excel spreadsheet I want to import. The code is:
Public Function ExcelPicker(Optional strFileName As String, _
Optional ByVal strWindowTitle As String = "Select an excel file") As String
Dim fd As Office.FileDialog
'Set fd = Application.FileDialog(msoFileDialogFolderPicker)
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = strWindowTitle
.Filters.Add "All files", "*.*", 1
.Filters.Add "Excel Workbooks", "*.xls;*.xlsx;*.xlsm", 2
.AllowMultiSelect = False
If .Show = -1 Then
FilePicker = (.SelectedItems(1))
Else
FilePicker = vbNullString
End If
End With
Set fd = Nothing
End Function
I have then created an import button on the MS Access 2010 front end, and in the OnClick event I have entered the code:
Private Sub cmdImportFilterResults_Click()
Dim sExcelFile As String
Set sExcelFile = Application.FileDialog(msoFileDialogFilePicker)
'' if sExcelFile is not blank then
'' import the file to MSSQL linked table
If sExcelFile <> "" Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "[Database].Table_Result", sExcelFile, True
End If
End Sub
However, when I click on the import button in the front end, nothing is happening. What is wrong in my code or my solution?
Here's a working example:
Private Sub cmdImportFilterResults_Click()
Dim strWindowTitle As String
Dim objDialog As Object
Dim sExcelFile As String
strWindowTitle = "Select an excel file"
Set objDialog = Application.FileDialog(msoFileDialogFilePicker)
With objDialog
.Title = strWindowTitle
.Filters.Add "Excel Workbooks", "*.xls;*.xlsx;*.xlsm", 1
.AllowMultiSelect = False
.Show
If .SelectedItems.Count = 0 Then
MsgBox "No File Selected."
Else
sExcelFile = Dir(.SelectedItems(1))
End If
End With
' if sExcelFile is not blank then
' import the file to MSSQL linked table
If sExcelFile <> "" Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12Xml, "[Database].Table_Result", sExcelFile, True
End If
End Sub
I am new in Access been trying this for over 3days now. im tyingin to create a module or anything that when a press a button from a form the module will show a file dialog. get the .txt file and insert it into a table
here is how far i have got
Private Sub FileUpload()
'Requires reference to Microsoft Office 12.0 Object Library.
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Const MyFile = "TXT_Import_Spec" 'change to suit
'Clear listbox contents.
'Me.FileList.RowSource = ""
'Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
'Allow user to make multiple selections in dialog box.
.AllowMultiSelect = False
'Set the title of the dialog box.
.Title = "Please choose FM16 text files"
'Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add ".txt FM16 Files", "*.TXT"
.Show
obJaces
'Import Myfile
DoCmd.TransferText acImportDelim, "TXT_Import_Spec", "DM1", "MyFile", False
'Delete old records from Tbl_Import
'CurrentDb.Execute "DELETE * FROM DM1"
'Add new records to Tbl_Import
CurrentDb.Execute "INSERT INTO DM1 SELECT * FROM MyFile WHERE MyFile.JobNo IN (SELECT MyFile.JobNo FROM MyFile LEFT JOIN Tbl_Import ON MyFile.JobNo = Tbl_Import.JobNo WHERE Tbl_Import.JobNo Is Null)"
'Delete Myfile Table
CurrentDb.Execute "DROP TABLE MyFile"
End With
End Sub
been a stress full week. will appreciate any help.
#DonGeorge I have manage to get the script working please check the script below but the problem is its taking for ever. because the txt file has like 900,000 records.
so what i did to avoid overflow error is the script to show notification in every 100,000 records uploaded. but that takes like 5 mins for a good computer.
Option Compare Database
Sub uploadData()
On Error GoTo 11:
Dim strFile As String
Dim db As DAO.Database
Dim rs1 As DAO.Recordset
Dim cnt As Double
strFile = GetFile
If strFile <> "" Then
Set db = CurrentDb()
Set rs1 = db.OpenRecordset("BM1")
Dim firstLine As Boolean
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFile)
firstLine = False
msg = MsgBox("Do you want to delete all records from BM1 before loading ?", vbCritical + vbYesNo, "Upload File")
If msg = vbYes Then
DoCmd.SetWarnings False
DoCmd.RunSQL "delete * from BM1"
DoCmd.SetWarnings True
End If
Do Until objFile.AtEndOfStream
strEmployee = objFile.ReadLine
If firstLine = True Then
arrEmployee = Split(strEmployee, ",")
If UBound(arrEmployee) = 20 Then
rs1.AddNew
For i = 0 To rs1.Fields.Count - 1
rs1.Fields(i).Value = Replace(arrEmployee(i), """", "")
Next
rs1.Update
End If
Else
firstLine = True
End If
cnt = cnt + 1
If cnt Mod 100000 = 0 Then
MsgBox "Records Added " & cnt
End If
Loop
rs1.Close
MsgBox "Records Upload Completed"
End If
Exit Sub
11:
MsgBox Err.Description
End Sub
Function GetFile() As String
Dim f As Object
Set f = Application.FileDialog(3)
Dim varfile As Variant
f.AllowMultiSelect = False
f.Filters.Clear
f.Filters.Add "Text File", "*.txt"
f.Show
For Each varfile In f.selecteditems
GetFile = varfile
Exit For
Next varfile
End Function
I found this code here on StackOverflow:
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file to kill his non colored cells"
.Filters.Add "Excel", "*.xls"
.Filters.Add "All", "*.*"
If .Show = True Then
txtFileName = .SelectedItems(1)
End If
End With
I know this code should select a file in FileDialog.
However, once I have chosen the .xls file, how do I manipulate the file? In other words, where is my file object for me to manipulate?
I would like someone to continue this code to make some simple manipulation on the workbook so I could learn how to do those simple things on a workbook that I opened.
There are two approaches for you (I prefer using first one). In both approaches wb variable stores opened workbook. I commented code in details, but if you have some questions - ask:)
First approach:
Sub test1()
Dim xlFileName
Dim wb As Workbook
xlFileName = GetOpenFilename("Excel (*.xls*),*.xls*", 1, _
"Please select the file to kill his non colored cells")
'if user pressed CANCEL - exit sub
If xlFileName = False Then
MsgBox "User pressed CANCEL"
Exit Sub
End If
'Tries to open workbook with choosen file name
On Error Resume Next
Set wb = Application.Workbooks.Open(xlFileName)
On Error GoTo 0
'If we can't find workbook with choosen path, exit Sub
If wb Is Nothing Then
MsgBox "Can't find file"
Exit Sub
End If
'your code here
wb.Worksheets("Sheet1").Range("A1").Value = "test"
'close workbook with saving changes
wb.Close SaveChanges:=True
Set wb = Nothing
End Sub
Second approach:
Sub test()
Dim xlFileName As String
Dim fd As Office.FileDialog
Dim wb As Workbook
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.AllowMultiSelect = False
.Title = "Please select the file to kill his non colored cells"
.Filters.Add "Excel", "*.xls*"
.Filters.Add "All", "*.*"
If .Show Then
xlFileName = .SelectedItems(1)
Else
'if user pressed CANCEL - exit sub
MsgBox "User pressed CANCEL"
Exit Sub
End If
End With
'Tries to open workbook with choosen file name
On Error Resume Next
Set wb = Workbooks.Open(xlFileName)
On Error GoTo 0
'If we can't find workbook with choosen path, exit Sub
If wb Is Nothing Then
MsgBox "Can't find file"
Exit Sub
End If
'your code here
wb.Worksheets("Sheet1").Range("A1").Value = "test"
'close workbook with saving changes
wb.Close SaveChanges:=True
Set wb = Nothing
End Sub
Here's an example:
Dim wb As Workbook
Dim ws As Worksheet
Dim r As Range
Set wb = Workbooks.Open(txtfilename) ' the file path you selected in FileDialog
Set ws = wb.Worksheets(1)
Set r = ws.Cells(1, 1)
With r
.Value = "Hello world!"
.Interior.Color = RGB(255,20,20) 'bright red
End With