create folder and sub folders

[megatronixs]

Hi all,
I have the below code to create email and folders based on data from the database.
For now, I'm able to create the main folder and add a word document inside.
What could be changed on the code or added to add 2 sub folder named "Documents" and "Correspondence"

Any help in getting this solved would be great.

Greetings.

Option Compare Database

Private Sub SendEmail_Click()

On Error GoTo Err_open_word_Click



    Dim oApp As Object
    Dim path As String
    Dim filename As String
    Dim strEventPhotos As String
    
    'adding variable with path and file name, adding another backslash at the end of path
    path = "Y:\Developement\Folders\" & Me.BINnr & "_" & Me.CompanyName & "_" & Me.Analyst & "\"
    filename = Me.BINnr & Me.CompanyName & Me.Analyst & ".doc"
    
    'checking if the folder exist if not creating one
    If Dir(path, vbDirectory) = vbNullString Then
    MkDir path
    End If
    strEventPhotos = "Y:\Developement\Folders\" & Me.BINnr & "_" & Me.CompanyName & "_" & Me.Analyst
    Shell "EXPLORER.EXE " & strEventPhotos, vbNormalFocus
    Set oApp = CreateObject("Word.Application")
    oApp.Visible = True
    oApp.Documents.Add
    'oApp.activedocument.SaveAs filename:=path & filename
    If Dir(path & filename) = "" Then
        oApp.activedocument.SaveAs filename:=path & filename
    Else
        'MsgBox "File already exist!"
        oApp.Quit
    End If
Debug.Print path
    
    
Dim rst As DAO.Recordset
    Dim strSQL As String
    Dim olApp As Outlook.Application
    Dim objMail As Outlook.MailItem
    
    Dim strTableBeg As String
    Dim strTableBody As String
    Dim strTableEnd As String
    Dim strFntNormal As String
    Dim strTableHeader As String
    Dim strFntEnd As String
        
    Dim dblTotGross As Double
    Dim dblTotCommission As Double

    'Define format for output
    strTableBeg = "<br><br><table border=1 cellpadding=3 cellspacing=0>"
    strTableEnd = "</table>Dear analyst,<br><br>Please note that a new case has been assigned to you.<br>Please find below the link:<br><br><br>Regards. <br><br>Path: " & path
    strTableHeader = "<font size=3 face=" & Chr(34) & "Verdana" & Chr(34) & "><b>" & _
                        "<tr bgcolor=lightblue>" & _
                            TD("BIN") & _
                            TD("CompanyName") & _
                            TD("Analyst") & "</tr></b></font>"
'                            TD("Trans Type") & _
'                            TD("Effective Date") & _
'                            TD("Gross") & _
'                            TD("Commission") & _
'                            TD("Net") & _

    strFntNormal = "<font color=black face=" & Chr(34) & "Verdana" & Chr(34) & " size=2>"
    strFntEnd = "</font>"
    
    strSQL = "SELECT * FROM TARA WHERE Email = True"
    Set rst = CurrentDb.OpenRecordset(strSQL)
    
    'Build HTML Output for the DataSet
    strTableBody = strTableBeg & strFntNormal & strTableHeader
    
    
    Do Until rst.EOF
        strTableBody = strTableBody & _
                        "<tr>" & _
                            TD("BINnr") & _
                            TD("CompanyName") & _
                            TD("Analyst") & "</tr>"
'                            TD(rst!TranType) & _
'                            TD(rst!BillEffDte) & _
'                            TD(Format(rst!Gross, "currency")) & _
'                            TD(Format(rst!Comm, "currency")) & _
'                            TD(Format(rst!Net, "currency")) & _
                        "</tr>"
''        dblTotGross = dblTotGross + rst!Gross
'        dblTotCommission = dblTotCommission + CDbl(rst!Comm)
        
        rst.MoveNext
    Loop

    'Totals
'    strTableBody = strTableBody & _
                    "<tr><TD align=right colspan=5 nowrap><b>Totals</td></b>"
'                    & _
'                        TD (Format(dblTotGross, "BINnr")) & TD(Format(dblTotCommission, "BINnr")) & "</tr>"
'                        TD(Format(dblTotGross + dblTotCommission, "currency")) &
                    
    
    'strTableBody = strTableBody & strFntEnd & strTableEnd
    strTableBody = strFntEnd & strTableEnd & strTableBody
    
    rst.Close
    
    'Create e-mail item
    Set olApp = Outlook.Application
    Set objMail = olApp.CreateItem(olMailItem)
    With objMail
        'Set body format to HTML
        .To = " "
        .Subject = "New Case has been assigned to you "
        .BodyFormat = olFormatHTML
        '.HTMLBody = "<HTML><BODY>" & strFntNormal & strTableBody & " </BODY></HTML>"   'original
        .HTMLBody = "<HTML><BODY>" & strTableBody & strFntNormal & " </BODY></HTML>"
        .Display
    End With
    
Clean_Up:
    Set rst = Nothing
    
Exit_open_word_Click:
    Exit Sub

Err_open_word_Click:
    MsgBox Err.Description
    Resume Exit_open_word_Click

Debug.Print path

End Sub

 

[CJ_London]

 ...
 ...
 If Dir(path, vbDirectory) = vbNullString Then
    MkDir path
     MkDir path & "Documents\"
     MkDir path & "Correspondence\"
 End If
 ...
 ...

 

[megatronixs]

Hi,
I had no idea that it could be that simple so I could not come up with it in a thousand years.
THANK YOU

Greetings.

 

[smig]

This piece of code will create a DIR in any level, including on network drives:

Public Sub CreateDirectory(Dir)

Dim fso
Dim SplitDir() As String
Dim CreateDir As String
Dim i As Integer

SplitDir = Split(Dir, "\")

Set fso = CreateObject("Scripting.FileSystemObject")

i = 0

For i = LBound(SplitDir()) To UBound(SplitDir())
        If i = 0 Then
            CreateDir = SplitDir(i)
        Else
            CreateDir = CreateDir & "\" & SplitDir(i)
        End If
        If Right(CreateDir, 1) = ":" Or NullOrEmpty(SplitDir(i)) Or (Left(CreateDir, 2) = "\\" And i = 2) Then
                  ' --- Drive name Or Network drive name - don't create
        Else
            If fso.FolderExists(CreateDir) = False Then
                fso.CreateFolder (CreateDir)
            End If
        End If
Next i

End Sub

Not sure why I changed the DIr() and MKDir() into the FSO thing

 

[megatronixs]

Hi Smig,

I need to add one more option. Depending on the situation, it should create the folder inside a different folder. If a field has a value of risk high, it should go to a folder like as example Main\Risk High\1234_Client 1 Ltd._Peter.
If it has midium risk, to a folder inside Main\Risk_Medium\1234_Client 1 Ltd._Peter.

How can I adjust the above code to create a folder based on the above criteria.

Greetings.

 

[smig]

The code I gave you will create any folder, in any level you send to it.
It's up to you to send the correct path.

It should be something like:

Dim DirToCreate as string
   
If .... Then
  DirToCreate  = "c:\Main\Risk High\1234_Client 1 Ltd._Peter\NewFolder"
Else
  DirToCreate  = "c:\Main\Risk_Medium\1234_Client 1 Ltd._Peter\NewFolder"
end if


call CreateDirectory(DirToCreate )

 

[megatronixs]

Hi Smig,

It is workig

Greetings.