VBA saving file to OneDrive

J

jayettar

New Member
Joined
Aug 5, 2013
Messages
11
Hello all,

My company just migrated over to One Drive from a corporate shared drive, our inventory spreadsheet would use ThisWorkbook.path to save a copy each time someone would email it, now with One Drive using an HTTP protocol I get the run time error. Would someone please help me with what I need to change up or insert in my code?
Thanks ahead of time.

Terminal = "Richmond"

Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
saveformat = Application.DefaultSaveFormat

ans = MsgBox("This will Email a copy of this report via OUTLOOK" & vbCrLf & vbCrLf & _
"OK?", vbYesNoCancel + vbQuestion)
If ans = 2 Then Exit Function
If ans = 7 Then MsgBox "Try again": Exit Function


FileExtStr = ".xlsx": FileFormatNum = 51

FileVer = 1
salesdate = Sheets("Tank Report").Range("h4").Text
salesdate1 = Application.Text(salesdate, "mm-dd-yyyy")
VerStr = " (" & FileVer & ")"
suggname = Terminal & " Inventory Report " & salesdate1 & VerStr & FileExtStr

'>>>>>>>>>>
'Copies File over to new workbook
'use for Emailing via Notes
Set wb = ActiveWorkbook
Set Wbsf = Workbooks.Add
Set Wbsf = ActiveWorkbook
wbsf1 = suggname


