I am trying to find a string in the list of shared folder names in an IP address in VBA.
The below routine works for folders but does not work. The error it says is Err-76, path not found.
could any one tell me how to access shared folder names in an IP address.
Sub findfolder()
Dim myFolder As Folder
Dim objfile As Object
Dim subfolder As Object
Dim FSO As New FileSystemObject
Dim txt As String
Dim strname As String
txt = "\\10.4.32.33"
'spath = GetFolder(txt)
strname = InputBox(Prompt:="You Search String please.", _
Title:="ENTER SEARCH STRING", Default:="Your Search String here")
Set myFolder = FSO.GetFolder(txt)
For Each subfolder In myFolder.SubFolders
cnt = 0
If (InStr(LCase(subfolder.Name), strname)) Then MsgBox ("found string" & subfolder.Name)
Next
End Sub
Use Shell.Application ActiveX instead of FSO, here is an example:
Sub ShowSharedFolders()
Const SHCONTF_CHECKING_FOR_CHILDREN = &H10
Const SHCONTF_FOLDERS = &H20
Const SHCONTF_NONFOLDERS = &H40
Const SHCONTF_INCLUDEHIDDEN = &H80
Const SHCONTF_INIT_ON_FIRST_NEXT = &H100
Const SHCONTF_NETPRINTERSRCH = &H200
Const SHCONTF_SHAREABLE = &H400
Const SHCONTF_STORAGE = &H800
Const SHCONTF_NAVIGATION_ENUM = &H1000
Const SHCONTF_FASTITEMS = &H2000
Const SHCONTF_FLATLIST = &H4000
Const SHCONTF_ENABLE_ASYNC = &H8000
Const SHCONTF_INCLUDESUPERHIDDEN = &H10000
strPath = "\\10.4.32.33\"
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.Namespace(strPath)
Set objFolderItems = objFolder.Items()
objFolderItems.Filter SHCONTF_FOLDERS + SHCONTF_INCLUDEHIDDEN, "*.*"
For Each objFolderItem In objFolderItems
Debug.Print objFolderItem.Name & vbTab & objFolderItem.Path
Next
End Sub
For early binding Set objShellApp = New Shell you have to add the reference to Microsoft Shell Controls and Automation (Shell32).
Related
I'm trying to create a VBS script that will grab all the fonts from the server font location so that the domain user will have the ability to use them. When I run this script I get a line 15 char 1 error: 800A400C.
Not sure what is wrong with it or if this script will do the job I'm wanting it to do.
'On Error Resume Next
'Option Explicit
Dim objShell, objFSO, wshShell
Dim strFontSourcePath, objFolder, objFont, objNameSpace, objFile, strFontsSytem
Set objShell = CreateObject("Shell.Application")
Set wshShell = CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FilesyStemObject")
strFontSourcePath = "\\server\Fonts\"
strFontsSytem = WSHShell.SpecialFolders("Fonts") & "\"
Set objNameSpace = objShell.Namespace(strFontSourcePath)
Set objFolder = objFSO.GetFolder(strFontSourcePath)
For Each objFile In objFolder.Files
If LCase(Right(objFile, 4)) = ".ttf" Or LCase(Right(objFile, 4)) = ".otf" Then
Set objFont = objNameSpace.ParseName(objFile.Name)
If objFSO.FileExists(strFontsSytem & objFile.Name) = False Then
objFont.InvokeVerb("Install")
Set objFont = Nothing
End If
End If
Next
Set objShell = Nothing
Set wshShell = Nothing
Set objFSO = Nothing
Set objNameSpace = Nothing
Set objFolder = Nothing
WScript.Quit
Error code 800A004C means Path not found. Please check the existance of the strFontSourcePath and like Ansgar says also check if the user running this code has access to this share.
Anyway, Here's my code to copy and install fonts from a server share if that is any help
Call AddFonts("\\server\Fonts\")
WScript.Quit
Private Sub AddFonts(strFromPath)
' install fonts from a server location if not already present
Dim appShell, objShell, objFSO, colFiles, objFile, objFolder
Dim strToPath, flags, strFile, strExt
'SpecialFolder. See: https://technet.microsoft.com/en-us/library/ee176604.aspx
Const FONTFOLDER = &H14&
'CopyHere switches
Const FOF_MULTIDESTFILES = &H1&
Const FOF_CONFIRMMOUSE = &H2&
Const FOF_SILENT = &H4&
Const FOF_RENAMEONCOLLISION = &H8&
Const FOF_NOCONFIRMATION = &H10&
Const FOF_WANTMAPPINGHANDLE = &H20&
Const FOF_ALLOWUNDO = &H40&
Const FOF_FILESONLY = &H80&
Const FOF_SIMPLEPROGRESS = &H100&
Const FOF_NOCONFIRMMKDIR = &H200&
Const FOF_NOERRORUI = &H400&
Const FOF_NOCOPYSECURITYATTRIBS = &H800&
Const FOF_NORECURSION = &H1000&
Const FOF_NO_CONNECTED_ELEMENTS = &H2000&
Const FOF_WANTNUKEWARNING = &H4000&
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = Createobject("Wscript.Shell")
Set appShell = CreateObject("Shell.Application")
'create an object for the systems fonts folder
Set objFolder = appShell.Namespace(FONTFOLDER)
'make sure these paths end in a backslash
strFromPath = FixPath(strFromPath)
'get the name of the system fonts folder (C:\WINDOWS\Fonts)
strToPath = FixPath(objShell.SpecialFolders("Fonts"))
'set flags to install as quiet as possible.
flags = FOF_SILENT Or FOF_NOCONFIRMATION Or FOF_NOERRORUI Or _
FOF_NOCONFIRMMKDIR Or FOF_NOCOPYSECURITYATTRIBS
If (Not objFolder Is Nothing) Then
If objFSO.FolderExists(strFromPath) Then
Set colFiles = objFSO.GetFolder(strFromPath).Files
If colFiles.Count > 0 Then
For Each objFile In colFiles
strExt = objFSO.GetExtensionName(objFile.Name)
Select Case LCase(strExt)
Case "ttf", "otf" ' can also be used for "fon", "pfm", "pfb", "afm"
'get the complete path and filename for this font file and check if already there
strFile = strToPath & objFile.Name
If Not (objFSO.FileExists(strFile)) Then
objFolder.CopyHere strFromPath & objFile.Name, flags
End If
End Select
Next
End If
End If
End If
'cleanup objects
Set appShell = Nothing
Set colFiles = Nothing
Set objFile = Nothing
Set objFolder = Nothing
Set objFSO = Nothing
Set objShell = Nothing
End Sub
Private Function FixPath(sPath)
'small helper function to ensure a path ends in a backslash
If Len(sPath) > 0 And Right(sPath, 1) <> "\" Then
FixPath = sPath & "\"
Else
FixPath = sPath
End If
End Function
I have an Access database which has a filename field, along with width and height fields for an image. Instead of populating the width and height manually, I'm trying to read the height and width from the filename alone (full file path) and then insert into a record.
The reading of dimensions is fairly trivial in most languages, but can't find much for Access VBA. All I can find is for Excel which assumes the image is already in the spreadsheet as an object.
Just try googling "Use vba to read image file dimensions"
eg
https://social.msdn.microsoft.com/Forums/office/en-US/5f375529-a002-4312-a54b-b70d6d3eb6ae/how-to-retrieve-image-dimensions-using-vba-?forum=accessdev
for example
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Documents and Settings\Administrator\Desktop")
Set objFile = objFolder.ParseName("file_name.bmp")
MsgBox objFile.ExtendedProperty("Dimensions")
You can extract what you need from the string displayed in the message box
You can do this:
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Documents and Settings\Administrator\Desktop")
Set objFile = objFolder.ParseName("file_name.bmp")
MsgBox objFile.ExtendedProperty("Dimensions")
That messagebox should give you something along the lines of "300 X 500" (or whatever the Length X Width is). If you need the individual dimensions, you'll need to use something like
FileLen = CInt(Trim(Mid(objFile.ExtendedProperty, 2, InStr(objFile.ExtendedProperty, "X") - 1)))
and
FileWid = CInt(Trim(Mid(objFile.ExtendedProperty, InStr(objFile.ExtendedProperty, "X") + 2, Len(objFile.ExtendedProperty))))
You can also accomplish this with a class, which lets you use code like this:
targetImage.PixelWidth
targetImage.PixelHeight
Create a new Class Module and name it ImageDimensions.
Paste the following code into that class module:
Class Module Code
Option Explicit
Private pPixelWidth As Long
Private pPixelHeight As Long
Private pImageFullPath As String
Public Property Get ImageFullPath() As String
ImageFullPath = pImageFullPath
End Property
Public Property Let ImageFullPath(fullPath As String)
pImageFullPath = fullPath
Dim dimensionsText As String
dimensionsText = GetImageDimensions(fullPath)
pPixelWidth = Left$(dimensionsText, InStr(dimensionsText, ",") - 1)
pPixelHeight = Mid$(dimensionsText, InStr(dimensionsText, ",") + 1)
End Property
Public Property Get PixelWidth() As Long
PixelWidth = pPixelWidth
End Property
Private Property Let PixelWidth(value As Long)
pPixelWidth = value
End Property
Public Property Get PixelHeight() As Long
PixelHeight = pPixelHeight
End Property
Private Property Let PixelHeight(value As Long)
pPixelHeight = value
End Property
Private Function GetImageDimensions(ByVal fullPath As String)
Dim fileName As String
Dim fileFolder As String
fileName = FilenameFromPath(fullPath)
fileFolder = FolderFromFilePath(fullPath)
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
Dim targetFolder As Object
Set targetFolder = objShell.Namespace(fileFolder & vbNullString)
Const IMAGE_DIMENSIONS As Long = 31
Dim dimensionsPrep As String
dimensionsPrep = targetFolder.GetDetailsOf( _
targetFolder.Items.Item(fileName & vbNullString), _
IMAGE_DIMENSIONS)
dimensionsPrep = Replace(dimensionsPrep, " x ", ",")
dimensionsPrep = Mid$(dimensionsPrep, 2, Len(dimensionsPrep) - 2)
GetImageDimensions = dimensionsPrep
End Function
Private Function FolderFromFilePath(ByVal filePath As String) As String
Dim filesystem As Object
Set filesystem = CreateObject("Scripting.FileSystemObject")
FolderFromFilePath = filesystem.GetParentFolderName(filePath) & "\"
End Function
Private Function FilenameFromPath(ByVal filePathAndName As String) As String
Dim pathLength As Long
Dim iString As String
pathLength = Len(filePathAndName)
iString = vbNullString
Dim iCount As Long
For iCount = pathLength To 1 Step -1
If Mid$(filePathAndName, iCount, 1) = Application.PathSeparator Then
FilenameFromPath = iString
Exit Function
End If
iString = Mid$(filePathAndName, iCount, 1) & iString
Next iCount
FilenameFromPath = filePathAndName
End Function
Example Usage
Put this code in a regular code module (not a class module):
Sub ExampleImageDimensions()
Dim targetImage As ImageDimensions
Set targetImage = New ImageDimensions
targetImage = "C:\Users\ChrisB\Downloads\Screenshot.jpg"
Debug.Print targetImage.PixelHeight
Debug.Print targetImage.PixelWidth
End Sub
I need to create a table in this format:
FOLDER NAME MODIFICATION TIME FILE SIZE FILE NAME
Nexus 5/14/2015 16:56 <DIR> pictures
0 bytes
Nexus\pictures 4/22/2015 10:53 155,466,275 auto
5/4/2015 10:13 2,006,176 ship
4/21/2015 11:01 <DIR> june
5/14/2015 15:17 <DIR> july
157,472,451
I tried using this code in excel visual basic window but since I am not familiar with vb scripting I am unable to edit it to fit my required columns. Please help me edit this code:
Place this code in a Standard module
VB:
Const BIF_RETURNONLYFSDIRS As Long = &H1 ''' For finding a folder to start document searching
Const BIF_DONTGOBELOWDOMAIN As Long = &H2 ''' Does not include network folders below the domain level in the tree view control
Const BIF_RETURNFSANCESTORS As Long = &H8 ''' Returns only file system ancestors.
Const BIF_BROWSEFORCOMPUTER As Long = &H1000 ''' Returns only computers.
Const BIF_BROWSEFORPRINTER As Long = &H2000 ''' Returns only printers.
Const BIF_BROWSEINCLUDEFILES As Long = &H4000 ''' Returns everything.
Const MAX_PATH As Long = 260
Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszINSTRUCTIONS As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare Function SHGetPathFromIDListA Lib "shell32.dll" (ByVal pidl As Long, ByVal pszBuffer As String) As Long
Declare Function SHBrowseForFolderA Lib "shell32.dll" (lpBrowseInfo As BROWSEINFO) As Long
Function BrowseFolder() As String
Const szINSTRUCTIONS As String = "Choose the folder to use for this operation." & vbNullChar
Dim uBrowseInfo As BROWSEINFO
Dim szBuffer As String
Dim lID As Long
Dim lRet As Long
With uBrowseInfo
.hOwner = 0
.pidlRoot = 0
.pszDisplayName = String$(MAX_PATH, vbNullChar)
.lpszINSTRUCTIONS = szINSTRUCTIONS
.ulFlags = BIF_RETURNONLYFSDIRS
.lpfn = 0
End With
szBuffer = String$(MAX_PATH, vbNullChar)
''' Show the browse dialog.
lID = SHBrowseForFolderA(uBrowseInfo)
If lID Then
''' Retrieve the path string.
lRet = SHGetPathFromIDListA(lID, szBuffer)
If lRet Then BrowseFolder = Left$(szBuffer, InStr(szBuffer, vbNullChar) - 1)
End If
End Function
In a second Module copy this code
VB:
Option Explicit
Sub CreateList()
Application.ScreenUpdating = False
Workbooks.Add ' create a new workbook for the folder list
' add headers
With Cells(1, 1)
.Value = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Cells(3, 1).Value = "Folder Path:"
Cells(3, 2).Value = "Folder Name:"
Cells(3, 3).Value = "Size:"
Cells(3, 4).Value = "Subfolders:"
Cells(3, 5).Value = "Files:"
Cells(3, 6).Value = "Short Name:"
Cells(3, 7).Value = "Short Path:"
Range("A3:G3").Font.Bold = True
ListFolders BrowseFolder, True
Application.ScreenUpdating = True
End Sub
Sub ListFolders(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the folders in SourceFolder
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
' display folder properties
r = Cells(Rows.Count, 1).End(xlUp).Row + 1
Cells(r, 1).Value = SourceFolder.Path
Cells(r, 2).Value = SourceFolder.Name
Cells(r, 3).Value = SourceFolder.Size
Cells(r, 4).Value = SourceFolder.SubFolders.Count
Cells(r, 5).Value = SourceFolder.Files.Count
Cells(r, 6).Value = SourceFolder.ShortName
Cells(r, 7).Value = SourceFolder.ShortPath
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFolders SubFolder.Path, True
Next SubFolder
Set SubFolder = Nothing
End If
Columns("A:G").AutoFit
Set SourceFolder = Nothing
Set FSO = Nothing
ActiveWorkbook.Saved = True
End Sub
NOTE: This code uses Microsoft Scripting Runtime. The macro examples need a reference to the Microsoft Scripting Runtime library. You can do this from within the VBE by selecting the menu Tools > References and scroll for Microsoft Scripting Runtime, check th box then click OK
You can get a directory listing into a text file with the > symbol.
For example, "DIR >test.txt" will output the results of the DIR command to a text file that you could then pull into excel.
I could not get the DIR command to output anything close to your format above, but this may be a start if you can get something useful.
I am using the below VBscript to change group type of couple of groups to Security. I am getting an error "The server is unwilling to process the request" when executing objGroup.setinfo.
Appreciate if someone can help to resolve this.
Dim strOU, strGroup, objOU, objGroup
Dim strFile, objFile, objFSO
Const ADS_GROUP_TYPE_SECURITY_ENABLED = &H80000000
Const ForReading = 1
Const ADS_NAME_INITTYPE_GC = 3
Const ADS_NAME_TYPE_NT4 = 3
Const ADS_NAME_TYPE_1779 = 1
Const ADS_GROUP_TYPE_UNIVERSAL = &H8
strFile = "c:\Temp\GroupNames.txt"
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(strFile, ForReading)
Set objRootDSE = GetObject("LDAP://RootDSE")
strDNSDomain = objRootDSE.Get("defaultNamingContext")
Set objTrans = CreateObject("NameTranslate")
objTrans.Init ADS_NAME_INITTYPE_GC, ""
objTrans.Set ADS_NAME_TYPE_1779, strDNSDomain
strNetBIOSDomain = objTrans.Get(ADS_NAME_TYPE_NT4)
strNetBIOSDomain = Left(strNetBIOSDomain, _
Len(strNetBIOSDomain) - 1)
Do Until objFile.AtEndOfStream
strNTName = Trim(objFile.ReadLine)
If (strNTName <> "") Then
On Error Resume Next
objTrans.Set ADS_NAME_TYPE_NT4, strNetBIOSDomain & "\" & strNTName
End If
' Use Get method to retrieve Distinguished Name.
strUserDN = objTrans.Get(ADS_NAME_TYPE_1779)
wscript.echo strUSerDN
' Bind to user object in AD.
Set objGroup = GetObject("LDAP://servername
" & strUserDN)
objGroup.Put "groupType", ADS_GROUP_TYPE_SECURITY_ENABLED
objGroup.SetInfo
Loop
objFile.Close
You need to specify the group scope as well. Instead of just "ADS_GROUP_TYPE_SECURITY_ENABLED", you need "ADS_GROUP_TYPE_[type]_GROUP Or ADS_GROUP_TYPE_SECURITY_ENABLED", where [type] is GLOBAL, LOCAL, or UNIVERSAL.
I'm working on an Outlook add-in that requires the Office specific FileDialog to interoperate with a Sharepoint site; the common file dialog doesn't have the interoperability. I know that both Word and Excel have a get_fileDialog method under Globals.ThisAddIn.Application.Application, but Outlook doesn't seem to. How do I launch an Outlook FileDialog? Is it even possible?
Microsoft Common Dialog
If you have COMDLG32.OCX ("Common Dialog ActiveX Control") installed, then you can use this - it's explained here, with an example. (Scroll down just past the screenshot entitled "FIGURE 2: Don't try to select more than one file in Word! ").
It appears that Outlook's Application object does not offer FileDialog. But a simple workaround, if you are willing to have an Excel reference, is:
Dim fd As FileDialog
Set fd = Excel.Application.FileDialog(msoFileDialogFolderPicker)
Dim folder As Variant
If fd.Show = -1 Then
For Each folder In fd.SelectedItems
Debug.Print "Folder:" & folder & "."
Next
End If
'Add a "Module". Then add the declarations like this to it.
Option Explicit
Private Declare Function GetOpenFileName _
Lib "comdlg32.dll" _
Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Public Function MyOpenFiledialog() As String
Dim OFName As OPENFILENAME
OFName.lStructSize = Len(OFName)
'Set the parent window
OFName.hwndOwner = Application.hWnd
'Set the application's instance
OFName.hInstance = Application.hInstance
'Select a filter
OFName.lpstrFilter = "Text Files (*.txt)" + Chr$(0) + "*.txt" + Chr$(0) + "All Files (*.*)" + Chr$(0) + "*.*" + Chr$(0)
'create a buffer for the file
OFName.lpstrFile = Space$(254)
'set the maximum length of a returned file
OFName.nMaxFile = 255
'Create a buffer for the file title
OFName.lpstrFileTitle = Space$(254)
'Set the maximum length of a returned file title
OFName.nMaxFileTitle = 255
'Set the initial directory
OFName.lpstrInitialDir = "C:\"
'Set the title
OFName.lpstrTitle = "Open File - VB Forums.com"
'No flags
OFName.flags = 0
'Show the 'Open File'-dialog
If GetOpenFileName(OFName) Then
MsgBox "File to Open: " + Trim$(OFName.lpstrFile)
MyOpenFiledialog = Trim$(OFName.lpstrFile)
Else
MsgBox "Cancel was pressed"
MyOpenFiledialog = vbNullString
End If
End Sub 'Usage:
Private Sub Command1_Click()
Text1.Text = MyOpenFiledialog
End Sub
Public Sub TestFileDialog()
Dim otherObject As Excel.Application
Dim fdFolder As office.FileDialog
Set otherObject = New Excel.Application
otherObject.Visible = False
Set fdFolder = otherObject.Application.FileDialog(msoFileDialogFolderPicker)
fdFolder.Show
Debug.Print fdFolder.SelectedItems(1)
otherObject.Quit
Set otherObject = Nothing
End Sub
Private Sub multiEML2MSG()
Const PR_ICON_INDEX = &H10800003
Dim objPost As Outlook.PostItem
Dim objSafePost As Redemption.SafePostItem
Dim objNS As Outlook.NameSpace
Dim objInbox As Outlook.MAPIFolder
Set objNS = Outlook.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)
Set objPost = objInbox.Items.Add(OlItemType.olPostItem)
Set objSafePost = New Redemption.SafePostItem
Dim xlObj As Excel.Application
Dim fd As Office.FileDialog
Set xlObj = New Excel.Application
Set fd = xlObj.Application.FileDialog(msoFileDialogFolderPicker)
With fd
.Title = "Select your PST File"
.ButtonName = "Ok"
.Show
If fd.SelectedItems.Count <> 0 Then
xDirect$ = fd.SelectedItems(1) & "\"
xFname$ = Dir(xDirect$, 7)
licznik = 1
Do While xFname$ <> ""
XPathEML = xDirect$ & xFname$
XPathMSG = Replace(XPathEML, ".eml", ".msg", , , vbTextCompare)
Debug.Print XPath, Replace(XPath, ".eml", ".msg", , , vbTextCompare)
objPost.Save
objSafePost.Item = objPost
objSafePost.Import XPathEML, Redemption.RedemptionSaveAsType.olRFC822
objSafePost.MessageClass = "IPM.Note"
objSafePost.Fields(PR_ICON_INDEX) = none
objSafePost.SaveAs XPathMSG, Outlook.OlSaveAsType.olMSG
xFname$ = Dir
licznik = licznik + 1
Loop
End If
End With
xlObj.Quit
Set xlObj = Nothing
Set objSafePost = Nothing
Set objPost = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub