Private Sub Createbutton_Click(sender As Object, e As EventArgs) Handles Create.Click
Dim MyPassword As String = "Password"
Dim oItem As Object
Dim OffS As Integer
Dim MsExcel As Excel.Application
Dim Wb As Excel.Workbook
MsExcel = CreateObject("Excel.Application")
'ASPTS is my project name and Default is a folder i created
Wb = MsExcel.Workbooks.Add("..\\ASPTS\ASPTS\Default\football.xlsm")
OffS = 0
For Each oItem In TeamListBox.Items
Wb.Sheets(1).Range("A2").Offset(OffS, 0).Value = oItem
OffS = OffS + 1
Next oItem
FSaveFileDialog.Filter = "Excel Files (*.xlsm)|*.xslsm"
Wb.SaveAs(Filename:="..\\ASPTS\ASPTS\Football\" & TextBox1.Text & ".xlsm", FileFormat:=52, Password:=MyPassword,
WriteResPassword:=MyPassword, ReadOnlyRecommended:=False, CreateBackup:=False)
Wb.Close()
End Sub
If I change the path like this
("C:\Users\UserName\Desktop\ASPTS\ASPTS\Default\football.xlsm")
it works fine but I don't want to specify any drive in folder path because my project should be able to run in other drives and other by users too.
Related
I want to create a backup file when sending an email. The following code works fine if I do a step by step debug it works fine. Without it a manually need to kill the Excel task otherwise the whole thing hangs:
Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
Call SaveACopy(Item)
End Sub
Sub SaveACopy(Item As Object)
Const olMsg As Long = 3
Dim m As MailItem
Dim savePath As String
If TypeName(Item) <> "MailItem" Then Exit Sub
Set m = Item
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = False
Dim fd As Office.FileDialog
Set fd = xlApp.Application.FileDialog(msoFileDialogFolderPicker)
Dim selectedItem As Variant
If fd.Show = -1 Then
For Each selectedItem In fd.SelectedItems
savePath = selectedItem & "\"
savePath = savePath & Format(Now(), "yyyy-mm-dd - hhNNss")
savePath = savePath & ".msg"
m.SaveAs savePath, olMsg
Next
End If
Set fd = Nothing
xlApp.Quit
Set xlApp = Nothing
End Sub
Any ideas?
Using a liberal application of DoEvents to solve a problem is not unlike fixing a hole in your car's oil pan by adding more oil.
Whatever was causing that bind is still there and your program will run faster if you can get it straightened out.
I am looking in the Folder for specific file in .docx and want to open it. I put the Name of X into Inputbox, go to Sheet Y, look on the next right cell of X and open this as Word (next cell right is an file in word I want to open). It is working, but the Problem is that the target Word Doc may be in multiples subfolders. Is there any quick way to search in These subfolder?
Private Sub CommandButton1_Click()
On Error GoTo ErrorHandling
Application.ScreenUpdating = False
Dim AppWD As Object
Dim SearchX As String
Dim SearchArea As Range
Dim Y As String
Dim sPath As String
sPath = "C:\Users\VS\Desktop\test"
SearchRule = InputBox("X")
Set SearchArea = Sheets("Look").Range("A:A").Find(what:=SearchX, _
LookIn:=xlFormulas, lookat:=xlWhole)
ActiveWindow.Visible = True
Target = SearchArea.Offset(0, 1).Value
Set AppWD = CreateObject("Word.Application")
AppWD.Visible = True
AppWD.documents.Open (sPath & "\" & Target & "." & "docx")
ErrorHandling: Exit Sub
End Sub
My take on searching throught subfolders
Sub searchSub()
Dim fso As FileSystemObject, fFile As File, fFolder As Folder
Dim fSubFolder As Folder, fPath As String, FileToSearch As String
Set fso = New FileSystemObject
FileToSearch = "SomeDocument.docx"
fPath = ThisWorkbook.Path
Set fFolder = fso.GetFolder(fPath)
For Each fFolder In fFolder.SubFolders
Set fSubFolder = fso.GetFolder(fFolder.Path)
For Each fFile In fSubFolder.Files
If fFile.Name = FileToSearch Then
'do something with file
End If
Next fFile
Next fFolder
End Sub
I have a two codes. I would like the second code to perform the first code on all files in a directory. The first code works like a charm and does exactly what I need it to, this is that:
Sub STATTRANSFER()
' Transfers all STATS lines
Application.ScreenUpdating = False
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = "STATS"
Set f = Sheets(1)
Set e = Sheets("Stats")
Dim d
Dim j
Dim k
d = 1
j = 1
k = 1
Do Until IsEmpty(f.Range("A" & j))
If f.Range("A" & j) = "STATS" Then
e.Rows(d).Value = f.Rows(j).Value
d = d + 1
f.Rows(j).Delete
Else
j = j + 1
End If
Loop
Application.ScreenUpdating = True
End Sub
The second code looks like this:
Public Sub DataProcess()
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
filename = Dir(folderPath & "*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
For Each mySubFolder In mainFolder.SubFolders
filename = Dir(mySubFolder.Path & "\*.csv*")
Do While Len(filename) > 0
Set WB = Workbooks.Open(mySubFolder.Path & "\" & filename)
Call STATTRANSFER
ActiveWorkbook.Close SaveChanges:=True
filename = Dir
Loop
Next
End Sub
The second code does successfully loop through all of the folders and documents I want it to, however it performs my first code incorrectly. When I perform the first code on a sheet alone, it creates a new sheet called STATS then takes all lines from the first sheet that has the word STATS in column A and copies them to the new sheet, it then deletes the STATS lines out of the first sheet.
When I run it with the second code that goes through all the folders it doesn't work the same. I can see it create the sheet called STATS on my screen but then when it finishes and I open up on of the documents all the lines that have STATS in column A are on the first sheet, the STATS sheet is no longer there, and all the data that didn't have STATS in column A is gone. So I'm not sure what the problem is.
Keep your first sub as it is, replace your second sub with this:
Sub MM()
Dim file As Variant
Dim files As Variant
Dim WB As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set WB = Workbooks.Open(file)
STATTRANSFER
WB.Close True
Set WB = Nothing
Next
End Sub
just as an remark: your code only runs thru the first level of sub folders. If you want to go thru all sub level folders, you have to use a recursive method like:
Private Sub test()
readFileSystem ("C:\Temp\")
End Sub
Private Sub readFileSystem(ByVal pFolder As String)
Dim oFSO As Object
Dim oFolder As Object
' create FSO
Set oFSO = CreateObject("Scripting.FileSystemObject")
' get start folder
Set oFolder = oFSO.getFolder(pFolder)
' list folder content
listFolderContent oFolder
' destroy FSO
Set oFolder = Nothing
Set oFSO = Nothing
End Sub
Private Sub listFolderContent(ByVal pFolder As Object)
Dim oFile As Object
Dim oFolder As Object
' go thru all sub folders
For Each oFolder In pFolder.SubFolders
Debug.Print oFolder.Path
' do the recursion to list sub folder content
listFolderContent oFolder
Next
' list all files in that directory
For Each oFile In pFolder.Files
Debug.Print oFile.Path
Next
' destroy all objects
Set pFolder = Nothing
Set oFile = Nothing
Set oFolder = Nothing
End Sub
this is just an example and you have to call your first procedure of course still correct. So I would suggest to add a parameter to the first procedure where you can pass the workbook.
and BTW: always delcare your variables with datatype. Dim j will declare a VARIANT variable and not a Interger as you might want to have.
You see all STATS in the first sheet because you added an extra sheet to a CSV file and saved it. By definition, CSV file only saves and shows 1 sheet.
This modification to your code could solve your problem, as it calls itself to go through subfolders.
Try it.
Include your STATTRANSFER sub.
Public Sub DataProcess()
thisPath = ThisWorkbook.Path
process_folders (thisPath)
End Sub
Sub process_folders(thisPath)
Dim folderPath
Dim filename
Dim newfilename
Dim SavePath
Dim mySubFolder As Object
Dim mainFolder As Object
Dim WB As Workbook
Dim OrigWB As Workbook
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim name1 As String
Dim name2 As String
Set OrigWB = ThisWorkbook
Set objFSO = CreateObject("Scripting.FileSystemObject")
folderPath = ActiveWorkbook.Path
Set mainFolder = objFSO.GetFolder(folderPath)
folderPath = ActiveWorkbook.Path
filename = Dir(folderPath & "\*.csv")
Do While Len(filename) > 0
Set WB = Workbooks.Open(folderPath & "\" & filename)
Call STATTRANSFER
'save file as Excel file !!!
ActiveWorkbook.SaveAs _
filename:=(folderPath & "\" & filename), _
FileFormat:=xlOpenXMLWorkbook, _
CreateBackup:=False
ActiveWorkbook.Close (False)
filename = Dir
Loop
'now with each subfolder
For Each subfolder In mainFolder.SubFolders
process_folders (subfolder)
Next
End Sub
The problem was that you can only save a .csv with one sheet on it. Now the code looks like this.
Sub NewDataProcess()
Dim file As Variant
Dim files As Variant
Dim wb As Excel.Workbook
files = Filter(Split(CreateObject("WScript.Shell").Exec("CMD /C DIR """ & ActiveWorkbook.Path & "\*.csv"" /S /B /A:-D").StdOut.ReadAll, vbCrLf), ".")
For Each file In files
Set wb = Workbooks.Open(file)
Call STATTRANSFER(wb)
newfilename = Replace(file, ".csv", ".xlsm")
wb.SaveAs filename:=newfilename, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
wb.Close SaveChanges:=False
Set wb = Nothing
Next
End Sub
Now I need a way to delete the old files if someone can help with that. I dont want the CSV file at all anymore
I've got a code from here and I'm tweaking it for my need. My need is quite simple: I need it to download if it has the name of the Daily Tracker I'm keeping track of (as it changes daily with the Format(Now)). The problem is that it is not finding the attachment.
The code can find the email if I substitute the ElseIf to Next part for oOlItm.Display, but won't download the attachment.
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd/MM/yyyy")
Set oOlAp = GetObject(, "Outlook.application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
For Each oOlItm In oOlInb.Items
If InStr(oOlItm.Subject, NewFilename)) <> 0 Then
ElseIf oOlItm.Attachments.Count <> 0 Then
For Each oOlAtch In oOlItm.Attachments
oOlAtch.SaveAsFile (AttachmentPath)
Exit For
Next
Else
MsgBox "No attachments found"
End If
Exit For
Next
End Sub
The email:
This should work for you:
Sub AttachmentDownload()
Const olFolderInbox As Integer = 6
'~~> Path for the attachment
Const AttachmentPath As String = "C:\TEMP\TestExcel"
Dim oOlAp As Object
Dim oOlns As Object
Dim oOlInb As Object
Dim oOlItm As Object
Dim oOlAtch As Object
Dim oOlResults As Object
Dim x As Long
Dim NewFileName As String
NewFileName = "Daily Tracker " & Format(Now, "dd-MM-yyyy")
'You can only have a single instance of Outlook, so if it's already open
'this will be the same as GetObject, otherwise it will open Outlook.
Set oOlAp = CreateObject("Outlook.Application")
Set oOlns = oOlAp.GetNamespace("MAPI")
Set oOlInb = oOlns.GetDefaultFolder(olFolderInbox)
'No point searching the whole Inbox - just since yesterday.
Set oOlResults = oOlInb.Items.Restrict("[ReceivedTime]>'" & Format(Date - 1, "DDDDD HH:NN") & "'")
'If you have more than a single attachment they'll all overwrite each other.
'x will update the filename.
x = 1
For Each oOlItm In oOlResults
If oOlItm.attachments.Count > 0 Then
For Each oOlAtch In oOlItm.attachments
If GetExt(oOlAtch.FileName) = "xlsx" Then
oOlAtch.SaveAsFile AttachmentPath & "\" & NewFileName & "-" & x & ".xlsx"
End If
x = x + 1
Next oOlAtch
End If
Next oOlItm
End Sub
'----------------------------------------------------------------------
' GetExt
'
' Returns the extension of a file.
'----------------------------------------------------------------------
Public Function GetExt(FileName As String) As String
Dim mFSO As Object
Set mFSO = CreateObject("Scripting.FileSystemObject")
GetExt = mFSO.GetExtensionName(FileName)
End Function
Another way of doing it is from within Outlook:
Create a new folder in your Outlook Inbox and set a rule to move the email to this folder when it arrives. You can then write code to watch this folder and save the file as soon as it arrives.
Place this code within the ThisOutlookSession module in Outlook.
Dim WithEvents TargetFolderItems As Items
Const FILE_PATH As String = "C:\TEMP\TestExcel\"
Private Sub Application_Startup()
Dim ns As Outlook.NameSpace
Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item("Mailbox - Darren Bartrup-Cook") _
.Folders.Item("Inbox") _
.Folders.Item("My Email For Processing").Items
End Sub
Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
'when a new item is added to our "watched folder" we can process it
Dim olAtt As Attachment
Dim i As Integer
Dim sTmpFileName As String
Dim objFSO As Object
Dim sExt As String
If Item.Attachments.Count > 0 Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
sExt = objFSO.GetExtensionName(olAtt.FileName)
If sExt = "xlsx" Then
sTmpFileName = "Daily Tracker " & Format(Now, "dd-mm-yyyy") & ".xlsx"
End If
Item.UnRead = False
olAtt.SaveAsFile FILE_PATH & sTmpFileName
DoEvents
Next
End If
Set olAtt = Nothing
MsgPopup "A new attachment has been saved.", vbOKOnly, "New Daily Tracker"
End Sub
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
Create a new module in Outlook and put this code in there. This will create a messagebox that won't stop whatever you're doing.
Public Function MsgPopup(Optional Prompt As String, _
Optional Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional Title As String, _
Optional SecondsToWait As Long = 0) As VbMsgBoxResult
' Replicates the VBA MsgBox() function, with an added parameter
' to automatically dismiss the message box after n seconds
' If dismissed automatically, this will return -1: NOT ‘cancel’ or the default button choice.
' Nigel Heffernan, 2006. This code is in the public domain.
' Uses late-binding: bad for performance and stability, useful for code portability
' The correct declaration is: Dim objWshell As IWshRuntimeLibrary.WshShell
Dim objWshell As Object
Set objWshell = CreateObject("WScript.Shell")
MsgPopup = objWshell.Popup(Prompt, SecondsToWait, Title, Buttons)
Set objWshell = Nothing
End Function
I had this code working a few days ago, but forgot to save the working copy. It took me 4 weeks just to find this answer and would not like to take that much time again, so...
Everything here works, except the objWorkBook lines, which return the error:
"Variable 'objWorkBook' is used before it has been assigned a value. A null reference exception could result at runtime."
Any suggestions?
Dim objExcel As Excel.Application = System.Runtime.InteropServices.Marshal.GetActiveObject("Excel.Application")
Dim objWorkBook As Excel.Workbook
Dim totalWorkBooks As Integer = objExcel.Workbooks.Count
MsgBox(totalWorkBooks & " is Number of Open Workbooks")
Dim ActiveBookIndex As Integer = objExcel.ActiveWindow.Index
MsgBox(ActiveBookIndex & " is Active Window Index")
Dim FullName As String = objWorkBook.FullName
MsgBox(FullName & " is FullName")
Dim OnlyName As String = objWorkBook.Name
MsgBox(OnlyName & " is Name without the Path")
I forgot what Value I had assigned.
My objective is to compare an open Excel Workbook name with one in a known location so that if they match, my program can proceed. I need the code above so I can compare it to the following code in an If-Then so that my program can proceed.
Dim dir As String = System.Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments)
Dim FullFileName As String = dir & "\My_File_Name.xlsx"
On a positive note, I pieced together A solution, even though it's not the answer I was looking for....
Dim p() As Process = System.Diagnostics.Process.GetProcessesByName("Excel")
Dim Title As String = p(0).MainWindowTitle
Dim dir As String = System.Environment.GetFolderPath(Environment.SpecialFolder.MyDocuments)
Dim FullFileName As String = dir & "\" & Replace(Title, "Microsoft Excel - ", "") & ".xlsx"
MsgBox(dir)
MsgBox(Title)
MsgBox(FullFileName)
This will work for now, but I would like to solve it the other way.
Change the line
Dim objWorkBook As Excel.Workbook
to
Dim objWorkBook As Excel.Workbook = Nothing
Also your objWorkBook object is not assigned to anything before you are trying to use it in the line Dim FullName As String = objWorkBook.FullName
Is this what you are trying?
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim objExcel As Excel.Application = System.Runtime.InteropServices.Marshal.GetActiveObject("Excel.Application")
Dim objWorkBook As Excel.Workbook
Dim totalWorkBooks As Integer = objExcel.Workbooks.Count
MsgBox (totalWorkBooks & " is Number of Open Workbooks")
Dim ActiveBookIndex As Integer = objExcel.ActiveWindow.Index
MsgBox (ActiveBookIndex & " is Active Window Index")
'~~> Set the workbook to say first workbook.
'~~> You can use a loop here as well to loop through
'~~> the workbooks count
objWorkBook = objExcel.Workbooks(1)
Dim FullName As String = objWorkBook.FullName
MsgBox (FullName & " is FullName")
Dim OnlyName As String = objWorkBook.Name
MsgBox (OnlyName & " is Name without the Path")
'
'~~> Rest of the code
'
End Sub
End Class
EDIT: Followup from comments
But let's say I have 9 Workbooks already open, how do I get me app to index, manipulate, switch between them... without knowing the Full Path and File Names ahead of time?
Imports Excel = Microsoft.Office.Interop.Excel
Public Class Form1
Private Sub Button1_Click(sender As System.Object, e As System.EventArgs) Handles Button1.Click
Dim objExcel As Excel.Application = System.Runtime.InteropServices.Marshal.GetActiveObject("Excel.Application")
Dim objWorkBook As Excel.Workbook = Nothing
Dim FullName As String = ""
Dim OnlyName As String = ""
Dim totalWorkBooks As Integer = objExcel.Workbooks.Count
MsgBox (totalWorkBooks & " is Number of Open Workbooks")
For i As Integer = 1 To totalWorkBooks
objWorkBook = objExcel.Workbooks(i)
With objWorkBook
FullName = .FullName
OnlyName = .Name
MessageBox.Show (FullName & " is FullName and " & OnlyName & " is Name without the Path")
'
'~~> Rest of the code here to manipulate the workbook. For example
' objWorkBook.Sheets(1).Range("A1").Value = "Blah Blah"
'
End With
Next i
releaseObject (objExcel)
releaseObject (objWorkBook)
End Sub
'~~> Release the objects
Private Sub releaseObject(ByVal obj As Object)
Try
System.Runtime.InteropServices.Marshal.ReleaseComObject (obj)
obj = Nothing
Catch ex As Exception
obj = Nothing
Finally
GC.Collect()
End Try
End Sub
End Class