VBA - Checking Folder/File exist in SharePoint - vba

I wanted to copy a local file to sharepoint library using VBA by clicking an image. Right now seems like I'm unable to check for Folder & Files on SharePoint.
As every time I ran the code(by clicking an image in excel), it returns unable to find the file in SharePoint. And stops at returning the MsgBox Sorry there's no such Folder......
I tried mapping drive, it works perfectly fine, but not an options because end-user need to map the drive by themselves.
So now I'm looking to connecting to SharePoint using the link.
If I copy the SharePointLink to IE & Chrome using \, it works fine. But if I uses /, IE is unable to find the link.
UPDATE
If I uses \ after few tries, IE, will open up the file path in NetWork. Chrome will show the file path on chrome page. Why is this happening?????
The authentication is using windows authentication, so not an issue.
This is my code
Sub imgClicked()
Dim SharePointLib As String
Dim MyPath As String
Dim folderPath As String
Dim objNet As Object
Dim FSO As Object
Dim copyPath As String
Dim copyFilePath As String
folderPath = Application.ThisWorkbook.path
MyPath = Application.ThisWorkbook.FullName
SharePointLib = "//company.com/sites/MS/10%20Mg%20Review/"
' create new folder to store the file
copyPath = folderPath + "\copyPath\"
If Not FolderExists(copyPath) Then
FolderCreate (copyPath)
ElseIf Not FolderExists(SharePointLib) Then
MsgBox "Sorry there's no such folder. Folder Path: " & vbNewLine & vbNewLine & SharePointLib & ""
Exit Sub
End If
fileName = "hello.xlsm"
'Copy current excel file and save at the new folder created
ThisWorkbook.SaveCopyAs copyPath & fileName
MsgBox "Save Copy As: " + copyPath & filseName & vbNewLine & vbNewLine & "The file will be uploaded to this address: " + SharePointLib & fileName
' Check whether the file exist in the directory
' If exist error message
' else copy the file from copyPath then paste at the SharePoint directory
If Not Dir(SharePointLib & fileName, vbDirectory) = nbNullString Then
MsgBox "Sorry file already exist!"
Else
Call FileCopy(copyPath & fileName, SharePointLib & fileName)
MsgBox "File has being successfuly created in SharePoint!"
End If
Set FSO = CreateObject("scripting.filesystemobject")
If Right(copyPath, 1) = "\" Then
copyPath = Left(copyPath, Len(copyPath) - 1)
End If
If FSO.FolderExists(copyPath) = False Then
MsgBox copyPath & " doesn't exist"
Exit Sub
End If
FSO.DeleteFolder copyPath
MsgBox "Folder has being deleted successfully!"
End Sub
Function for checking if folder exists
Function FolderExists(ByVal path As String) As Boolean
FolderExists = False
Dim FSO As New FileSystemObject
If FSO.FolderExists(path) Then FolderExists = True
End Function
Function for creating Folder
Function FolderCreate(ByVal path As String) As Boolean
FolderCreate = True
Dim FSO As New FileSystemObject
try:
If FSO.FolderExists(path) Then
Exit Function
Else
On Error GoTo catch
FSO.CreateFolder path
Debug.Print "FolderCreate: " & vbTab & path
Exit Function
End If
catch:
MsgBox "A folder could not be created for the following path: " & path & ". Check the path name and try again."
FolderCreate = False
Exit Function
End Function
Any help and suggestions are appreciated. Let me know if more info is needed. Thanks in advance.

Ensure the WebClient service is running. You can start the WebClient service through code, or you could set the startup type to automatic.
With the WebClient service running, your folder/file tests will work as expected.
Edit: Additionally, if you map the sharepoint url to a drive letter, Windows will start the WebClient service.
Sub mapPath(str_drive as string, str_path as string)
If Not Len(str_drive) = 1 Then Exit Sub
Dim wso As Object
Set wso = CreateObject("WScript.Network")
wso.MapNetworkDrive str_drive & ":", str_path, False
End Sub

Related

Through FSO VBA - Files are not moving, please go through my code, I don't understand why files are not moving. I am trying to execute it but msg box

Please go through my code, correct me where I am wrong, files are not moving from folder to folder.
Option Explicit
Sub MoveFiles()
Dim FSO As Object
Dim FromDir As String
Dim ToDir As String
Dim FExtension As String
Dim Fnames As String
FromDir = "C:\Users\B\Source Folder"
ToDir = "C:\Users\B\Destination Folder"
FExtension = "*.*"
Fnames = Dir(FromDir & FExtension)
If Len(Fnames) = 0 Then
MsgBox "No files or Files already moved" & FromDir
Exit Sub
End If
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.MoveFile Source:=FromDir & FExtension, Destination:=ToDir
End Sub
Problem
You are missing a \ at the end of your FromDir which will separate the path from your filenames.
For your info: & is not really combining path and filename, but just concatenating two strings, so it never adds the \ itself.
Correction possibility 1
You can add it to the definition of FromDir:
FromDir = "C:\Users\B\Source Folder\"
Correction possibility 2
Add it to these lines of code dynamically:
Fnames = Dir(FromDir & "\" & FExtension)
FSO.MoveFile Source:=FromDir & "\" & FExtension, Destination:=ToDir
Another remark
You should also separate FromDir from the error text, like this:
MsgBox "No files or Files already moved: " & FromDir

Access VBA "Path not found" when using MkDir to create folder on desktop

I'm attempting to create a folder from a form in MS Access. I need to have the ability to create a new folder for each form entry. I'm a novice VBA programmer, but have learned a lot through searching and testing techniques online. Here is the code:
Private Sub Create_File_Folder_Click()
Engine.SetFocus
If Dir("C:\Users\ndemos\Documents\Test\" & TimeDateTeam.Value, vbDirectory) = "" Then
MkDir ("C:\Users\ndemos\Documents\Test\" & TimeDateTeam.Value)
Const strParent = "C:\Users\ndemos\Desktop\Test\"
Dim strTimeDateTeam As String
Dim strFolder As String
Dim fso As Object
strStudentID = Me.TimeDateTeam
strFolder = strParent & strStudentID
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FolderExists(strFolder) Then
MsgBox "Specified folder already exists.", vbInformation, "File Folder"
Exit Sub
Else
fso.CreateFolder strFolder
End If
Shell "explorer.exe " & strFolder, vbNormalFocus
End If
End Sub
I am running into a run-time error 76 "path not found" when I try and click the button in my form to create a folder. I've made sure the path actually does exist, and have tried and failed with multiple other directions for the folder to go to (such as \Documents\ and so forth).
Any help with how to create the folder would be greatly appreciated.
First, "\Test" must exist. Then this will work:
Path = Environ("UserProfile") & "\Documents\Test\" & Me!TimeDateTeam.Value
If Dir(Path, vbDirectory) = "" Then
MkDir Path
End If

Save a copy of Database then email it to a shared email box

I have a script that saves a backup database (with a date stamp) to a shared drive.
Private Sub Command0_Click()
Dim fs As Object Dim oldPath As String, newPath As String
Dim CurrentDate As String
CurrentDate = Format(Now, "MMDDYY")
oldPath = "\\xxx\xxx Database" 'Folder file is located in
'newPath = "\\xxx\xxx\FINANCE\USERS\xxx\xxx Operations\xxx\xxx\" 'Folder to copy file to
newPath = "C:\Users\xxx\Documents\xxx\xxx" 'Folder to copy file to
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile oldPath & "\" & "xxx Database Update v.1.6_be.accdb", newPath & "\" _
& "xxx Database Update v.1.6_be_" & CurrentDate & ".accdb"
Set fs = Nothing
MsgBox "Database Backed up", , "Backup Complete"
End Sub
This worked fine.
However I have now been asked to also send the database to a shared inbox email address.
Private Sub btnbrowse_click()
Dim filediag As FileDialog
Dim file As Variant
Set filediag = FileDialog(msofiledialogfilepicker)
filediag.allowmultiselect = False
If filediag.show Then
For Each file In filediag.selecteditems
Me.txtattachment = file
Next
End If
End Sub
Private Sub btnSend_Click()
Dim oApp As New Outlook.Application
Dim oEmail As Outlook.MailItem
Set oEmail = oApp.CreateItem(olMailItem)
oEmail.To = Me.txtto
oEmail.Subject = Me.txtsubject
oEmail.Body = Me.txtbody
If Len(Me.txtattachment) > 0 Then
oEmail.Attachments.Add Me.txtattachment.Value
End If
With oEmail
If Not IsNull(.To) And Not IsNull(.Subject) And Not IsNull(.Body) Then
.Send
MsgBox "Email Sent!"
Else
MsgBox "Please fill out the required fields."
End If
End With
End Sub
Please can somebody help me link the two scripts so that instead of using the FileDialog to choose the email attachment, I can use the path in the first query to select the attachment and the script will run both the save file and the email file commands at the same time.
It's just the filename, so it could be just passing the value from your script:
oEmail.Attachments.Add newPath & "\xxx Database Update v.1.6_be_" & CurrentDate & ".accdb"
If you want to just automatically send after the backup, make the email code a Sub that can be called in Backup button click procedure.
Sub SendEmail(strFile As String)
...
oEmail.Attachments.Add strFile
...
End Sub
Then calling the sub at end of the Backup button click:
SendEmail(newPath & "\xxx Database Update v.1.6_be_" & CurrentDate & ".accdb")
Many email systems reject emails with Access file as an attachment because of malicious code risk. However, a zipped Access file should pass security. Example code:
Dim strZip As String
strZip = CurrentProject.Path & "\Construction.zip"
'create empty zip folder
'found this on web, no idea what the Print line does but if it isn't there, this won't work
Open strZip For Output As #1
Print #1, "PK" & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
'copy file into zip folder
Dim objApp As Object
Set objApp = CreateObject("Shell.Application")
'variable for source file doesn't seem to work in this line
'also double parens not in original example code but won't work without
objApp.NameSpace((strZip)).CopyHere CurrentProject.Path & "\Construction.accdb"
As noted in code comment, issue is passing source file via variable. Sorry, I never needed to solve.
Creating zip file code could be in the email procedure and then attach the zip file:
oEmail.Attachments.Add strZip
Then at the end of email procedure, can delete the zip file:
Kill strZip

retrieve current path from file saved on server

How I can retrieve the current path of current db?
I've one AC07 program, to distribute it I save one copy on the intranet server, how to copy this program into our PC and then use it?
Always some people open the file directly on server.
When the file is open one form star automatically, in this form I put this code:
Private Sub Form_Load()
On Error GoTo ErrorHandler
Dim StrServer As String
StrServer = "\\itbgafs01\Comune\Dashboard\"
If GetDBPath() = StrServer Then
MsgBox "You can't open this file from server" & vbCrLf & _
"save one copy on you PC, and use those", vbCritical, "Dashboard.info"
Application.Quit
End If
Public Function GetDBPath() As String
Dim strFullPath As String
Dim I As Integer
strFullPath = CurrentDb().Name
For I = Len(strFullPath) To 1 Step -1
If Mid(strFullPath, I, 1) = "\" Then
GetDBPath = left(strFullPath, I)
Exit For
End If
Next
End Function
My problem is: some PC are mapped on drive H: the server directory then the path result is H:\Comune\Dashboard\ and not \\itbgafs01\\Dashboard\.
How I can retrieve the absolute path?
First I think to use more if like:
Private Sub Form_Load()
On Error GoTo ErrorHandler
Dim StrServer As String
Dim StrMaph As String
StrServer = "\\itbgafs01\Comune\Dashboard\"
StrMaph = "H:\Comune\Dashboard\"
MsgBox StrServer & vbCrLf & _
StrMaph & vbCrLf & _
GetDBPath()
If GetDBPath() = StrServer Or GetDBPath() = StrMaph Then
MsgBox "Non puoi aprire il file sul server" & vbCrLf & _
"copialo sul tuo pC ed avvia il programma da li", vbCritical, "Dashboard.info"
Application.Quit
End If
Is there another way to do it?
You can use the Scripting Runtime to get the UNC path of the drive then replace it in the currentDb.Name.
E.g.:
Sub blah()
Debug.Print GetUNCPath(CurrentDb.Name)
End Sub
Function GetUNCPath(path As String) As String
Dim fso As Object, shareName
Set fso = CreateObject("Scripting.FileSystemObject")
shareName = fso.GetDrive( _
fso.GetDriveName(path)).shareName
'sharename is empty if it wasn't a network mapped drive (e.g. local C: drive)
If shareName <> "" Then
GetUNCPath = shareName & Right(path, Len(path) - InStr(1, path, "\"))
Else
GetUNCPath = path
End If
End Function
Edit: alternatively you can use a call to the WinAPI to get the info: https://support.microsoft.com/en-us/kb/160529

Outlook Attachment.SaveAsFile with accented filename results in file not found

I have an email message with an image attachment that I want to save with a VBA macro. The file name and the display name show French accents in the attachment name (e.g. "Événement.jpg").
Saving the attachment with Outlook VBA works:
Dim fso As Object
Dim sFileName As String
Dim oAttachment As Outlook.attachment
set fso = CreateObject("Scripting.FileSystemObject")
' Edit the folder location accordingly:
sFileName = "C:\Users\YOUR_ACCOUNT_HERE\Desktop\" & oAttachment.getFileName
oAttachment.SaveAsFile sFileName
I can see the file correctly named on the file system.
Trying to access this file within VBA later on fails. The following code always returns FALSE:
' Returns False
MsgBox "File [" & sFileName & "] exists? " & sfo.fileexists(sFileName), vbInformation
Dim bFileExists as Boolean
If lenB (Dir(sFileName) > 0 Then
bFileExists = True
Else
bFileExists = True
EndIf
' Also returns False
MsgBox "File [" & sFileName & "] exists? " & bFileExists, vbInformation
What am I doing wrong?
I eventually came upon a workaround, thanks to the MS-DOS "8.3" file naming legacy of Windows. Converting the file name to its short file name makes Dir() and Open() happy:
Dim sFileShortName As String
sFileShortName = fso.Getfile(sTempFileLocation).shortpath
bFileExists = (Dir(sFileShortName) <> "") ' Now returns True at last!
Now fso.FileExists(sFileShortName) as well as bFileExists (based on Dir()) return True and Open sFileShortName For Binary Access Read As lFileNum works as well.
I hope that this will be beneficial to others.