I have the path of the files stored in MS Access in a table.
The table was made to rename a specific set of files, so the important fields are oldpath and newpath. These are used in VBA. First I bring the the data setting a recordset. Afterwards I do a while not to process all the oldpath using RenameFileOrDir function.
The function renames all file names that are not in Chinese.
Public Function TestNameStatement()
Dim fOK As Boolean
Set rs_images = CurrentDb.OpenRecordset("Select import_acc.* from import_acc")
rs_images.MoveLast
rs_images.MoveFirst
Do While Not rs_images.EOF
oldlocation = rs_images.Fields("oldpath")
newlocation = rs_images.Fields("newpath")
' Folders must exist for Source, but do not need to exist for destination
fOK = RenameFileOrDir("" & oldlocationx & "", "" & newlocationx & "")
rs_images.MoveNext
Loop
On Error Resume Next
End Function
Go to Access options, Language,add chinese language
Related
I'm pretty new to using VBA. I have an access database where the user clicks a button and this will upload multiple files.
The files uploaded are temp tables and get fields added to them etc. Once updates have been made to the temp tables, the records get transferred into a permanent table.
It uploads multiple files at once, so as files get uploaded the table they get input into tables called'temp_filename', with each file getting its own table.
Below is my code. For the alter table statement I want to upload the temp table which has just been created. As this table will be named something different every time I tried to assign it to a variable. I tried different syntax etc, however I keep getting errors. Can anyone see where I am going wrong? Any help would be appriciated.
Public Sub Import()
Dim oFileDiag As Office.FileDialog
Dim path As String: path = ""
Dim oFSO As New FileSystemObject
Dim FileSelected As Variant
Dim FileNameSelected As Variant
Dim UpdatedTableName As Variant
Set oFileDiag = Application.FileDialog(msoFileDialogFilePicker) ''Picks file to import
oFileDiag.AllowMultiSelect = True ''Allows multiple files to be selected
oFileDiag.Title = "Please select the reports to upload"
oFileDiag.Filters.Clear
oFileDiag.Filters.Add "Excel Spreadsheets", "*.xlsx, *.xls" ''Only allows xlsx and xls file types to upload
If oFileDiag.Show Then
For Each FileSelected In oFileDiag.SelectedItems
FileNameSelected = oFSO.GetFileName(FileSelected)
UpdatedTableName = "temp_" & FileNameSelected
If oFileDiag.SelectedItems.Count > 0 Then path = oFileDiag.SelectedItems(1)
If Len(path) > 0 Then
DoCmd.TransferSpreadsheet acImport, acSpreadsheetTypeExcel12, UpdatedTableName, path, 1
DoCmd.RunSQL "ALTER TABLE UpdatedTableName ADD COLUMN [Date_of_Report] TEXT(100);"
MsgBox "The " & FileNameSelected & " file has been uploaded"
Else
MsgBox "File not found"
End If
Next
End If
You need to concatenate the table name into the SQL string:
DoCmd.RunSQL "ALTER TABLE [" & UpdatedTableName & "] ADD COLUMN [Date_of_Report] TEXT(100);"
I've used square brackets just in case there are things like spaces in the table name.
Regards,
I have a split database where both the front end and back end are accdb files. Because one of my tables uses the AppendOnly = Yes property, I cannot use the link table manager or the refreshlink property when I move the backend. The backend moves from time to time because my IT loves to reshuffle servers.
So my solution is to write a function which prompts for the backend location, deletes all the currently linked tables, and then loops through all the backend tables and links them to the frontend. On this last part I receive a run time error 3170 could not find suitable ISAM. I don't know why.
Code is below:
Public Function MoveDB()
'this function will replace the linked table manager. It will open a file select dialog box to allow the user to pick the new location of the DB backend.
'It will then break all the current links and then recreate them. We need to do this vice use the relink function because the cases table uses AutoAppend which stores old path data
' and breaks the relink function which is why linked table manager does not work.
' FileDialog Requires a reference to Microsoft Office 11.0 Object Library.
'variables to get the database path
Dim fDialog As Office.FileDialog
Dim varFile As Variant
Dim DriveLetter As String
Dim NetworkPath As String
Dim DrivePath As String
Dim SubPath As String
'variables to link the database
Dim db As DAO.Database
Dim BEdb As DAO.Database
Dim oldtdf As DAO.TableDef
Dim tblName As String
Dim newtdf As DAO.TableDef
Dim BEtdf As DAO.TableDef
Set db = CurrentDb()
' Set up the File Dialog.
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
' Do not Allow user to make multiple selections in dialog box
.AllowMultiSelect = False
'set the default folder that is opened
.InitialFileName = CurrentProject.Path & "\BE"
' Set the title of the dialog box.
.Title = "Please select the Database Backend"
' Clear out the current filters, and add our own.
.Filters.Clear
.Filters.Add "Access Databases", "*.accdb"
' Show the dialog box. If the .Show method returns True, the
' user picked a file. If the .Show method returns
' False, the user clicked Cancel.
If .Show = True Then
'We need to determine the full network path (including server name) to the DB backend. The reason is that different users may have the share drive mapped with different letters.
'If the backend is mapped using the drive letter of the user moving the DB then other users may not have a valid path. The full network path is universal
'Get the mapped drive letter from the path of the selected DB file
DriveLetter = Left$(Trim(fDialog.SelectedItems(1)), 2)
'Get the path of the selected DB file minus the drive letter
SubPath = Mid$(Trim(fDialog.SelectedItems(1)), 3)
'Get the full network path of the mapped drive letter
DrivePath = GETNETWORKPATH(DriveLetter)
'Combine the drive path and the sub path to get the full path to the selected DB file
NetworkPath = DrivePath & SubPath
'MsgBox (NetworkPath)
Else
MsgBox "You clicked Cancel in the file dialog box."
End If
End With
'Now we need to delete all the linked tables
For Each oldtdf In db.TableDefs
With oldtdf
If oldtdf.Attributes And dbAttachedODBC Or oldtdf.Attributes And dbAttachedTable Then
'this is a linked table
tblName = .Name
DoCmd.DeleteObject acTable, tblName
End If
End With
Next oldtdf
tblName = ""
'Now we link all the tables from the backend to the front end
Set BEdb = OpenDatabase(NetworkPath)
For Each BEtdf In BEdb.TableDefs
tblName = BEtdf.Name
If Left(tblName, 4) <> "~TMP" Then
Set newtdf = db.CreateTableDef(strTable)
newtdf.Connect = "Database = " & NetworkPath
newtdf.SourceTableName = tblName
newtdf.Name = tblName
db.TableDefs.Append newtdf
End If
Next BEtdf
End Function
The error occurs on the
db.TableDefs.Append newtdf
line. I'm looking to either make this code work, or a way around the known bug that prevents refreshing links when using the AppendOnly=Yes property.
Thanks in advance for any help.
I think you are just missing the semicolon on your string and remove extra spaces
newtdf.Connect = ";Database=" & NetworkPath
Alternatively, you can use DoCmd.TransferDatabase method and be sure to leave out the MSys tables as they have no direct application use between split files:
If Left(tblName, 4) <> "~TMP" And Left(tblName, 4) <> "MSys" Then
DoCmd.TransferDatabase acLink, "Microsoft Access", NetworkPath, _
acTable, tblName, tblName, False
End If
found this and worked for me
DAODataSet.SQL.Text := 'SELECT * FROM Country IN "" ";DATABASE=C:\SIMPLE.MDB;PWD=MyPassword"';
DAODataSet.Open;
I'm working with someone who has to identify certain variables within excel files. Currently, the man I'm working with has a great deal of folders and sub-folders that have Excel documents in them. He's using a VBA code that looks within a folder for a sub-folder, and then returns the pathway, then creating a hyperlink to the sub-folder (this isn't part of the VBA code below) and looking at all excel files within, no matter the level of sub-folders within the main folder.
Here's the code:
Sub GetFolders()
Dim path As String
Dim folder As String
Dim row As Integer
path = "your directory here"
folder = Dir(path, vbDirectory)
row = 1
Do While folder <> ""
If (GetAttr(path & folder) And vbDirectory) = vbDirectory Then
Cells(row, 1) = path & folder
row = row + 1
End If
folder = Dir()
Loop
End Sub
This is great, but I know there has to be a better way. How can I manipulate this code to return COLUMN HEADERS of any excel files found A) within a folder or B) within a subfolder contained within a folder. I want these to be returned to an excel spreadsheet so that 100's of excel documents don't need to be opened, but rather just this one, and then we can identify any excel spreadsheets that need further investigation and ignore the rest.
You can query them with ADO (adjust the connection string as needed):
'Requires reference to Microsoft ActiveX Data Objects #.# Library
Private Function GetHeaders(filepath As String) As String()
Dim output() As String
Dim ado As New ADODB.Connection
output = Split(vbNullString)
With ado
.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source='" & filepath & "';" & _
"Extended Properties=""Excel 12.0 Xml;HDR=YES;IMEX=1;"";"
With .OpenSchema(adSchemaTables)
Dim table As String
Dim columns As ADODB.Recordset
Do While Not .EOF
table = .Fields("TABLE_NAME")
Set columns = ado.OpenSchema(adSchemaColumns, Array(Empty, Empty, table))
With columns
Do While Not .EOF
ReDim Preserve output(UBound(output) + 1)
output(UBound(output)) = table & .Fields("COLUMN_NAME")
.MoveNext
Loop
End With
.MoveNext
Loop
End With
End With
GetHeaders = output
End Function
Then call it like this for each file that you find:
Sub Example()
Dim headers() As String
Dim i As Long
headers = GetHeaders("C:\Foo\Bar.xlsx")
For i = LBound(headers) To UBound(headers)
Debug.Print headers(i)
Next i
End Sub
Note that this assumes you don't know the sheet names and need to get headers for all of them. The strings in the output array will be in the form of Sheet$Field, but that can be adjusted according to need.
Cell in col header is limited to 255 chars only due to limitation in ADODB.
I have a simple Access 2013 database that currently has one table, and one form for inputting data. I input data using the form, things like first name, last name, etc. I then have the database calling a function that takes these values, and places them on a word document in specific areas, (similar to mail merge, but mail merge doesn't suit my exact needs.) The function then converts a copy of that word document to a .pdf, and saves it in a location that is pre-defined.
I currently have the function tied to a button that is on the form. Everything works fine now, and I would like to break the soon-to-be large amount of code that will follow into modules; however, this is where I am having the issue. When I place this function in a module, it does not populate all of the form fields on the word document. It only populates one or two fields, not all of them. If I place the code back in a function that is on the main form, it works just fine.
I do not get any errors either way. The .pdf is created and stored exactly where it is supposed to be, but if the button calls the module, it doesn't populate all of the fields. If the button calls the function within the same form, it works like a champ. I will post a shortened version of the code below.
My initial thoughts are that perhaps I am not calling the module correctly, but at this point, I am lost. I have tried passing the values as 'Function Memo(LN, FN, srcFile) As String', labeling individually 'As String', but I can't seem to get it to work.
Function Memo(LN, FN, srcFile)
Dim appword As Object
Dim doc As Object
Dim Path As String
Dim pdfFileName As String
Dim folderName As String
Dim directory As String
Path = srcFile
folderName = LN & ", " & FN
directory = Application.CurrentProject.Path & "\" & folderName
pdfFileName = directory & "\" & folderName & " 2015 Memo" & ".pdf"
If Dir(directory, vbDirectory) = "" Then
MkDir (directory)
Else
End If
On Error Resume Next
Error.Clear
Set appword = GetObject(, "word.application")
If Err.Number <> 0 Then
Set appword = CreateObject("Word.Application")
appword.Visible = False
End If
Set doc = appword.Documents.Open(Path, , True)
With doc
.FormFields("TextFN1").Result = FN
.FormFields("TextMI1").Result = MI
.FormFields("TextLN11").Result = LN
.ExportAsFixedFormat pdfFileName, 17
appword.Visible = False
Set doc = appword.Documents.Close()
appword.Quit SaveChanges:=False
End With
Set doc = Nothing
Set appword = Nothing
End Function
Wow. Silly me. After some additional exploratory surgery on the code, I found my problem. The issue is that a few of my variables did not have unique names. Problem solved.
I need to add text string to all files on a folder, as a footer
For example, on the folder on the path and called C:\mobatchscripts\
I have a random number of txt files, with text.
I want to add a line for example "text" on each of the text files on the folder
I have little knowledge of vba programming, but for what I have read I can use append, but I need something that loop on the files on the folder, and modify them.
So far I tried this:
Sub footer()
Dim FolderPath As String
Dim FileName As String
Dim wb As Excel.Workbook
FolderPath = "C:\mobatchscripts\"
FileName = Dir(FolderPath)
Do While FileName <> ""
Open FileName For Append As #1
Print #1, "test"
Close #1
FileName = Dir
Loop
End Sub
But seems that its not looking into the files, or appending the text.
On the assumption that you're writing to text files (I see "batchscripts" in the path), you need a reference to the Microsoft Scripting Runtime (Within the VBE you'll find it in Tools, References)
Option Explicit
Public Sub AppendTextToFiles(strFolderPath As String, _
strAppendText As String, _
blnAddLine As Boolean)
Dim objFSO As FileSystemObject
Dim fldOutput As Folder
Dim filCurrent As File
Dim txsOutput As TextStream
Set objFSO = New FileSystemObject
If objFSO.FolderExists(strFolderPath) Then
Set fldOutput = objFSO.GetFolder(strFolderPath)
For Each filCurrent In fldOutput.Files
Set txsOutput = filCurrent.OpenAsTextStream(ForAppending)
If blnAddLine Then
txsOutput.WriteLine strAppendText
Else
txsOutput.Write strAppendText
End If
txsOutput.Close
Next
MsgBox "Wrote text to " & fldOutput.Files.Count & " files", vbInformation
Else
MsgBox "Path not found", vbExclamation, "Invalid path"
End If
End Sub
I'd recommend adding error handling as well and possibly a check for the file extension to ensure that you're writing only to those files that you want to.
To add a line it would be called like this:
AppendTextToFiles "C:\mobatchscripts", "Test", True
To just add text to the file - no new line:
AppendTextToFiles "C:\mobatchscripts", "Test", False
Alternatively, forget the params and convert them to constants at the beginning of the proc. Next time I'd recommend working on the wording of your question as it's not really very clear what you're trying to achieve.