Create folder make it shareable in VBA

Question

Looking for such a topic, I have found VBScript that do the task in successful way Here's the VBScript https://blogs.msdn.microsoft.com/imayak/2008/12/05/vbscript-for-creating-and-sharing-a-folder/# I tried to convert this to work on VBA

Sub MyTest()
'--------------------------------------
'Script Start
'Owner - Imayakumar J.
'Date - December 5 2008
'--------------------------------------

'---------------------------------------------------------
' Get the Folder name
'---------------------------------------------------------

'wscript.Echo Date

Dim thismonth, thisday, thisyear, foldername

'wscript.echo Month(Date)

thismonth = Month(Date)
thisday = Day(Date)
thisyear = Year(Date)

If Len(thisday) = 1 Then
thisday = "0" & thisday
End If

'foldername = thismonth&thisday&thisyear
foldername = thismonth & thisday & thisyear
'----------------------------------------------------
'Create folder
'----------------------------------------------------

Dim filesys, returnvalue

Set filesys = CreateObject("Scripting.FileSystemObject")

'wscript.Echo returnvalue

filesys.CreateFolder "C:\" & foldername

'---------------------------------------------------------
' Check if another shar with the same name exists
'---------------------------------------------------------

strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set colShares = objWMIService.ExecQuery _
("Select * from Win32_Share Where Name = 'INGEST'")
For Each objShare In colShares
objShare.Delete
Next

'-----------------------------------------------------
' Share the created folder
'-----------------------------------------------------

Const FILE_SHARE = 0
Const MAXIMUM_CONNECTIONS = 25
strComputer = "."
Set objWMIService = GetObject("winmgmts:" _
& "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
Set objNewShare = objWMIService.Get("Win32_Share")
errReturn = objNewShare.Create _
("C:\" & foldername, "INGEST", FILE_SHARE, _
MAXIMUM_CONNECTIONS, "Notes to Exchange Migration Share.")

If errReturn = "0" Then
MsgBox "Success"
Else
MsgBox "Task Failed"
End If

'---------------------------------------------
' Script End
'-------------------------------———————
End Sub

But I got the message "Task failed" .. Is that related to run the macro as admin ..? and if yes, in that case how can I run the code as admin?

Answer 1

Try the next code, please:

Firstly, paste the next function on top of your module (in the declarations area):

Option Explicit

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As LongPtr, _
          ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, _
          ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

Then, use the next Sub, please:

Sub CreateSharedFolder()
 Dim thismonth As String, thisday As String, thisyear As String, foldername As String

 thismonth = Month(Date): thisday = Format(Day(Date), "00"): thisyear = Year(Date)
 foldername = thismonth & thisday & thisyear

 If Dir("C:\" & foldername, vbDirectory) = "" Then
     MkDir "C:\" & foldername
 End If
 '---------------------------------------------------------
 ' Check if another share with the same name exists
 '---------------------------------------------------------
 Dim strComputer As String, objWMIService As Object, colShares As Object, objShare As Object

 strComputer = "."
 Set objWMIService = GetObject("winmgmts:" _
  & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
 Set colShares = objWMIService.ExecQuery _
     ("Select * from Win32_Share Where Name = 'INGEST'")
 For Each objShare In colShares
    objShare.Delete
 Next

 '------------------ ---------------------------------------
 ' Share the folder (using "Shell.Application"
 '---------------------------------------------------------
 Dim intRun As LongPtr
 intRun = ShellExecute(0, "runas", "c:\windows\system32\cmd.exe", _
        "/k net share INGEST=" & "C:\" & foldername & _
        " /grant:everyone,FULL /remark:""Notes to Exchange Migration Share.""", "c:\windows\system32", 0)
   If intRun = 0 Then
      MsgBox "Sharing " & "C:\" & foldername & " failed..."
      Exit Sub
   End If

  If intRun <> 0 Then
    MsgBox "Success"
  Else
    MsgBox "Task Failed"
  End If
End Sub

It will share the folder, for Everyone, full access. Like I was afraid (see my comment) you need to press OK when UAC asks for permission... I think that also this can be bypassed, but now I do not have time to try this aspect, too.

Please, confirm that it works also in your case.