'********************************************************************* ' [Office 2013]信頼できるアプリカタログのアドレス削除スクリプト ' - 共有フォルダーの指定 -> アプリカタログからアドレス削除, ' フォルダーの共有設定解除 ' ' Author : kinuasa ' Date : 2013/01/24 ' Version : 1.00 '********************************************************************* Option Explicit Dim FolderPath 'マニフェストファイルを保存するフォルダーパス Dim tmp Dim itms, itm Const LocalAddress = "\\127.0.0.1\" 'Officeアプリケーション(Excel,Word,PowerPoint)が起動しているか簡易的にチェック If ChkRunningOfficeApp() Then MsgBox "Officeアプリケーション(Excel,Word,PowerPoint)を終了してから再度実行してください。", vbExclamation + vbSystemModal WScript.Quit End If '信頼できるカタログの登録とフォルダーの共有設定を解除 FolderPath = GetFolderPath("マニフェストファイル保存用のフォルダーを選択してください。" & vbCrLf & "※ 選択したフォルダーが信頼できるカタログに登録されている場合はその登録とフォルダーの共有設定が解除されます。") If Len(Trim(FolderPath)) < 1 Then WScript.Quit tmp = Replace(FolderPath, ChrW(92), ChrW(92) & ChrW(92)) Set itms = CreateObject("WbemScripting.SWbemLocator").ConnectServer.ExecQuery("Select * From Win32_Share Where Path = '" & tmp & "'") If itms.Count > 0 Then For Each itm In itms DelCatalogUrl LocalAddress & itm.Name DelSharedFolder itm.Name Next MsgBox "信頼できるカタログの登録とフォルダーの共有設定を解除しました。", vbInformation + vbSystemModal Else MsgBox "信頼できるカタログに登録されている共有フォルダーではありません。" & vbCrLf & "処理を中止します。", vbExclamation + vbSystemModal End If Private Sub DelCatalogUrl(ByVal url) '信頼できるカタログにURLが登録されていればレジストリキーを削除 Dim ret Dim reg Dim keys Dim rn, rt Dim v Dim i, j Const HKEY_CURRENT_USER = &H80000001 Const SubKeyName = "Software\Microsoft\Office\15.0\WEF\TrustedCatalogs" ret = False '初期化 Set reg = CreateObject("WbemScripting.SWbemLocator").ConnectServer(, "root\default").Get("StdRegProv") reg.EnumKey HKEY_CURRENT_USER, SubKeyName, keys If Not IsNull(keys) Then For i = LBound(keys) To UBound(keys) reg.EnumValues HKEY_CURRENT_USER, SubKeyName & ChrW(92) & keys(i), rn, rt For j = LBound(rn) To UBound(rn) If LCase(rn(j)) = "url" Then reg.GetStringValue HKEY_CURRENT_USER, SubKeyName & ChrW(92) & keys(i), rn(j), v If v = url Then reg.DeleteKey HKEY_CURRENT_USER, SubKeyName & ChrW(92) & keys(i) Exit Sub End If End If Next Next End If End Sub Private Sub DelSharedFolder(ByVal ShareName) 'フォルダーの共有設定解除 Dim com com = "share """ & ShareName & """ /delete" CreateObject("Shell.Application").ShellExecute "net", com, "", "runas" End Sub Private Function ChkRunningOfficeApp() 'Officeアプリケーションの起動チェック Dim ex, wd, pp Dim ret Set ex = Nothing: Set wd = Nothing: Set pp = Nothing: ret = False '初期化 On Error Resume Next Set ex = GetObject(, "Excel.Application") Set wd = GetObject(, "Word.Application") Set pp = GetObject(, "PowerPoint.Application") On Error GoTo 0 If Not ex Is Nothing Then ret = True If Not wd Is Nothing Then ret = True If Not pp Is Nothing Then ret = True ChkRunningOfficeApp = ret End Function Private Function GetFolderPath(ByVal DlgTitle) 'フォルダー選択 Dim ret Dim f Const ssfDESKTOPDIRECTORY = &H10 ret = "": Set f = Nothing '初期化 With CreateObject("Shell.Application") Set f = .BrowseForFolder(0, DlgTitle, &H1 + &H10, .Namespace(ssfDESKTOPDIRECTORY).Self.Path) If Not f Is Nothing Then ret = f.Self.Path If Right(ret, 1) = ChrW(92) Then ret = Left(ret, Len(ret) - 1) End If End With GetFolderPath = ret End Function