I searched SO, SU, and SP.SE for a solution, but could not find what I needed. I'm looking for a solution which may be a script or some other non-coding method/tool.
I am trying to write a script (to be used by others) or some other form of automation to upload various reports automatically to a SharePoint site. I have managed to get the following (VBScript) code to work, but only for text-based files -- .CSV in this case, though this also works for .TXT, etc.
Option Explicit
Dim sCurPath
sCurPath = CreateObject("Scripting.FileSystemObject").GetAbsolutePathName(".")
UploadAllToSP sCurPath
Sub UploadAllToSP(sFolder)
Dim fso, folder, fil
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(sFolder)
For Each fil In folder.Files
If fso.GetExtensionName(fil) = "csv" Then
UploadFileToSP fil
End If
Next
End Sub
Sub UploadFileToSP(ofile)
Dim xmlhttp
Dim sharepointUrl
Dim sharepointFileName
Dim tsIn
Dim sBody
Set tsIn = ofile.openAsTextstream
sBody = tsIn.readAll
tsIn.close
sharepointUrl = "http://SHAREPOINT URL HERE"
sharepointFileName = sharepointUrl & ofile.name
set xmlHttp = createobject("MSXML2.XMLHTTP.4.0")
xmlhttp.open "PUT", sharepointFileName, false
xmlhttp.send sBody
If xmlhttp.status < 200 Or xmlhttp.status > 201 Then
wscript.echo "There was a problem uploading " & ofile.name & "!"
End If
End Sub
This only works for text files because it pipes the text data into a file on the SP site. However, if I want to transfer any kind of binary file (.XLS, .PDF), this results in garbage being uploaded.
I tried to take a look at a Shell.Application ==> .Namespace(), but this doesn't seem to work with a URL, but only a physical drive. Here's some of what else I tried (trimmed to show relevant pieces):
Set oApp = CreateObject("Shell.Application")
If oApp.NameSpace(sharepointUrl) <> Null then ' Always Null!
' Copy here
' Some lines omitted
oApp.NameSpace(sharepointUrl).CopyHere ofile.Name ' This also fails when not surrounded by the Null check
Else
MsgBox "SharePoint directory not found!"
End If
I also tried a batch file using xcopy, but that can't connect to the http:// either. I looked at this method, which may work for me, but I'd prefer not to deal with mapping/NET USE, since our company has multiple network shares, the mapping for which varies depending on who's logged in.
Since none of these work quite the way I need: Is there a method to automate this kind of functionality?
I have experience with VBA/VBscript, so either a script like the above, or something built in to an MS Office application (Outlook is best, but I can probably adapt whatever I am given) would be preferable. That being said, I am open to any method that would allow me to do this, running natively in Windows or Office. However, I do not have access to Visual Studio, so I can't use any .NET functionality.
Thanks to Sean Cheshire for pointing me at the obvious answer that I did not see. Posting the relevant code, since I don't believe this yet exists on SO.
Sub UploadFilesToSP(sFolder)
Dim sharepointUrl
Dim sharepointFileName
Dim LlFileLength
Dim Lvarbin()
Dim LobjXML
Dim LvarBinData
Dim PstrFullfileName
Dim PstrTargetURL
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
Dim fldr
Dim f
'This has not been successfully tested using an "https" connection.
sharepointUrl = "http://SHAREPOINT URL HERE"
Set LobjXML = CreateObject("Microsoft.XMLHTTP")
Set fldr = fso.GetFolder(sFolder)
For Each f In fldr.Files
sharepointFileName = sharepointUrl & f.Name
PstrFullfileName = sFolder & f.Name
LlFileLength = FileLen(PstrFullfileName) - 1
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
' Convert to variant to PUT.
LvarBinData = Lvarbin
PstrTargetURL = sharepointFileName
' Put the data to the server, false means synchronous.
LobjXML.Open "PUT", PstrTargetURL, False
' Send the file in.
LobjXML.Send LvarBinData
Next f
Set LobjXML = Nothing
Set fso = Nothing
End Sub
This is VBA code, formatted to mostly work with VBScript, though I could not get this block to transfer properly. As VBA, this can be improved some by assigning data types, etc.
' Read the file into a byte array.
ReDim Lvarbin(LlFileLength)
Open PstrFullfileName For Binary As #1
Get #1, , Lvarbin
Close #1
This is a very old post but a very useful one so thanks to everyone's contribution. This is my version with the early binding. I found that the previous posting didn't work due to VBA assumption of the none declared variable types.
Private Sub cmdUploadToApplicationsAndApprovals_Click()
Dim strSharePointUrl As String
Dim strSharePointFileName As String
Dim lngFileLength As Long
Dim bytBinary() As Byte
Dim objXML As XMLHTTP
Dim varBinData As Variant
Dim strFullfileName As String
Dim strTargetURL As String
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim folder As folder
Dim file As file
Dim strFolder As String
strFolder = CurrentProject.Path & "\Upload\"
'This has not been successfully tested using an "https" connection.
strSharePointUrl = "http://sps.mysite.ca/subsite/DocLib/"
Set objXML = New XMLHTTP 'CreateObject("Microsoft.XMLHTTP")
Set folder = fso.GetFolder(strFolder)
For Each file In folder.Files
strSharePointFileName = strSharePointUrl & file.Name
strFullfileName = strFolder & file.Name
lngFileLength = FileLen(strFullfileName) - 1
'Read the file into a byte array.
ReDim bytBinary(lngFileLength)
Open strFullfileName For Binary As #1
Get #1, , bytBinary
Close #1
'Convert to variant to PUT.
varBinData = bytBinary
strTargetURL = strSharePointFileName
'Put the data to the server, false means synchronous.
objXML.Open "PUT", strTargetURL, False
'Send the file in.
objXML.Send varBinData
'Now Update the metadata
Next file
'Clean up
Set objXML = Nothing
Set fso = Nothing
MsgBox "Done"
End Sub
FYI the above code required 2 references.
1. Microsoft XML, v6.0
2. Microsoft Scripting Runtime
Hope this helps improve on the already brilliant answer!!
Related
Trying to use Excel VBA to capture all the file attributes from files on disk, including extended attributes. Was able to get it to loop through the files and capture the basic attributes (that come from the file system):
File Path
File Name
File Size
Date Created
Date Last Accessed
Date Last Modified
File Type
Would also like to capture the extended properties that come from the file itself:
Author
Keywords
Comments
Last Author
Category
Subject
And other properties which are visible when right clicking on the file.
The goal is to create a detailed list of all the files on a file server.
You say loop .. so if you want to do this for a dir instead of the current document;
Dim sFile As Variant
Dim oShell: Set oShell = CreateObject("Shell.Application")
Dim oDir: Set oDir = oShell.Namespace("c:\foo")
For Each sFile In oDir.Items
Debug.Print oDir.GetDetailsOf(sFile, XXX)
Next
Where XXX is an attribute column index, 9 for Author for example.
To list available indexes for your reference you can replace the for loop with;
for i = 0 To 40
debug.? i, oDir.GetDetailsOf(oDir.Items, i)
Next
Quickly for a single file/attribute:
Const PROP_COMPUTER As Long = 56
With CreateObject("Shell.Application").Namespace("C:\HOSTDIRECTORY")
MsgBox .GetDetailsOf(.Items.Item("FILE.NAME"), PROP_COMPUTER)
End With
You can get this with .BuiltInDocmementProperties.
For example:
Public Sub PrintDocumentProperties()
Dim oApp As New Excel.Application
Dim oWB As Workbook
Set oWB = ActiveWorkbook
Dim title As String
title = oWB.BuiltinDocumentProperties("Title")
Dim lastauthor As String
lastauthor = oWB.BuiltinDocumentProperties("Last Author")
Debug.Print title
Debug.Print lastauthor
End Sub
See this page for all the fields you can access with this: http://msdn.microsoft.com/en-us/library/bb220896.aspx
If you're trying to do this outside of the client (i.e. with Excel closed and running code from, say, a .NET program), you need to use DSOFile.dll.
'vb.net
'Extended file stributes
'visual basic .net sample
Dim sFile As Object
Dim oShell = CreateObject("Shell.Application")
Dim oDir = oShell.Namespace("c:\temp")
For i = 0 To 34
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(oDir, i) & vbCrLf
For Each sFile In oDir.Items
TextBox1.Text = TextBox1.Text & oDir.GetDetailsOf(sFile, i) & vbCrLf
Next
TextBox1.Text = TextBox1.Text & vbCrLf
Next
I was finally able to get this to work for my needs.
The old voted up code does not run on windows 10 system (at least not mine). The referenced MS library link below provides current examples on how to make this work. My example uses them with late bindings.
https://learn.microsoft.com/en-us/windows/win32/shell/folder-getdetailsof.
The attribute codes were different on my computer and like someone mentioned above most return blank values even if they are not. I used a for loop to cycle through all of them and found out that Title and Subject can still be accessed which is more then enough for my purposes.
Private Sub MySubNamek()
Dim objShell As Object 'Shell
Dim objFolder As Object 'Folder
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("E:\MyFolder")
If (Not objFolder Is Nothing) Then
Dim objFolderItem As Object 'FolderItem
Set objFolderItem = objFolder.ParseName("Myfilename.txt")
For i = 0 To 288
szItem = objFolder.GetDetailsOf(objFolderItem, i)
Debug.Print i & " - " & szItem
Next
Set objFolderItem = Nothing
End If
Set objFolder = Nothing
Set objShell = Nothing
End Sub
Lucky discovery
if objFolderItem is Nothing when you call
objFolder.GetDetailsOf(objFolderItem, i)
the string returned is the name of the property, rather than its (undefined) value
e.g. when i=3 it returns "Date modified"
Doing it for all 288 values of I makes it clear why most cause it to return blank for most filetypes
e.g i=175 is "Horizontal resolution"
I need some help listing all the files and a specific folder. I used this tutorial and I cannot get it to work with the VBA.
Once on one drive, will this still work? If I follow the tutorial without VBA, the function doesn't list the file names...
Please help me.
Thanks,
VBA:
Function GetFileNames(ByVal FolderPath As String) As Variant
Dim Result As Variant
Dim i As Integer
Dim MyFile As Object
Dim MyFSO As Object
Dim MyFolder As Object
Dim MyFiles As Object
Set MyFSO = CreateObject("Scripting.FileSystemObject")
Set MyFolder = MyFSO.GetFolder(FolderPath)
Set MyFiles = MyFolder.Files
ReDim Result(1 To MyFiles.Count)
i = 1
For Each MyFile In MyFiles
Result(i) = MyFile.Name
i = i + 1
Next MyFile
GetFileNames = Result
End Function
Cell Function:
=IFERROR(INDEX(GetFileNames($A$1),ROW()-2),"")
A1:
=REPLACE(CELL("filename"),FIND("[",CELL("filename")),LEN(CELL("filename")),"*")
This actually prints out
https://...../Test/*
I had to remove the slash and * for it to work locally. But still not working on one drive
The project I'm working on imports images from a blob in a MySQL database. Sometimes these images are rotated 90 degrees and the user needs to manually rotate them to the correct orientation.
So my question is, is anyone aware of a function that extract exif data from a shape in Excel using vba? I'm trying to avoid any third party applications to do this.
I eventually turned something up in the bowels of social.msdn.microsoft.com.
Here is the solution. Microsoft Shell Controls and Automation reference required. Credit to OssieMac on social.msdn.microsoft.com. Link to page of post
Pointing it at a shape doesn't seem to work (gives me an error), but I save my mysql blob to a temp file on the pc anyway so this works out for me anyway.
Sub ListMetadata()
Dim fileFolder As String
Dim fileName As String
Dim objShell As Shell32.Shell
Dim objFolder As Shell32.Folder
Dim objItem As Shell32.FolderItem
Dim i As Long
'Edit following line to your path. (Note NO back slash on end.)
fileFolder = ThisWorkbook.Path & "\Picture Test"
'Can insert path like following if you prefer.
'fileFolder = "C:\Users\OssieMac\Documents\Excel\Test Macros\Picture Test"
'Edit following line to your file name
fileName = "DSC00093.JPG"
Set objShell = New Shell
Set objFolder = objShell.Namespace(fileFolder)
Set objItem = objFolder.ParseName(fileName)
With objFolder
For i = 1 To 1000
Sheets("Sheet1").Cells(i, "A") = .GetDetailsOf(objItem.Name, i)
Sheets("Sheet1").Cells(i, "B") = .GetDetailsOf(objItem, i)
Next i
End With
Set objItem = Nothing
Set objFolder = Nothing
Set objShell = Nothing
End Sub
I'm writing a script where I wish to write an HTML doc to a string from sharepoint.
Dim Content As String
Dim strShare As String: strShare = "\\link\to\share.html"
Dim iFile As Integer: iFile = FreeFile
Open strShare For Input As #iFile
Content = Input(LOF(iFile), iFile)
Close #iFile
However, I find I get a "path/file access error" every time I run the script for the first time upon boot. Once I visit "\link\to\share.html" in IE for the first time, the path begins to resolve in the VBA script.
My only thought is that IE is performing some sort of "DNS Cache" that VBA can't do. Currently my workaround is to catch the error and force the URL to open in IE the first time the script is run. After that, every other HTML file under that share loads fine.
As a test, I tried switching between from what I understand is http:// formatting (forward slash) and WebDAV formatting (\\ formating), and only the backslash separated paths ever work. I also tried to resolve the share to an IP and try it that way, but that never worked.
My last thought is to try mapping the share to a drive letter name and then specifically accessing the share with G:\link\to\mapped\share.html. But I don't see this as an elegant solution, and wonder if it will receive the same error any way.
Is there something blatant that I do not understand about WebDAV, Windows file handling, and VBA file inputs? There's something weird going on under the hood with resolving that shared domain, and I can't seem to debug it.
See if this helps here and an example below that I used.
2 things though: I only worked with Excel files on Sharepoint and I was already logged in there.
Dim oFSO As Object
'Dim oFolder As Object 'if needed
'Dim oFile As Object 'if needed
Set oFSO = CreateObject("Scripting.FileSystemObject")
Set oFolder = oFSO.GetFolder("\\sharepoint.site.com#SSL\DavWWWRoot\sites\")
'For Each oFolder In oFolder.SubFolders 'loops through folders
' For Each oFile In oFolder.Files 'loops through files
' 'do stuff
' Next oFile
'Next oFolder
I'm a bit confused about what you want to do. Do you want to check out files from SP and check files back into SP?
Sub testing()
Dim docCheckOut As String
'docCheckOut = "//office.bt.com/sites/Training/Design Admin/Training Plan/adamsmacro.xlsm"
docCheckOut = "http://your_path_here/ExcelList.xlsb"
Call UseCheckOut(docCheckOut)
End Sub
Sub UseCheckOut(docCheckOut As String)
' Determine if workbook can be checked out.
If Workbooks.CanCheckOut(docCheckOut) = True Then
Workbooks.CheckOut docCheckOut
Else
MsgBox "Unable to check out this document at this time."
End If
End Sub
Or...do you want to list files in a SP folder?
Sub ListFiles()
Dim folder As Variant
Dim f As File
Dim fs As New FileSystemObject
Dim RowCtr As Integer
Dim FPath As String
Dim wb As Workbook
RowCtr = 1
FPath = "http://excel-pc:43231/Shared Documents"
For Each f In FPath
'Set folder = fs.GetFolder("C:\Users\Excel\Desktop\Ryan_Folder")
'For Each f In folder.Files
Cells(RowCtr, 1).Value = f.Name
RowCtr = RowCtr + 1
Next f
End Sub
Sub test()
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("C:\Users\Excel\Desktop\Ryan_Folder")
'Set colSubfolders = objFolder.SubFolders
'For Each objSubfolder In colSubfolders
Cells(RowCtr, 1).Value = f.Name
RowCtr = RowCtr + 1
'Next
End Sub
I'm attempting to modify a VBA script from another post (26486871).
The script will download a Zip file, extract a text file and import the data to Excel.
I don't know VBA so I'll tackle each of the functions one at-a-time.
Create a temp directory with a randomized name................................Complete
Download a Zip file from a public server...............................................Complete
Extract the text file (20MB, tab-delimited)..............................................Error
Import the data into the open worksheet (overwrite the existing data)...Not Yet
On the Extract portion, I'm receiving a run-time error on the following line:
objOApp.Namespace(FileNameToUnzip).CopyHere objOApp.Namespace(varFileNameFolder).items, 256
"Run-time error '91: Object variable or With block variable not set."
When I hover my cursor over the variables while in Debug Mode, the directory and filenames are correct.
I'm unsure what is not set. I appreciate any help.
Option Explicit
'Main Procedure
Sub DownloadExtractAndImport()
Dim url As String
Dim targetFolder As String, targetFileZip As String, targetFileTXT As String
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
Dim newSheet As Worksheet
url = "http://www.example.com/data.zip"
targetFolder = Environ("TEMP") & "\" & RandomString(6) & "\"
MkDir targetFolder
targetFileZip = targetFolder & "data.zip"
targetFileTXT = targetFolder & "data.txt"
'1 download file
DownloadFile url, targetFileZip
'2 extract contents
Call UnZip(targetFileZip, targetFolder)
End Sub
Private Sub DownloadFile(myURL As String, target As String)
Dim WinHttpReq As Object
Dim oStream As Object
Set WinHttpReq = CreateObject("Msxml2.ServerXMLHTTP")
WinHttpReq.Open "GET", myURL, False
WinHttpReq.send
myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStream = CreateObject("ADODB.Stream")
oStream.Open
oStream.Type = 1
oStream.Write WinHttpReq.responseBody
oStream.SaveToFile target, 1 ' 1 = no overwrite, 2 = overwrite
oStream.Close
End If
End Sub
Private Function RandomString(cb As Integer) As String
Randomize
Dim rgch As String
rgch = "abcdefghijklmnopqrstuvwxyz"
rgch = rgch & UCase(rgch) & "0123456789"
Dim i As Long
For i = 1 To cb
RandomString = RandomString & Mid$(rgch, Int(Rnd() * Len(rgch) + 1), 1)
Next
End Function
Private Function UnZip(PathToUnzipFileTo As Variant, FileNameToUnzip As Variant)
Dim objOApp As Object
Dim varFileNameFolder As Variant
varFileNameFolder = PathToUnzipFileTo
Set objOApp = CreateObject("Shell.Application")
objOApp.Namespace(FileNameToUnzip).CopyHere objOApp.Namespace(varFileNameFolder).items, 256
End Function
Dim mainFolder As String
Dim zipFolder As String
Dim destinationFolder As String
Dim oShell As Object
Dim oMainFolder As Object
Dim oDestinatioFolder As Object
Dim oZipFolder As Object
Dim oZipItems As Object
replace with
Dim mainFolder As Variant
Dim zipFolder As Variant
Dim destinationFolder As Variant
Dim oShell As Object
Dim oMainFolder As Object
Dim oDestinatioFolder As Object
Dim oZipFolder As Object
Dim oZipItems As Object
Comintem is right, you should edit your old question with the added code rather than post a near identical new question. Perhaps keep this question and delete the old one.
To answer your question, it looks as if you're passing your arguments in the wrong order to your UnZip function. Try changing the line to:
Call UnZip(targetFolder, targetFileZip)
Update
It's difficult to diagnose the issues as your objects are being created and its properties/methods being called all on one line. Judging by the nature of your questions it doesn't seem as though your VBA knowledge is particularly vast and that you're trying to construct a working solution by tying various pieces of web code together. It's not my position to judge that kind of approach but my advice would be, if you take this approach, to create your objects one at a time and call its methods one at a time. This will make it far easier to diagnose your code.
I've tried to rewrite elements of your code to show you how this could be done. It might be a bit overkill but at least it'll help you identify the precise location of any problems. Obviously change the folder names to your own.
Dim mainFolder As String
Dim zipFolder As String
Dim destinationFolder As String
Dim oShell As Object
Dim oMainFolder As Object
Dim oDestinatioFolder As Object
Dim oZipFolder As Object
Dim oZipItems As Object
'Define the folder names
mainFolder = "C:\Users\User\Downloads\SO\" 'change to your own folder name
zipFolder = "sqlite-shell-win32-x86-3071700.zip" 'an old sqlite download = change to your name
destinationFolder = Left(zipFolder, Len(zipFolder) - 4) 'name of zip folder minus the '.zip'
'Create the new destination folder
MkDir mainFolder & destinationFolder
'Acquire the folder items
'create the shell object
Set oShell = CreateObject("Shell.Application")
'create the main folder object as Folder3 item
Set oMainFolder = oShell.Namespace(CVar(mainFolder)) 'argument must be a variant
'create the destination folder object as Folder3 item
Set oDestinatioFolder = oMainFolder.Items.Item(CVar(destinationFolder & "\")).GetFolder
'create the zip folder object as Folder3
Set oZipFolder = oMainFolder.Items.Item(CVar(zipFolder)).GetFolder
'Extract the zip folder items and write to desination folder
oDestinatioFolder.CopyHere oZipFolder.Items, 256