创建文件夹使其可在 VBA 中共享

Question

寻找这样的主题，我找到了成功完成任务的 VBScript 这是 VBScript https://blogs.msdn.microsoft.com/imayak/2008/12/05/vbscript-for-creating-and-sharing-a-folder/# 我试图将其转换为适用于 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

但是我收到消息 "Task failed" .. 这与运行作为管理员的宏有关吗？如果是，在这种情况下，我如何运行管理员代码？

Answer 1

请尝试下一个代码：

首先，将下一个函数粘贴到您的模块顶部（在声明区域）：

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

那么，使用下一个Sub，请：

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

它将共享文件夹，Everyone，完全访问。就像我害怕（见我的评论）你需要在 UAC 请求许可时按 OK ......我认为这也可以绕过，但现在我也没有时间尝试这方面。

请确认它也适用于您的情况。

创建文件夹使其可在 VBA 中共享

Create folder make it shareable in VBA

vbscript

excel

vba