' Checks to see if file exists ...
'Add Digit to version number
Do While Dir(ThisWorkbook.Path & "\" & wbsf1) <> ""

ExisFile = Dir(ThisWorkbook.Path & "\" & wbsf1)
FileVer = Mid(ExisFile, InStr(ExisFile, "(") + 1, 1)
FileVer = FileVer + 1
VerStr = " (" & FileVer & ")"
suggname = Terminal & " Inventory Report " & salesdate1 & VerStr & FileExtStr
wbsf1 = suggname
'MsgBox FileVer
'MsgBox "OOPS File Exists", vbOKCancel + vbQuestion

Loop

On Error GoTo Errorhandler1

ActiveWorkbook.SaveAs fileName:=ThisWorkbook.Path & "\" & wbsf1, FileFormat:=FileFormatNum
 

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
Sort by date Sort by votes
rpaulson said:
stackoverflow.com

VBA: How to get the local filepath of a workbook that uses the new autosave feature (and thus is technically opened from OneDrive)?

I have a workbook that does some analysis and outputs its results to a textfile in the same directory as the workbook is saved. I need to run this code on multiple computers so the local directory
stackoverflow.com stackoverflow.com
Click to expand...
Thanks for the reply, I'm having issues trying to figure out where that goes, would it replace the path part or would I need to change it all around?
 
Upvote 0
VBA Code: 
............

Dim fso as FileSystemObject, localPath as String
localPath = fso.GetParentFolderName(fso.GetAbsolutePathName(Application.ActiveWorkbook.Name))


ActiveWorkbook.SaveAs fileName:=localPath & "\" & wbsf1, FileFormat:=FileFormatNum
 
Upvote 0
rpaulson said:
VBA Code: 
............

Dim fso as FileSystemObject, localPath as String
localPath = fso.GetParentFolderName(fso.GetAbsolutePathName(Application.ActiveWorkbook.Name))


ActiveWorkbook.SaveAs fileName:=localPath & "\" & wbsf1, FileFormat:=FileFormatNum
Click to expand...
I appreciate all your help but I'm not getting this to work, just errors.
 
Upvote 0
I've attached the entire code that I have, when I run it and it hits (Do While Dir(ThisWorkbook.Path & "\" & wbsf1) <> "") I get the error, I only assume this is because of ThisWorkbook.Path gives back a URL for OneDrive. I've tried a bunch of different options all giving me the same results. I can't hardcode a path because it will be used by a host of users all using different OneDirve or SharePoint per facility.

If anyone has any ideas PLEASE let me know.

VBA Code: 
Option Explicit
Sub Send_Outlook_Albany()
'>>>>>>>>>>>>>>>

'setup for Outlook 3/5/16

'<<<<<<<<<<<<<<
Dim wb, Wbsf As Workbook
Dim ans, FileVer As Integer
Dim wbsf1, suggname, salesdate, salesdate1, saveformat As String
Dim ExisFile, VerStr As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Terminal As String
Dim I As Long
                  
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
                  
 
Terminal = "Tampa"

Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
saveformat = Application.DefaultSaveFormat
 
                     ans = MsgBox("This will Email a copy of this report via OUTLOOK" & vbCrLf & vbCrLf & _
                    "OK?", vbYesNoCancel + vbQuestion)
                    If ans = 2 Then Exit Sub
                    If ans = 7 Then MsgBox "Try again": Exit Sub
                  
                  
FileExtStr = ".xlsx": FileFormatNum = 51

FileVer = 1
salesdate = Sheets("Tank Report").Range("h4").Text
salesdate1 = Application.Text(salesdate, "mm-dd-yyyy")
VerStr = " (" & FileVer & ")"
suggname = Terminal & " Inventory Report " & salesdate1 & VerStr & FileExtStr
      
'>>>>>>>>>>
'Copies File over to new workbook
'use for Emailing via Notes
Set wb = ActiveWorkbook
Set Wbsf = Workbooks.Add
Set Wbsf = ActiveWorkbook
wbsf1 = suggname


' Checks to see if file exists ...
'Add Digit to version number
Do While Dir(ThisWorkbook.Path & "\" & wbsf1) <> ""

ExisFile = Dir(ThisWorkbook.Path & "\" & wbsf1)
FileVer = Mid(ExisFile, InStr(ExisFile, "(") + 1, 1)
FileVer = FileVer + 1
VerStr = " (" & FileVer & ")"
suggname = Terminal & " Inventory Report " & salesdate1 & VerStr & FileExtStr
wbsf1 = suggname
'MsgBox FileVer
'MsgBox "OOPS File Exists", vbOKCancel + vbQuestion

Loop

On Error GoTo Errorhandler1

ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & wbsf1, FileFormat:=FileFormatNum

wbsf1 = Wbsf.Name
                    If Val(Application.Version) > 14 Then
                            'You use Excel 2013 or higher
                        With Wbsf
                        Sheets.Add After:=ActiveSheet
                        Sheets.Add After:=ActiveSheet
                        End With
                    Else
                            'You use Excel 2010 or lower
                    End If
With wb
    .Activate
    .Sheets("Tank Report").Activate
    Range("a1:r57").Select
   .Sheets(Array("Tank Report", "Inventory", "Status")).Select
    Selection.Copy
End With

With Wbsf.Sheets("Sheet1").Range("a1")
    .PasteSpecial xlPasteAllUsingSourceTheme
    '.PasteSpecial xlPasteAll
    .PasteSpecial xlPasteColumnWidths
    .PasteSpecial xlPasteValues
End With
 
 
 'Get a Global logo. Check for name
    wb.Sheets("vessel report").Activate
    ActiveSheet.Shapes("Picture 199").Select
    Selection.Copy
  
  
 
    Wbsf.Sheets("sheet3").Activate
    ActiveWindow.DisplayGridlines = False
    Wbsf.Sheets("sheet2").Activate
    ActiveWindow.DisplayGridlines = False
    Wbsf.Sheets("sheet1").Activate
    ActiveWindow.DisplayGridlines = False
 
    'Paste Global Logo
    Wbsf.Sheets("Sheet1").Range("a1").Select
    ActiveSheet.Paste
    Wbsf.Sheets("sheet3").Activate
    Wbsf.Sheets("Sheet3").Range("a1").Select
    ActiveSheet.Paste
    Wbsf.Sheets("sheet2").Activate
    Wbsf.Sheets("Sheet2").Range("a1").Select
    ActiveSheet.Paste


'Resets Original Workbook
With wb
    .Sheets("Status").Activate
    .Sheets("Status").Select
    Range("a1").Select
    .Sheets("Tank Report").Activate
    .Sheets("Tank Report").Select
    Range("c10").Select
    .Sheets("Rate Report").Activate
    .Sheets("Rate Report").Select
    Range("D3").Select
    .Sheets("Vessel Report").Activate
    .Sheets("Vessel Report").Select
    Range("C5").Select
    .Sheets("Inventory").Select
End With
Application.CutCopyMode = False


' sets up the send file
With Wbsf
    .Sheets("sheet1").Name = "Tank Report"
    .Sheets("sheet2").Name = "Inventory"
    .Sheets("sheet3").Name = "Status"

  
   ' activate and set print area
    .Sheets("Tank Report").Activate
    .Sheets("Tank Report").Select
       With ActiveSheet.PageSetup
        .PrintArea = "A1:R57"
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintGridlines = False
       End With
       .Sheets("Tank Report").Range("a1").Select
  
    'activate and set print area
    .Sheets("Inventory").Activate
    .Sheets("Inventory").Select
       With ActiveSheet.PageSetup
        .PrintArea = "A1:p35"
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintGridlines = False
       End With
       .Sheets("Inventory").Range("a1").Select
  
    'activate and set print area
    .Sheets("Status").Activate
    .Sheets("Status").Select
       With ActiveSheet.PageSetup
        .PrintArea = "A1:i42"
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.5)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .CenterHorizontally = True
        .CenterVertically = False
        .Orientation = xlLandscape
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintGridlines = False
       End With
       .Sheets("Status").Range("a1").Select
 
        
    .Sheets("Inventory").Activate
    .Sheets("Inventory").Range("a1").Select

End With
  
ActiveWorkbook.Save


'<<<<<<<<<<<MAIL it


Application.CutCopyMode = False

 On Error Resume Next
    With OutMail
        .To = "PLavalle@globalp.com; terminalaccounting@globalp.com; SMccool@globalp.com; craig.yocham@globalp.com, khoyt@globalp.com; jday@globalp.com"
        .CC = "jratte@globalp.com"
        .BCC = ""
        .Subject = wbsf1
        .Body = " Attached is the file - " & wbsf1
        .Attachments.Add Wbsf.FullName
        .Display '.send
    End With
    On Error GoTo 0


With Wbsf
          .Close SaveChanges:=False
End With

               
                   Set OutApp = Nothing
                   Set OutMail = Nothing
                 
                 
With wb.Sheets("Inventory")
    .Activate
    .Select
    .Range("a1").Select
End With
 
'Set DefaultSaveFormat back to the users setting
Application.DefaultSaveFormat = saveformat

With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
End With

Exit Sub
Errorhandler1:

With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
End With



End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question
Save File VBA code works perfectly....except.....
Replies
1
Views
268
rlv01
R
P
  • Locked
  • Question
Edit VBA code to let it automatically create Folder
Replies
5
Views
471
RoryA
RoryA
G
  • Question
VBA. Save sheets as values in separate workbooks. The problem is, all data in original file is saved as metadata.
Replies
0
Views
661
Gloffo
G
E
  • Question
VBA-sending different attachments to different persons
Replies
7
Views
1K
I_know_nuffin
I
A
  • Question
Automating 'save to PDF' directly to Downloads & Email
Replies
2
Views
937
Domenic
D

Forum statistics

Threads
1,215,072
Messages
6,122,968
Members
449,095
Latest member
Mr Hughes

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top