Trying to set this code found Here to work recursively down through my folders. at the minute I have this
Public Sub addPassword()
Dim FSO As Object
Dim strFileName As String
Dim strFilePath As String
Dim folder As Object, subfolder As Object
Dim doc As Object
Dim oDoc As Document
Dim PWD As String
Set FSO = CreateObject("Scripting.FileSystemObject")
folderPath = "G:\Test Data"
Set folder = FSO.GetFolder(folderPath)
PWD = "FooBar"
For Each doc In folder.Files
strFilePath = "G:\Test Data\"
strFileName = Dir$(strFilePath & "*.doc*")
Set oDoc = Documents.Open( _
FileName:=strFilePath & strFileName, _
PasswordDocument:="FooBar")
oDoc.Saved = False
oDoc.SaveAs2 FileName:=strFilePath & strFileName, _
Password:=PWD
oDoc.Close
Set oDoc = Nothing
Next
For Each subfolder In folder.SubFolders
For Each doc In subfolder.Files
strFilePath = "G:\Test Data\"
strFileName = Dir$(strFilePath & "*.doc*")
Set oDoc = Documents.Open( _
FileName:=strFilePath & strFileName, _
PasswordDocument:="FooBar")
oDoc.Saved = False
oDoc.SaveAs2 FileName:=strFilePath & strFileName, _
Password:=PWD
oDoc.Close
Set oDoc = Nothing
Next
Next
End Sub
Absolute Novice to vba so trying to use some limited python experience to set this up recursively. I can see every file open up in the side but when I go to check on them non of them have a password set
Any help would be appreciated thank you
I am trying to copy a table from Microsoft Word 2016 to Microsoft Excel 2016 but not been very successful.
I get an error
User-defined type not defined
in this section of code below :
Public Sub ImportTableDataWordDoc(ByVal strDocName As String)
Could anyone help me with this, please?
The entire code follows:
Option Explicit
Public Sub ImportTableDataWord()
Const FOLDER_PATH As String = " \User\kritikata\Desktop\Articulateexporteddata\"
Dim sFile As String
sFile = Dir(FOLDER_PATH & " *.docx ")
If sFile = " " Then
MsgBox " The file is not present or was not found "
Exit Sub
End If
ImportTableDataWordDoc FOLDER_PATH & sFile
End Sub
Public Sub ImportTableDataWordDoc(ByVal strDocName As String)
Dim WdApp As Word.Application
Dim wddoc As Word.Document
Dim nCount As Integer
Dim rowWd As Long
Dim colWd As Long
Dim x As Long
Dim y As Long
Dim i As Long
On Error GoTo EH
If strDocName = "" Then
MsgBox "The file is not present or was not found"
GoTo FINISH
End If
Set WdApp = New Word.Application
WdApp.Visible = False
Set wddoc = WdApp.Documents.Open(strDocName)
If wddoc Is Nothing Then
MsgBox "No document object"
GoTo FINISH
End If
x = 1
y = 1
With wddoc
If .Tables.Count = 0 Then
MsgBox "No Tables Found in the document"
GoTo FINISH
Else
With .Tables(1)
For rowWd = 1 To .Rows.Count
For colWd = 1 To .Columns.Count
Cells(x, y) = WorksheetFunction.Clean(.Cell(rowWd, colWd).Range.Text)
y = y + 1
Next 'colWd
y = 1
x = x + 1
Next 'rowWd
End With
End If
End With
GoTo FINISH
EH:
With Err
MsgBox "Number" & vbTab & .Number & vbCrLf _
& "Source" & vbTab & .Source & vbCrLf _
& .Description
End With
'for debugging purposes
Debug.Assert 0
GoTo FINISH
Resume
FINISH:
On Error Resume Next
'release resources
If Not wddoc Is Nothing Then
wddoc.Close savechanges:=False
Set wddoc = Nothing
End If
If Not WdApp Is Nothing Then
WdApp.Quit savechanges:=False
Set WdApp = Nothing
End If
End Sub
The problem is that the sFile = Dir(FOLDER_PATH & " *.docx ") does not get the correct docx file.
This is visible, if you write MsgBox FOLDER_PATH & sFile before calling the sub.
I have code that splits a workbook based on a condition. I want to email each of those new workbooks to different people.
When I run the macro, it splits the workbook and puts all the worksheets where I want them. When I try to send I only send 1 email.
Sub savesheetsSend()
Dim ws As Worksheet
Dim Filetype As String
Dim Filenum As Long
Dim wb As Workbook
Dim FolderName As String
Dim open_book As Workbook
Set outmail = CreateObject("outlook.application")
Set outmsg = outmail.createitem(0)
Set wb = Application.ThisWorkbook
'create directory to save each sheet in
FolderName = "C:\Users\jpenn\Desktop" & "\" & wb.Name
MkDir FolderName
On Error Resume Next
'save each sheet as workbook in directory
For Each ws In wb.Worksheets
If ws.Range("A1") = 1 Then
Filetype = ".xlsm": Filenum = 52
ws.Copy
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & Filetype
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=Filenum
End If
Next
'send all new workbooks to email address in CELL("B1")
For Each open_book In Application.Workbooks
If open_book.Name <> ThisWorkbook.Name Then
With outmsg
.Subject = ActiveWorkbook.Name & " payroll data"
.To = ActiveWorkbook.ActiveSheet.Range("b1").Value
.body = "I will get to this later"
.Attachments.Add Application.ActiveWorkbook.FullName
.send
End With
open_book.Close
End If
Next
End Sub
Try it this way... Tested
Option Explicit
Sub savesheetsSend()
Dim Ws As Worksheet
Dim Filetype As String
Dim xFile As String
Dim Filenum As Long
Dim Wb As Workbook
Dim FolderName As String
Dim Open_Book As Workbook
Dim OutMsg As Object
Dim OutMail As Object
Set OutMail = CreateObject("outlook.application")
Set Wb = Application.ThisWorkbook
'create directory to save each sheet in
FolderName = "C:\Users\jpenn\Desktop" & "\" & Wb.Name
MkDir FolderName
'save each sheet as workbook in directory
For Each Ws In Wb.Worksheets
If Ws.Range("A1") = 1 Then
Filetype = ".xlsm": Filenum = 52
Ws.Copy
xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & Filetype
Application.ActiveWorkbook.SaveAs xFile, FileFormat:=Filenum
Set OutMsg = OutMail.createitem(0)
With OutMsg
.Subject = Ws.Name & " payroll data"
.To = ActiveSheet.Range("b1").Value
.Body = "I will get to this later"
.Attachments.Add (xFile)
.Display
End With
ActiveWorkbook.Close
End If
Next
End Sub
a server sends me emails with a link file in each email.
Do you knwow if it exists a VBA code which opens each email, download each link file in a local directory, and move the email in another directory (as done) ?
Thanks a lot for your reply.
Christophe
If you want to download emails from Outlook, you can try this script.
Option Explicit On
Const fPath As String = "C:\Users\your_path_here\" 'The path to save the messages
Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err() <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
'.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
CreateFolders fPath
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
'.Cells(NextRow, 6) = olItem.Body 'Are you sure?
End If
Next olItem
End With
MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
Set olApp = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Function SaveMessage(olItem As Object) As String
Dim Fname As String
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) &
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object,
strPath As String,
strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For iPath = 1 To UBound(vPath)
strPath = strPath & vPath(iPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next iPath
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
Now, let's say you want to download emails and save each individual text files, run this script.
Public Sub ProcessInbox()
Dim oOutlook As Outlook.Application
Dim oNs As Outlook.NameSpace
Dim oFldr As Outlook.MAPIFolder
Dim oAttachments As Outlook.Attachments
Dim oAttachment As Outlook.Attachment
Dim iMsgCount As Integer
Dim oMessage As Outlook.MailItem
Dim iCtr As Long, iAttachCnt As Long
Dim sFileNames As String
Dim aFileNames() As String
'get reference to inbox
Set oOutlook = New Outlook.Application
Set oNs = oOutlook.GetNamespace("MAPI")
Set oFldr = oNs.GetDefaultFolder(olFolderInbox)
Debug.Print "Total Items: "; oFldr.Items.Count
Debug.Print "Total Unread items = " & oFldr.UnReadItemCount
For Each oMessage In oFldr.Items
With oMessage
'basic info about message
Debug.Print.To
Debug.Print.CC
Debug.Print.Subject
Debug.Print.Body
If .UnRead Then
Debug.Print "Message has not been read"
Else
Debug.Print "Message has been read"
End If
iMsgCount = iMsgCount + 1
'save message as text file
.SaveAs "C:\message" & iMsgCount & ".txt", olTXT
'reference and save all attachments
With oMessage.Attachments
iAttachCnt = .Count
If iAttachCnt > 0 Then
For iCtr = 1 To iAttachCnt
.Item(iCtr).SaveAsFile "C:\Users\your_path_here\" & .Item(iCtr).FileName
Next iCtr
End If
End With
End With
DoEvents
Next oMessage
Set oAttachment = Nothing
Set oAttachments = Nothing
Set oMessage = Nothing
Set oFldr = Nothing
Set oNs = Nothing
Set oOutlook = Nothing
End Sub
You can read all about these techniques, and many, many, many more things, in my book.
https://www.amazon.com/Automating-Business-Processes-Reducing-Increasing-ebook/dp/B01DJJKVZC/ref=sr_1_1?ie=UTF8&qid=1468466759&sr=8-1&keywords=ryan+shuell
I would like to open a Word doc, paste data from my Excel file and then save that Word document.
Opening Word and pasting the data works fine, but it doesn't save the file due to a problem with the line "ChDir "C:\My Documents\".
What am I missing here?
Sub macro()
Dim WordApp As Word.Application
Dim WordDoc As Word.Document
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True
WordApp.Activate
Set WordDoc = WordApp.Documents.Add
Range("A1:C33").Copy
WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _Placement:=wdInLine, DisplayAsIcon:=False
WordDoc.PageSetup.LeftMargin = CentimetersToPoints(1.5)
WordDoc.PageSetup.TopMargin = CentimetersToPoints(1.4)
WordDoc.PageSetup.BottomMargin = CentimetersToPoints(1.5)
ChDir "C:\My Documents\Test"
ActiveDocument.SaveAs "Archief" & Format(Now, "yyyymmdd") & ".docx"
Set WordDoc = Nothing
Set WordApp = Nothing
End Sub
It would be easier to create a variable to include both the path and the name of the file, like this :
Dim FileFullName As String
FileFullName = Environ("userprofile") & "\My Documents\Test" & "\" & "Archief" & Format(Now, "yyyymmdd") & ".docx"
ActiveDocument.SaveAs FileFullName
Try this:
Dim FileName2 As String
Set appWrd = CreateObject("Word.Application")
appWrd.DisplayAlerts = False
FileName2 = Document.Path & "\" & ".docx"
appWrd.ActiveDocument.SaveAs FileName:=FileName2