In MS Access, I want to rename filename of the attachment with ID and filename so that there should be any problem for duplicates. For example, if the id is 1 and filename is ABC then name in the folder should be 1ABC or 1_ABC anything is fine. Currently it is saving as ABC.extension (pdf/docx/txt).
Try this.
Private Sub Command0_Click()
Dim counter As Long
counter = SaveAttachments("D:\Test1")
MsgBox counter & " files exported."
End Sub
Public Function SaveAttachments(savePath As String, Optional strPattern As String = "*.*") As Long
Dim r As DAO.Recordset
Dim r2 As DAO.Recordset2
Dim strFullPath As String
Dim counter As Long
Set r = CurrentDb().OpenRecordset("Notices")
Do While Not r.EOF
Set r2 = r("Attachments").Value
Do While Not r2.EOF
If r2("FileName") Like strPattern Then
strFullPath = savePath & "\" & r("ID") & "_" & r2("FileName")
If Dir(strFullPath) = "" Then
r2("FileData").SaveToFile strFullPath
counter = counter + 1
End If
End If
r2.MoveNext
Loop
If Not r2 Is Nothing Then r2.Close
r.MoveNext
Loop
If Not r Is Nothing Then r.Close
SaveAttachments = counter
End Function
Related
I managed code to create a group of tables based off of .csv files inside of a folder.
I want each of them to be a separate table so most of the concatenation posts weren't for me.
Public Function importExcelSheets(Directory As String) As Long
On Error Resume Next
Dim strDir As String
Dim strFile As String
Dim I As Long
Dim N As Long
Dim FSO As Object, MyFile As Object
Dim FileName As String, Arr As Variant
Dim Content As String
Dim objStreamIn
Dim objStreamOut
'Prepare Table names-------------------------------------------------------------------------------------
FileName = "path/to/table/names.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.OpenTextFile(FileName, 1)
Arr = Split(MyFile.ReadAll, vbNewLine)
'Verify Directory and pull a file------------------------------------------------------------------------
If Left(Directory, 1) <> "\" Then
strDir = Directory & "\"
Else
strDir = Directory
End If
strFile = Dir(strDir & "*.csv")
'Fill Tables----------------------------------------------------------------------------------------------
I = UBound(Arr) - 1
While strFile <> ""
strFile = strDir & strFile
Set objStreamIn = CreateObject("ADODB.Stream")
Set objStreamOut = CreateObject("ADODB.Stream")
objStreamIn.Charset = "utf-8"
objStreamOut.Charset = "utf-8"
objStreamIn.Open
objStreamOut.Open
objStreamIn.LoadFromFile (strFile)
objStreamOut.Open
N = 1
While Not objStreamIn.EOS
Content = objStreamIn.ReadText(-2)
If N = 1 Then
Content = Replace(Content, "/", vbNullString, , 1)
objStreamOut.WriteText Content & vbCrLf
Else
objStreamOut.WriteText Content & vbCrLf
End If
N = N + 1
Wend
objStreamOut.SaveToFile strFile, 2
objStreamIn.Close
objStreamOut.Close
Set objStreamIn = Nothing
Set objStreamOut = Nothing
DoCmd.TransferText _
TransferType:=acImportDelim, _
TableName:=Arr(I), _
FileName:=strFile, _
HasFieldNames:=True, _
CodePage:=65001
strFile = Dir()
I = I - 1
Wend
importExcelSheets = I
End Function
It works until the last section where I use TransferText to create the table.
It will get different results based on a few things I've tried:
Running the script after commenting out the entire objStream section gives me the data and table names, but the headers are [empty], "F2", "F3", ... "F27".
I suspected it was because there was a forward slash in the first column header, so I put in the Replace() to remove it.
Running the script as in above gives me an empty table.
I now suspect that the encoding header of the file is the reason for this.
Running the script after changing objStreamOut.Charset = "utf-8" to objStreamOut.Charset = "us-ascii" and updating the CodePage to 20127 gives me an empty table with black diamond question marks for a column header.
I want to blame the encoding characters but it ran one time almost flawlessly with the utf-8 encoding and CodePage 65001. Is there another way around this?
Here is the Byte Order Mark of the file showing the UTF-8 Encoding
Edit: changed CodeType to CodePage and added vbCrLf to append to Content
Edit: Included picture of Hex for files showing UTF-8 offest
With the help from Comments it looks like I got it to work after fixing the vbCrLf problem. I switched the objStreamOut charset to us-ascii and changed the CodePage to 20127 to reflect that as well. I now have headers, table names, and data working normally. Here is the final code:
Public Function importExcelSheets(Directory As String) As Long
On Error Resume Next
Dim strDir As String
Dim strFile As String
Dim I As Long
Dim N As Long
Dim FSO As Object, MyFile As Object
Dim FileName As String, Arr As Variant
Dim Content As String
Dim objStreamIn
Dim objStreamOut
'Prepare Table names-------------------------------------------------------------------------------------
FileName = "path/to/table/names.txt"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set MyFile = FSO.OpenTextFile(FileName, 1)
Arr = Split(MyFile.ReadAll, vbNewLine)
'Verify Directory and pull a file------------------------------------------------------------------------
If Left(Directory, 1) <> "\" Then
strDir = Directory & "\"
Else
strDir = Directory
End If
strFile = Dir(strDir & "*.csv")
'Fill Tables----------------------------------------------------------------------------------------------
I = UBound(Arr) - 1
While strFile <> ""
strFile = strDir & strFile
Set objStreamIn = CreateObject("ADODB.Stream")
Set objStreamOut = CreateObject("ADODB.Stream")
objStreamIn.Charset = "utf-8"
objStreamOut.Charset = "us-ascii"
objStreamIn.Open
objStreamOut.Open
objStreamIn.LoadFromFile (strFile)
objStreamOut.Open
N = 1
While Not objStreamIn.EOS
Content = objStreamIn.ReadText(-2)
If N = 1 Then
Content = Replace(Content, "/", vbNullString, , 1)
objStreamOut.WriteText Content & vbCrLf
Else
objStreamOut.WriteText Content & vbCrLf
End If
N = N + 1
Wend
objStreamOut.SaveToFile strFile, 2
objStreamIn.Close
objStreamOut.Close
Set objStreamIn = Nothing
Set objStreamOut = Nothing
DoCmd.TransferText _
TransferType:=acImportDelim, _
TableName:=Arr(I), _
FileName:=strFile, _
HasFieldNames:=True, _
CodePage:=20127
strFile = Dir()
I = I - 1
Wend
importExcelSheets = I
End Function
Still not entirely sure why VBA was not getting the correct data when I used utf-8 and 65001 for CodeType and works now for us-ascii. This will work for me however.
I would like to get the value (The regex result) of the function below inside my main sub in orde to add it to the title of my file, how can I do this ?
Public Sub Process_SAU(Item As Outlook.MailItem)
Dim object_attachment As Outlook.Attachment
Dim saveFolder As String
Dim Code as String
Code = ExtractText
' Folder location when I want to save my file
saveFolder = "C:\Users\gdeange1\Desktop\suggestion updates\UpdateBusinessInformation\Processed_By_Bulks"
For Each object_attachment In Item.Attachments
' Criteria to save .doc files only
If InStr(object_attachment.DisplayName, ".json") Then
object_attachment.SaveAsFile saveFolder & "\" & Format(Now(), "dd-mm-yyyy") & "_" & Code & "_" & object_attachment.DisplayName
End If
Next
End Sub
Function ExtractText(Str As String) ' As String
Dim regEx As New RegExp
Dim NumMatches As MatchCollection
Dim M As Match
regEx.Pattern = "((.*))[A-Z]{0}(Danièle Loubert|Véronique Mantha|Julie-Emmanuelle Carle|Nicolas Bertrand|Martine Jean)"
Set NumMatches = regEx.Execute(Str)
If NumMatches.Count = 0 Then
ExtractText = "Blabla"
Else
Set M = NumMatches(0)
ExtractText = M.SubMatches(0)
End If
Code = ExtractText
End Function
The code I tried above did not work.
Thank's for your help!
You might have copied the function ExtractText(Str As String) , but this function expects a string value to be passed while using this function, which you are missing. If you pass a string type value while using the function in your main code, it should work.
You pass Item to Public Sub Process_SAU(Item As MailItem).
Similarly, you have to pass Str to Function ExtractText(Str As String) As String.
Option Explicit
Private Sub test_Process_SAU()
Dim currItem As Object
' with a selected item
Set currItem = ActiveExplorer.Selection(1)
' or
' with an open item
'Set currItem = ActiveInspector.currentItem
If currItem.Class = olMail Then
Process_SAU currItem
End If
End Sub
Public Sub Process_SAU(Item As MailItem)
Dim Code As String
' Pass the applicable string to the function
Code = ExtractText(Item.body)
Debug.Print " Code: " & Code
Dim object_attachment As outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\Users\gdeange1\Desktop\suggestion updates\UpdateBusinessInformation\Processed_By_Bulks"
For Each object_attachment In Item.Attachments
If InStr(object_attachment.DisplayName, ".json") Then
object_attachment.SaveAsFile saveFolder & "\" & Format(Now(), "dd-mm-yyyy") & "_" & Code & "_" & object_attachment.DisplayName
End If
Next
End Sub
Function ExtractText(Str As String) As String
Dim regEx As New regExp
Dim NumMatches As MatchCollection
Dim M As Match
regEx.Pattern = "((.*))[A-Z]{0}(Danièle Loubert|Véronique Mantha|Julie-Emmanuelle Carle|Nicolas Bertrand|Martine Jean)"
Set NumMatches = regEx.Execute(Str)
If NumMatches.count = 0 Then
ExtractText = "Blabla"
Else
Set M = NumMatches(0)
ExtractText = M.Value
End If
End Function
Thanks in advance for your help and comments.
I have the following problem, but I do not know if it is possible ... I am trying to rename PDF files that are in the folder C: \ ... I need to rename according to a worksheet that I have in excel that is ordered according to the pdf files .. I would like to rename with the spreadsheet data in excel?
I have a code that I researched but it does not search my database, but it asks me to enter the name of each file
Public Sub lsSelecionaArquivo()
Dim Caminho As String
Dim NomeBase As String
Caminho = InputBox("Informe o local dos arquivos a serem renomeados:", "Pasta", "C:\TEMP")
NomeBase = InputBox("Informe o local dos arquivos a serem renomeados:", "Renomear", "")
lsRenomearArquivos Caminho, NomeBase
End Sub
Public Sub lsRenomearArquivos(Caminho As String, NomeBase As String)
Dim FSO As Object, Pasta As Object, Arquivo As Object, Arquivos As Object
Dim Linha As Long
Dim lSeq As Long
Dim lNovoNome As String
Set FSO = CreateObject("Scripting.FileSystemObject")
If Not FSO.FolderExists(Caminho) Then
MsgBox "A pasta '" & Caminho & "' não existe.", vbCritical, "Erro"
Exit Sub
End If
lSeq = 1
Set Pasta = FSO.GetFolder(Caminho)
Set Arquivos = Pasta.Files
Cells(1, 1) = "De"
Cells(1, 2) = "Para"
Linha = 2
For Each Arquivo In Arquivos
Cells(Linha, 1) = UCase$(Arquivo.Path)
lNovoNome = Caminho & "\" & NomeBase & lSeq & Right(Arquivo, 4)
Name Arquivo.Path As lNovoNome
Cells(Linha, 2) = lNovoNome
lSeq = lSeq + 1
Linha = Linha + 1
Next
End Sub
For the renaming part, consider this.
Sub RenameFiles()
'Updateby20141124
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
https://www.extendoffice.com/documents/excel/2339-excel-rename-files-in-a-folder.html
Also, consider this.
Sub ListFiles()
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
MyFolder = "C:\DealerExam"
MyFile = Dir(MyFolder & "\*.*")
a = 0
Do While MyFile <> ""
a = a + 1
Cells(a, 1).Value = MyFile
MyFile = Dir
Loop
End Sub
This will list all the files in your directory starting in cell 'A1'
Thanks for the help
It is a bit tense to change language since I study Java and started doing VBA.
When I ran the code, I saw that it is necessary for the spreadsheet to have the old file name and the new one to insert the data, but there is no way to get it to just get the new data? And I've tried searching on how to make them as PDF without having to put the file extension in the worksheet.
Sorry for the questions ... I do not have much contact with VBA.
I thank you very much for helping me.
Sub RenameFiles()
Dim xDir As String
Dim xFile As String
Dim xRow As Long
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show = -1 Then
xDir = .SelectedItems(1)
xFile = Dir(xDir & Application.PathSeparator & "*")
Do Until xFile = ""
xRow = 0
On Error Resume Next
xRow = Application.Match(xFile, Range("A:A"), 0)
If xRow > 0 Then
Name xDir & Application.PathSeparator & xFile As _
xDir & Application.PathSeparator & Cells(xRow, "B").Value
End If
xFile = Dir
Loop
End If
End With
End Sub
Sub ListFiles()
Dim MyFolder As String
Dim MyFile As String
Dim j As Integer
MyFolder = "C:\Users\AnaWill\Desktop\Holerites Folha\Nova pasta"
MyFile = Dir(MyFolder & "\*.*")
a = 0
Do While MyFile <> ""
a = a + 1
Cells(a, 2).Value = MyFile
MyFile = Dir
Loop
End Sub
As in the Question: the task is to extract all files names from a folder, but the folder path needs to be hard coded into the macro, to prevent these dialog boxes asking me things and wasting my time.
I will not change this folder. It will be the same one until the end of time, and I want to extract the files names into the Excel column, starting from second row.
this is the folder I want to extract ALL files names from.
"C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\"
this is my portion of code:
Option Explicit
Sub GetFileNames()
Dim axRow As Long ' inside the Sheet("Lista") row#
Dim xDirectory As String
Dim xFname As String ' name of the file
Dim InitialFoldr$
Dim start As Double
Dim finish As Double
Dim total_time As Double
start = Timer
ThisWorkbook.Sheets("Lista").Range("D2").Activate
InitialFolder = "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst"
If Right(InitialFolder, 1) <> "\" Then
InitialFolder = InitialFolder & "\"
End If
Application.InitialFolder.Show
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
xFname = Dir(xDirectory, vbArchive)
' Dir's job is to return a string representing
' the name of a file, directory, or an archive that matches a specified pattern.
Do While xFname <> "" ' there is already xFname value (1st file name) assigned.
ActiveCell.Offset(xRow) = xFname
xRow = xRow + 1 ' następny xRow
xFname = Dir()
Loop
End If
End With
finish = Timer ' Set end time.
total_time = Round(finish - start, 3) ' Calculate total time.
MsgBox "This code ran successfully in " & total_time & " seconds", vbInformation
End Sub
this is the line that crushes:
If InitialFolder.SelectedItems.Count <> 0 Then
xDirectory = .SelectedItems(1) & "\"
And two more important questions in the .png file.
Please, respond to them as well - it's very important 4 me.
Or if U guys know any other method to do this faster just don't hesitate and share Your Code with me - I'll be very grateful.
Sub Files()
Dim sht As Worksheet
Dim strDirectory As String, strFile As String
Dim i As Integer: i = 1
Set sht = Worksheets("Sheet1")
strDirectory = "C:\Users\User\Desktop\"
strFile = Dir(strDirectory, vbNormal)
Do While strFile <> ""
With sht
.Cells(i, 1) = strFile
.Cells(i, 2) = strDirectory + strFile
End With
'returns the next file or directory in the path
strFile = Dir()
i = i + 1
Loop
End Sub
See example below
Public Sub Listpng()
Const strFolder As String = "C:\SomeFolder\"
Const strPattern As String = "*.png"
Dim strFile As String
strFile = Dir(strFolder & strPattern, vbNormal)
Do While Len(strFile) > 0
Debug.Print strFile '<- view this in Immediate window; Ctrl+g will take you there
strFile = Dir
Loop
End Sub
There's a couple of procedures I use depending on whether I want subfolders as well.
This loops through the folder and adds path & name to a collection:
Sub Test1()
Dim colFiles As Collection
Dim itm As Variant
Set colFiles = New Collection
EnumerateFiles "C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "*.xls*", colFiles
For Each itm In colFiles
Debug.Print itm
Next itm
End Sub
Sub EnumerateFiles(ByVal sDirectory As String, _
ByVal sFileSpec As String, _
ByRef cCollection As Collection)
Dim sTemp As String
sTemp = Dir$(sDirectory & sFileSpec)
Do While Len(sTemp) > 0
cCollection.Add sDirectory & sTemp
sTemp = Dir$
Loop
End Sub
This second way goes through the subfolders as well returning path & name. For some reason if you change InclSubFolders to False it only returns the name - got to sort that bit out.
Sub Test2()
Dim vFiles As Variant
Dim itm As Variant
vFiles = EnumerateFiles_2("C:\Users\michal\SkyDrive\csv\bossa\mstcgl_mst\", "xls*")
For Each itm In vFiles
Debug.Print itm
Next itm
End Sub
Public Function EnumerateFiles_2(sDirectory As String, _
Optional sFileSpec As String = "*", _
Optional InclSubFolders As Boolean = True) As Variant
EnumerateFiles_2 = Filter(Split(CreateObject("WScript.Shell").Exec _
("CMD /C DIR """ & sDirectory & "*." & sFileSpec & """ " & _
IIf(InclSubFolders, "/S ", "") & "/B /A:-D").StdOut.ReadAll, vbCrLf), ".")
End Function
I am trying to upload a few hundred folders each with files inside of them into SharePoint, but unfortunately SharePoint doesn't allow any special characters like "%".
I'm trying to use a VBA code that can automatically go into each subfolder and replace any special characters contained within the files such as "%", "#", etc.
So far what I have is:
Sub ChangeFileName()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set Folder = objFSO.GetFolder("C:\Users\Documents\TEST\Subfolder")
'Currently the way I have it requires me to change my path a few hundred times
For Each File In Folder.Files
sNewFile = File.Name
sNewFile = Replace(sNewFile, "%", "_")
sNewFile = Replace(sNewFile, "#", "_")
'^and so on`
If (sNewFile <> File.Name) Then
File.Move (File.ParentFolder + "\" + sNewFile)
End If
Next
End Sub
However for the script above, you need the specific sub-folder path. Wondering if there's any way to automatically replace the special characters of files within subfolders. I can also paste all the specific subfolder paths into column A of my Excel worksheet if that helps.
Thank you!
I use this code
Sub GetFileFromFolder()
Dim fd As FileDialog
Dim strFolder As String
Dim colResult As Collection
Dim i As Long, k As Long
Dim vSplit
Dim strFn As String
Dim vR() As String
Dim p As String
Dim iLevel As Integer, cnt As Long
'iLevel = InputBox(" Subfolder step : ex) 2 ")
p = Application.PathSeparator
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Show
.InitialView = msoFileDialogViewList
.Title = "Select your Root folder"
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then
Else
strFolder = .SelectedItems(1)
Set colResult = SearchFolder(strFolder)
i = colResult.Count
For k = 1 To i
vSplit = Split(colResult(k), p)
strFn = vSplit(UBound(vSplit))
strFn = Replace(strFn, "%", "_")
strFn = Replace(strFn, "#", "_")
'If UBound(vSplit) - UBound(Split(strFolder, p)) = iLevel Then
cnt = cnt + 1
ReDim Preserve vR(1 To 3, 1 To cnt)
On Error Resume Next
Err.Clear
Name colResult(k) As strFolder & strFn
vR(1, cnt) = colResult(k)
If Err.Number = 58 Then
strFn = Split(strFn, ".")(0) & "_" & vSplit(UBound(vSplit) - 1) & "_" & Date & "." & Split(strFn, ".")(1)
Name colResult(k) As strFolder & strFn
vR(2, cnt) = strFolder & strFn
vR(3, cnt) = "Changed name " 'When filename is duplicated chage filename
Else
vR(2, cnt) = strFolder & strFn
End If
' End If
Next k
ActiveSheet.UsedRange.Offset(1).Clear
Range("a3").Resize(1, 3) = Array("Old file", "New file", "Ect")
If cnt > 0 Then
Range("a4").Resize(cnt, 3) = WorksheetFunction.Transpose(vR)
End If
With ActiveSheet.UsedRange
.Borders.LineStyle = xlContinuous
.Columns.AutoFit
.Font.Size = 9
End With
End If
End With
MsgBox cnt & " files moved!! "
End Sub
Function SearchFolder(strRoot As String)
Dim FS As Object
Dim fsFD As Object
Dim f As Object
Dim colFile As Collection
Dim p As String
On Error Resume Next
p = Application.PathSeparator
If Right(strRoot, 1) = p Then
Else
strRoot = strRoot & p
End If
Set FS = CreateObject("Scripting.FileSystemObject")
Set fsFD = FS.GetFolder(strRoot)
Set colFile = New Collection
For Each f In fsFD.Files
colFile.Add f.Path
Next f
SearchSubfolder colFile, fsFD
Set SearchFolder = colFile
Set fsFD = Nothing
Set FS = Nothing
Set colFile = Nothing
End Function
Sub SearchSubfolder(colFile As Collection, objFolder As Object)
Dim sbFolder As Object
Dim f As Object
For Each sbFolder In objFolder.subfolders
SearchSubfolder colFile, sbFolder
For Each f In sbFolder.Files
colFile.Add f.Path
Next f
Next sbFolder
End Sub