Open attachement from Lotus Notes with VBA - excel

I want to open an attachment from Lotus Notes with VBA.
The Problem is that I don't get the path out of Lotus Notes.
I would be very thankful if you can give me a code, with how I can open this path without hardcoding it.
Here is the complete Code which does not work...
Function OpenURL(URL As String, WindowState As W32_Window_State) As Boolean
'Opens passed URL with default application, or Error Code (<32) upon error
Dim lngHWnd As Long
Dim lngReturn As Long
lngReturn = ShellExecute(lngHWnd, "open", URL, vbNullString, _
vbNullString, WindowState)
OpenURL = (lngReturn > 32)
End Function
Sub OpenLotusNotes()
Dim objNotesSession As Object
Dim objNotesFile As Object
Dim objNotesDocument As Object
Dim objNotesField As Object
Dim objNotesUIWorkSpace As Object
Dim objNotesView As Object
Set objNotesSession = CreateObject("Notes.NotesSession")
Set objNotesFile = objNotesSession.GETDATABASE("ATLAS40", "ACITF\PRODUCTION\USN\ePayable.nsf")
'("Server", "Datenbank")
Set objNotesUIWorkSpace = CreateObject("Notes.NotesUIWorkSpace")
Set i = Sheet1.Range("B20")
Dim DocNum As Variant
Dim DocName As Variant
Set objNotesView = objNotesFile.GetView("1.CheckView")
Set objNotesDocument = objNotesView.GetFirstDocument
Dim body As Variant
Dim ms As String
ms = ""
If Not objNotesDocument Is Nothing Then
'initial set
DocNum = objNotesDocument.InvoiceNumber
DocName = objNotesDocument.InvoiceDocumentNumber
Dim DocFound As Boolean
DocFound = False
While Not DocFound = True
DocNum = objNotesDocument.InvoiceNumber
DocName = objNotesDocument.InvoiceDocumentNumber
If DocNum(0) = i Then
ms = "You are about to open the attachement located in " & DocNum(0) & " " & DocName(0) & " in The Way we do things database from Database Server " & objNotesFile.server & " with Database File name " & objNotesFile.Filename & "."
MsgBox (ms)
DocFound = True
Set body = objNotesDocument.getfirstitem("$FILE")
'subject der mail ermitteln
For Each obj In body.embeddedobjects
'MsgBox (Environ("TEMP") & "\" & obj.Name)
'MsgBox (obj.Name)
Call obj.ExtractFile(Environ("TEMP") & "\" & obj.Name)
OpenURL "file://" & Environ("TEMP") & "\" & obj.Name, Show_Maximized
Next
End If
Set objNotesDocument = objNotesView.GetNextDocument(objNotesDocument)
Wend
End If

You can't open the file by accessing the $File item, so even if you had the correct syntax (using GetFirstItem("$File)) it would still not work.
You need to use objNotesDocument.EmbeddedObjects() This will return an array of NotesEmbeddedObject objects. If there's only one file attachment in the document, there will be only one element in the array. You can use the ExtractFile method of the NotesEmbeddedObject class to save a copy of the file to the filesystem, and you can open it from there.

Related

Excel VB - Shell object and Items extended properties

First of all i'm not a VB geek, but I've found my way through googling around and I just can't figure out this one...
Put simply, I made a macro that allows me to select pdfs, zip them, and build a list of those zipped files on another sheet, then automatically prepares an email with that zip as an attachment. I want that list to contain the following entries:
The file name without the path, and without the extension (done and code works, though I've read that I may have issues if "hide extension of know file type" is activated, not tested);
Then each file name is hyperlinked to the actual file location before being zipped (done and code works);
The document title, which is an extended property (title metadata) of the pdf (WITHOUT having Acrobat installed, done and code works);
The document Tags (or Keywords?), again extended property of the pdf. It's this one that I need help with!. I browsed through office documentations and just can't find the info I need.
Like I said, I'm not a coder, I know my code is not optimal so please don't judge me. I just want it to work, then I'll optimize it ;)
To get the title property I use the following code :
Sheet1.Range("F54").Value = oShell.Namespace("FOLDERPATH").Items.Item("FILE IN FOLDERPATH).ExtendedProperty("DocTitle")
"DocTitle" is the property name for the title. I just can't find what it is to extract "Tags", I've tried "Tags", "DocTags" and "Keywords" and I got nothing. I've tried using GetDetailsOf("FILE", 18), but it returns the string "Tags", not the actual tags...like... the title of the tags...
Here is the full code :
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Sub ZipAndEmailFiles() 'By selecting individually
Dim CurDateTime As String
Dim DefaultFilePath As String
Dim FilesToZip As String
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim FileCount As Long
Dim FileNumb As Integer
Dim LastZipNumb As Integer
Dim FileNames As Variant
Dim VArr As Variant
Dim ZipFileName As Variant
Dim ProjectNumb As String
LastZipNumb = Main.Range("C13").Value 'Get last qty of file(s) zipped
CurDateTime = Format(Now, "yyyy-mmm-dd h-mm-ss") 'Get actual date and time
DefaultFilePath = Application.DefaultFilePath
If Right(DefaultFilePath, 1) <> "\" Then DefaultFilePath = DefaultFilePath & "\"
ProjectNumb = Main.Range("C4").Value 'Get project number (Entry by user)
ZipFileName = DefaultFilePath & ProjectNumb & "-" & CurDateTime & ".zip" 'Name of zip
'Browse For Files & Select Multiple files
FileNames = Application.GetOpenFilename("PDF Files (*.pdf),*.pdf", MultiSelect:=True, Title:="Select Files you want to Zip & Email")
If IsArray(FileNames) = False Then Exit Sub
'Create Empty Zipped File in DefaultFilePath
If Len(Dir(ZipFileName)) > 0 Then Kill ZipFileName
Open ZipFileName For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
FileNumb = 0
'Clear cells from previous list
For FileCount = 1 To LastZipNumb
FileNumb = FileNumb + 1
ThisWorkbook.Worksheets("Transmittal").Range("B54:F54").Offset(2 * (FileNumb - 1), 0).Clear
Next
FileNumb = 0
'Build list & Fill zip
For FileCount = LBound(FileNames) To UBound(FileNames)
FileNumb = FileNumb + 1
'Insert name of each processed file, removing path, revision and extension
Transmittal.Range("B54").Offset(2 * (FileNumb - 1), 0).Value = Left(GetFilenameFromPath(FileNames(FileNumb)), 12)
'Create hyperlink to reference file being zipped
ActiveSheet.Hyperlinks.Add Transmittal.Range("B54").Offset(2 * (FileNumb - 1), 0), FileNames(FileNumb)
'Inscrire le titre dans la case indiquée
'Transmittal.Range("F54").Offset(2 * (FileNumb - 1), 0).Value = oShell.Namespace(FolderFromPath(FileNames(FileNumb))).GetDetailsOf(FileNameFromPath(FileNames(FileNumb)), FileNumb)
Transmittal.Range("D54").Offset(2 * (FileNumb - 1), 0).Value = oShell.Namespace(FolderFromPath(FileNames(FileNumb))).Items.Item(FileNameFromPath(FileNames(FileNumb))).ExtendedProperty("Keywords")
Transmittal.Range("F54").Offset(2 * (FileNumb - 1), 0).Value = oShell.Namespace(FolderFromPath(FileNames(FileNumb))).Items.Item(FileNameFromPath(FileNames(FileNumb))).ExtendedProperty("DocTitle")
'Copy said file in zip
oShell.Namespace(ZipFileName).CopyHere FileNames(FileCount)
'Keep Script waiting until compressing is done
On Error Resume Next
Do Until oShell.Namespace(ZipFileName).Items.Count = FileNumb
Sleep (100) 'Wait 100ms after each copied file
Loop
On Error GoTo 0
Next FileCount
Main.Range("C22").Value = ZipFileName 'Place zip location, to be attached to email
Main.Range("C13").Value = UBound(FileNames)
EmailZipFile
End Sub
Sub EmailZipFile()
Dim OutApp As Object
Dim OutEmail As Object
Set OutApp = CreateObject("Outlook.application")
Set OutEmail = OutApp.CreateItem(0)
With OutEmail
.To = Main.Range("C13").Value ' Email
If Main.Range("C16").Value <> "" Then .Attachments.Add Main.Range("C16").Value 'Zipped file
.Subject = Main.Range("C15").Value 'Email subject
.Body = Main.Range("C17").Value 'Email body
.Display 'Show Outlook windows
End With
End Sub
Function FileNameFromPath(ByVal strPath As String) As String
FileNameFromPath = Right(strPath, Len(strPath) - InStrRev(strPath, "\"))
End Function
Function FolderFromPath(ByVal strPath As String) As String
FolderFromPath = Left(strPath, InStrRev(strPath, "\"))
End Function
For the code to fully work, you have to have Outlook installed. But even without Outlook, the list generation works. Thanks for your help, and your time!

How to get Outlook appointments from a given date in Excel

I want to display Outlook Calendar appointments from a given date in a MessageBox. Unfortunately the code I am using does not show any appointments for today. If i change my code to
sfilter = "[Start] >= '" & startDate & "' "
then i get todays appointments with all future appointments for other dates. I want to only show appointments for the specified date.
The date selection is from a UserForm called cmDates.srtDate.Value
sFilter is the variable I am using the hold the date filter throughout the code
Code
Public Function getOutlookAppointments() As String
Dim oOutlook As Object
Dim oNS As Object
Dim oAppointments As Object
Dim oFilterAppointments As Object
Dim oAppointmentItem As Object
Dim bOutlookOpened As Boolean
' Dim rslt As String
Dim sfilter As String
Dim startDate As Date
Dim displayText As String
Dim start As Date
Const olFolderCalendar = 9
On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application") 'Bind to existing instance of Outlook
If Err.Number <> 0 Then 'Could not get instance of Outlook, so create a new one
Err.Clear
Set oOutlook = CreateObject("Outlook.Application")
bOutlookOpened = False 'Outlook was not already running, we had to start it
Else
bOutlookOpened = True 'Outlook was already running
End If
On Error GoTo Error_Handler
DoEvents
Set oNS = oOutlook.GetNamespace("MAPI")
Set oAppointments = oNS.GetDefaultFolder(olFolderCalendar)
startDate = cmDates.srtDate.value
'Apply a filter so we don't waste our time going through old stuff if we don't need to.
sfilter = "[Start] = '" & startDate & "' "
Set oFilterAppointments = oAppointments.Items.Restrict(sfilter)
For Each oAppointmentItem In oFilterAppointments
getOutlookAppointments = getOutlookAppointments & oFilterAppointments.Count & " appointment(s) found" & vbCrLf & vbCrLf & oAppointmentItem.Subject & vbCrLf & oAppointmentItem.start & vbCrLf & oAppointmentItem.End & vbCrLf & vbCrLf
'displayText = displayText & oAppointmentItem.Subject
Next
MsgBox prompt:=getOutlookAppointments, _
Title:="Appointments for"
If bOutlookOpened = False Then 'Since we started Outlook, we should close it now that we're done
oOutlook.Quit 'There seems to be a delay in this action taking place, but does eventually take place
End If
Error_Handler_Exit:
On Error Resume Next
Set oAppointmentItem = Nothing
Set oFilterAppointments = Nothing
Set oAppointments = Nothing
Set oNS = Nothing
Set oOutlook = Nothing
Exit Function
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
"Error Number: " & Err.Number & vbCrLf & _
"Error Source: GetFutureOutlookEvents" & vbCrLf & _
"Error Description: " & Err.Description _
, vbOKOnly + vbCritical, "An Error has Occured!"
Resume Error_Handler_Exit
outlookDates = False
End Function
Your restriction should have two parts - Start > today's midnight, and Start < tomorrow's midnight. You only have the first part.
Also keep in mind that if you want instances of the recurring activities (and not just the master appointments), you need to use the Items.IncludeRecurrences property - see https://learn.microsoft.com/en-us/office/vba/api/outlook.items.includerecurrences
There are several aspects:
To retrieve all Outlook appointment items from the folder that meets the predefined condition, you need to sort the items in ascending order and set the IncludeRecurrences to true. You will not catch recurrent appointments if you don’t do this before using the Restrict method!
Microsoft doesn’t recommend using the Count property in case you set the IncludeRecurrences property. The Count property may return unexpected results and cause an infinite loop.
Although dates and times are typically stored with a Date format, the Find and Restrict methods require that the date and time be converted to a string representation. To make sure that the date is formatted as Microsoft Outlook expects, use the Format function available in VBA. So, you must specify the date in the format which Outlook understand.
Format(youDate, "ddddd h:nn AMPM")
For example, here is a sample VB.NET code:
Imports System.Text
Imports System.Diagnostics
' ...
Private Sub RestrictCalendarItems(folder As Outlook.MAPIFolder)
Dim dtEnd As DateTime = New DateTime(DateTime.Now.Year, DateTime.Now.Month, _
DateTime.Now.Day, 23, 59, 0, 0)
Dim restrictCriteria As String = "[Start]<=""" + dtEnd.ToString("g") + """" + _
" AND [End]>=""" + DateTime.Now.ToString("g") + """"
Dim strBuilder As StringBuilder = Nothing
Dim folderItems As Outlook.Items = Nothing
Dim resultItems As Outlook.Items = Nothing
Dim appItem As Outlook._AppointmentItem = Nothing
Dim counter As Integer = 0
Dim item As Object = Nothing
Try
strBuilder = New StringBuilder()
folderItems = folder.Items
folderItems.IncludeRecurrences = True
folderItems.Sort("[Start]")
resultItems = folderItems.Restrict(restrictCriteria)
item = resultItems.GetFirst()
Do
If Not IsNothing(item) Then
If (TypeOf (item) Is Outlook._AppointmentItem) Then
counter = counter + 1
appItem = item
strBuilder.AppendLine("#" + counter.ToString() + _
" Start: " + appItem.Start.ToString() + _
" Subject: " + appItem.Subject + _
" Location: " + appItem.Location)
End If
Marshal.ReleaseComObject(item)
item = resultItems.GetNext()
End If
Loop Until IsNothing(item)
If (strBuilder.Length > 0) Then
Debug.WriteLine(strBuilder.ToString())
Else
Debug.WriteLine("There is no match in the " _
+ folder.Name + " folder.")
End If
catch ex As Exception
System.Windows.Forms.MessageBox.Show(ex.Message)
Finally
If Not IsNothing(folderItems) Then Marshal.ReleaseComObject(folderItems)
If Not IsNothing(resultItems) Then Marshal.ReleaseComObject(resultItems)
End Try
End Sub
You may find the following articles helpful:
How To: Use Restrict method in Outlook to get calendar items
How To: Retrieve Outlook calendar items using Find and FindNext methods

Excel VBA file content is persistent despite KILL

I have an Excel VBA script that takes two files and performs a Relace function on one column. This all works fine if i step through it slowly. But if i run it without any breaks then it produces a file that still contains the characters that i replaced ?
I have added "Kill" file commands to ensure that i am creating new files, even my output file i am using a datestamp to ensure its a unique file then renaming it. But i then upload it to an FTP server as part of the script and when viewing what i have uploaded, it has the characters i removed ? even though when i view my output file before uploading, it doesnt ?????
Private Sub OutputFile()
Dim strNowDifferentiator As String
Dim strPath As String
Dim AgentStr As String
Dim AccessTypeLong As Long
Dim ProxyNameStr As String
Dim ProxyBypassStr As String
Dim FlagsLong As Long
Dim InternetSessionLong As Long
Dim ServiceLong As Long
Dim ContextLong As Long
Dim FTPSessionLong As Long
Dim FailIfExistsBool As Boolean
Dim FlagsAndAttributesLong As Long
Dim SomeThingLong As Long
Dim MyInternetHandleLong As Long
Dim MyFTPHandleLong As Long
Dim SomeInteger As Integer
Dim FTPSuccessBool As Boolean ' Did the FTP download work?
AgentStr = "GreenTreeTest" ' can be whatever
AccessTypeLong = 0 ' zero appears to work fine
ProxyNameStr = "" ' nul works fine here
ProxyBypassStr = "" ' nul works fine here
FlagsLong = 0 ' zero appears to work fine
MyInternetHandleLong = InternetOpen(AgentStr, AccessTypeLong, ProxyNameStr, ProxyBypassStr, FlagsLong)
' MsgBox MyInternetHandleLong
'MyInternetHandleLong is obtained above
ServiceLong = 1 ' this for the FTP service (2 = gopher, 3 = http)
FlagsLong = 0 ' 0 appears to work fine here
ContextLong = 0 ' 0 appears to work fine here
MyFTPHandleLong = InternetConnect(MyInternetHandleLong, "mercury.ingrammicro.com", 21, "CDW_PRICEFILE", "XXXXX", ServiceLong, FlagsLong, ContextLong)
strNowDifferentiator = Replace(Replace(Now(), "/", " "), ":", "")
strPath = "\\Sov-fs3\Departmental\Supply Chain\Feeds\"
Application.DisplayAlerts = False
Call subUpdateProgressLabel("Producing the output file...")
'DeleteFile ("C:\temp\CDWFeed.csv")
DeleteFile (strPath & "CDWFeed.csv")
ThisWorkbook.Sheets("Output").Copy
'ActiveWorkbook.SaveAs Filename:="C:\temp\CDWFeed.csv", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.SaveAs Filename:=strPath & "CDWFeed" & strNowDifferentiator & ".csv", FileFormat:=xlCSV, CreateBackup:=True
ActiveWorkbook.Close SaveChanges:=False
Name strPath & "CDWFeed" & strNowDifferentiator & ".csv" As strPath & "CDWFeed.csv"
Call FtpDeleteFile(MyFTPHandleLong, "CDWFeed.csv")
Application.DisplayAlerts = True
Sheets("Output").Cells.Clear
Call subUpdateProgressLabel("Uploading file to Ingram fTP...")
'removed SHELL as doesnt work well within CITRIX
'Shell ("ftp -s:" & Chr(34) & "\\Sov-fs3\Departmental\Supply Chain\Feeds\script.txt" & Chr(34) & " mercury.ingrammicro.com")
Call FtpUpload("\\Sov-fs3\Departmental\Supply Chain\Feeds\CDWFeed.csv", "CDWFeed.csv", "mercury.ingrammicro.com", 21, "CDW_PRICEFILE", "XXXXXX")
End Sub

Function to direct debug to text file

I would like to write a function to would allow me to use Print #Debug, "text" throughout my future modules to collect debug statements.
Sub output_debug()
Dim WshShell As Object
Dim Desktop As String
Dim Debug As Integer
Debug = FreeFile()
Set WshShell = CreateObject("WScript.shell")
Desktop = WshShell.specialfolders("Desktop")
Open Desktop & "\VBA_output.txt" For Output As #Debug
Print #Debug, "test"
Close #Debug
End Sub
How can I move from the above, to defining a function that would allow me to use call output_debug() in a module so all my Print #Debug, would print to that file ? I would imagine I need to create another function called close_output() that has close #Debug
I did something like this in the past. Here is what I came up with. It relies on having a reference to Microsoft Scripting Runtime in any project that uses it. You can store the following subs in a module e.g. DebugLogger (which is what I use) that can be first exported then imported into any module that you want to have this functionality. It mimics the behavior of Debug.Print but sends the output to a file whose name is a function of the workbook's name. I toyed with the idea of time-stamping individual entries but rejected the idea as being too far from the functionality of Debug.Print (I do, however, time stamp the date of creation). Once you import the module and establish the right reference then you can just use DebugLog anywhere you would have used DebugPrint. As a default it also prints to the debug window. You can drop that part of the code entirely or switch what the default is.
Function GetFullDebugName() As String
'This function returns a string of the form
'*xldebug.txt, where *.* is the full name of the workbook
Dim MyName As String
Dim NameParts As Variant
MyName = ThisWorkbook.FullName
NameParts = Split(MyName, ".")
GetFullDebugName = NameParts(0) & "xldebug.txt"
End Function
Sub CreateDebugFile()
'file created in same directory as
'calling workbook
Dim DebugName As String
Dim fso As FileSystemObject
Dim MyStream As TextStream
Set fso = New FileSystemObject
DebugName = GetFullDebugName
Set MyStream = fso.CreateTextFile(DebugName)
MyStream.WriteLine "This debug file was created " _
& FormatDateTime(Date) _
& " at " & FormatDateTime(Time)
MyStream.Close
End Sub
Sub DebugLog(DebugItem As Variant, Optional ToImmediate As Boolean = True)
Dim DebugName As String
Dim fso As FileSystemObject
Dim MyStream As TextStream
Set fso = New FileSystemObject
DebugName = GetFullDebugName
'check to see if DebugFile exist
'if not, create it:
If Not fso.FileExists(DebugName) Then CreateDebugFile
Set MyStream = fso.OpenTextFile(DebugName, ForAppending)
MyStream.WriteLine DebugItem
MyStream.Close
If ToImmediate Then Debug.Print DebugItem
End Sub
Try a subroutine like this...
It will log text to a text file with a date stamp, so new file new day.
You have an option to pass it the ERR object if you trap the error in your code and it will log the error message with a highlight.
call debuglog("my log entry")
call debuglog("my log entry",err)
Public Sub DebugLog(sLogEntry As String, Optional ByVal oErr As Object)
' write debug information to a log file
Dim iFile As Integer
Dim sDirectory As String
Dim errNumber, errDescription As Variant
Dim l As Integer
If Not oErr Is Nothing Then
errNumber = oErr.Number
errDescription = oErr.Description
l = IIf(Len(errDescription) > Len(sLogEntry), Len(errDescription), Len(sLogEntry))
End If
On Error GoTo bail
sfilename = VBA.Environ("Homedrive") & VBA.Environ("Homepath") & "\My Documents\Debuglog" & "\debuglog" & Format$(Now, "YYMMDD") & ".txt"
iFile = FreeFile
Open sfilename For Append As iFile
If Not oErr Is Nothing Then
sLogEntry = "/" & String(5 + (l - Len(sLogEntry)), "-") & " " & sLogEntry & " " & String(5 + (l - Len(sLogEntry)), "-") & "\"
Print #iFile, Now; " "; sLogEntry
Print #iFile, Now; " "; errNumber
Print #iFile, Now; " "; errDescription
Print #iFile, Now; " "; "\" & String(Len(sLogEntry) - 2, "-") & "/"
Else
Print #iFile, Now; " "; sLogEntry
End If
bail:
Close iFile
End Sub
example logfile output
27/03/2015 10:44:27 -- COMIT Form Initialize - Complete
27/03/2015 10:44:27 - COMIT Active
27/03/2015 10:44:34 /----- -- Error Populating Opportunity Form: frmBluesheet.PopulateForm() -----\
27/03/2015 10:44:34 381
27/03/2015 10:44:34 Could not get the Column property. Invalid property array index.
27/03/2015 10:44:34 \-----------------------------------------------------------------------------/

Connecting two path strings to get the final path?

I'm trying to save excel file into a specific path.
So basically, when I click the button, I'm creating a folder, and want to save the file inside that folder.
The created folder has the current month as name. I'm trying to save into that current month folder.
'Create folder as Month Name. Save filename as date inside "month".
Dim sDate As String = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
Dim sMonth As String = DateTime.Now.ToString("MMMM")
Dim sFolder = Application.StartupPath & "\Resources\Excel\"
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
Dim sfinal = Path.Combine(sFolder, sMonth)
xlSh.SaveAs(sfinal & Format(sDate) & ".xlsx")
xlApp.Workbooks.Close()
xlApp.Quit()
As it is, this code doesn't give me any errors. But instead of creating a folder named "March" <-current month and saving inside it, it saves the file in \Excel\ and it also creates folder in the same place.
you could use the following function (similar to .NET System.IO.Path.Combine)
Function PathCombine(path1 As String, path2 As String)
Dim combined As String
combined = path1
If Right$(path1, 1) <> Application.PathSeparator Then
combined = combined & Application.PathSeparator
End If
combined = combined & path2
PathCombine = combined
End Function
Hope this helps!
After long hours of excruciating pain, I've finally did it!
Apparently I was missing an "\"
Since "sMonth" became dynamic name, which later I wanted to use as path, and save files in that folder. I needed to simply put that "\" after sMonth, to tell it to save inside it.
Before I realize this... I've broken down, simplified the code as much as I could so I can logically connect the pieces. What I ended up with, is something slightly different. Now the SaveAS properly saves the file inside the new folder.
Dim sDate As String
sDate = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
Dim sMonth As String
sMonth = DateTime.Now.ToString("MMMM")
Dim sFileName As String
sFileName = sDate + ".xlsx"
Dim sFolder As String
sFolder = Application.StartupPath & "\Resources\Excel\"
Dim sfinal As String
sfinal = (sFolder & sMonth & "\") '<- this thingie here o.O
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
xlSh.SaveAs(sfinal & Format(sFileName))
xlApp.Workbooks.Close()
xlApp.Quit()
Thanks for the help.
You don't appear to actually be setting the save path to the created directory. Instead, I believe you're appending the month to the beginning of the file name in the xlSh.SaveAs(sFinal & Format(sDate) & ".xlsx"). Basically (though I'm not sure of the specific command) you need to navigate to the folder you created after you create it. Probably something to the format of
My.Computer.FileSystem.ChangeDirectory(sFolder & Format(sMonth))
though I don't know that that specific command actually exists as I wrote it.
To those who have been wondering wtf I was doing with all this, here is the full sub. And if anyone needs something similar. Thanks for the support. Problem has been resolved.
Private Sub Button_Click(sender As Object, e As EventArgs) Handles Button.Click
Dim xlApp As Excel.Application
Dim xlSh As Excel.Worksheet
xlApp = New Excel.Application
xlApp.Workbooks.Add()
xlSh = xlApp.Workbooks(1).Worksheets(1)
'Items from listbox1 to be exported into excel, second row, second column.
Dim row As Integer = 2
Dim col As Integer = 2
For i As Integer = 0 To ListBox1.Items.Count - 1
xlSh.Cells(row, col) = ListBox1.Items(i)
row = row + 1
Next
row += 1
col = 1
'Items from listbox2 to be exported into excel, second row, third column.
Dim row2 As Integer = 2
Dim col2 As Integer = 3
For i As Integer = 0 To ListBox2.Items.Count - 1
xlSh.Cells(row2, col2) = ListBox2.Items(i)
row2 = row2 + 1
Next
row2 += 1
col2 = 1
'Create folder as Month Name. Save filename as date inside that folder.
'Make filename be yyyy-MM-DD_HH-mm-ss
Dim sDate As String
sDate = DateTime.Now.ToString("yyyy-MM-dd") & "_" & DateTime.Now.ToString("HH-mm-ss")
'This will be used as name for the new folder.
Dim sMonth As String
sMonth = DateTime.Now.ToString("MMMM")
'Filename + extension.
Dim sFileName As String
sFileName = sDate + ".xlsx"
'This is the path.
Dim sFolder As String
sFolder = Application.StartupPath & "\Resources\Excel\"
'This is the path combined with sMonth to make the final path.
Dim sfinal As String
sfinal = (sFolder & sMonth & "\")
'Check if folder with the name sMonth already exists.
If Dir(sFolder, vbDirectory) = sMonth Then
'If it exist, then simply save the file inside the folder.
xlSh.SaveAs(sfinal & Format(sFileName))
Else
'If it doesn't exist:
'This is the creation of sMonth folder, inside "\excel\.
My.Computer.FileSystem.CreateDirectory(sFolder & Format(sMonth))
'This saves the excel file at path sfinal, with filename of sFileName
xlSh.SaveAs(sfinal & Format(sFileName))
End If
'Close everything.
xlApp.Workbooks.Close()
xlApp.Quit()
End Sub
I find this method to be much easier.
Create a FileSystemObject and use BuildPath Method, like so:
Set fs = CreateObject("Scripting.FileSystemObject")
skPath = fs.BuildPath(ActiveDocument.Path, "Survival Story of Sword King")
Attention: ActiveDocument.Path is current directory in Word and does not work in excel or other. for excel it would be ActiveWorkbook.Path
My point is some methods or namespace are application specific.

Resources