VBA: Tweak Export to HTML code to create folder on desktop and save there?

Hi all,

I am using the following code to export a range of cells (with HTML content) to one consolidated HTML file.
This used to work perfectly until I moved all of my data to OneDrive. Not it seems like VBA doesn't have permissions anymore to write to the same path as the .xlsm is in (which sits in OneDrive)?

I'm wondering, is there a way to tweak this code to use the filepicker instead so I can choose a non-OneDrive folder to save the HTML?

At the moment, the below code only works if the .xlsm is saved in a non-OneDrive location (e.g. Desktop).

The code is:

Sub SaveAsUTF8HTMLall()
 
    Dim Cell        As Range
    Dim filename    As String
    Dim Rng         As Range

    ' ADODB.Stream file I/O constants
    Const adCrLf                As Long = -1
    Const adSaveCreateNotExist  As Long = 1
    Const adSaveCreateOverWrite As Long = 2
    Const adTypeText            As Long = 2
 
       filename = ThisWorkbook.Path & "\Export" & Replace(Sheets("Settings").Range("C31").Value, " ", "_") & ".html" 'cell C31 contains the file name of the consolidated HTML
        Set Rng = Worksheets("Settings").Range("C33:C129") 'this is the range that holds the HTML content to consolidate
        
        On Error Resume Next
    
        With CreateObject("ADODB.Stream")
            .Open
            .Type = adTypeText
            .Position = 0
            .Charset = "utf-8"
            .LineSeparator = adCrLf
            For Each Cell In Rng
                .WriteText Cell.Text
            Next Cell
            .SaveToFile filename, adSaveCreateOverWrite
            .SetEOS
            .Close
        End With
Application.ScreenUpdating = True           
End Sub

Hope someone can help this VBA newbie here?
Thanks!

Sub Test_DesktopFolder()
  MsgBox DesktopFolder
End Sub

Function DesktopFolder()
  Dim wshShell As Object, s As String
  Set wshShell = CreateObject("WScript.Shell")
  s = wshShell.SpecialFolders("Desktop")
  Set wshShell = Nothing
  DesktopFolder = s
End Function

Hi Kenneth,

Thanks so much! This seems to give me a message with the path to the desktop, but could you help me understand how I can tweak the code to use the file picker to create/select a folder (that's not on OneDrive) to save my file there?
At the moment, the code saves in the same location as the .xlsm, which doesn't seem to work (as that sits in a shared environment).

Appreciate the help!
Thank you!

Sub SaveAsUTF8HTMLall()
  Dim Cell As Range, filename As String, Rng As Range
  Dim p As String
  
  On Error Resume Next
  p = DesktopFolder & "\KingOfCamden\"
  MkDir p
  
  'filename = ThisWorkbook.Path & "\Export" & Replace(Sheets("Settings").Range("C31").Value, " ", "_") & ".html" 'cell C31 contains the file name of the consolidated HTML
  filename = p & "Export" & Replace(Sheets("Settings").Range("C31").Value, " ", "_") & ".html" 'cell C31 contains the file name of the consolidated HTML

  Application.ScreenUpdating = False
  
  ' ADODB.Stream file I/O constants
  Const adCrLf As Long = -1
  Const adSaveCreateNotExist  As Long = 1
  Const adSaveCreateOverWrite As Long = 2
  Const adTypeText As Long = 2
  
  Set Rng = Worksheets("Settings").Range("C33:C129") 'this is the range that holds the HTML content to consolidate
  
   With CreateObject("ADODB.Stream")
    .Open
    .Type = adTypeText
    .Position = 0
    .Charset = "utf-8"
    .LineSeparator = adCrLf
    
    For Each Cell In Rng
      .WriteText Cell.Text
    Next Cell
    
    .SaveToFile filename, adSaveCreateOverWrite
    .SetEOS
    .Close
  End With
  
  Application.ScreenUpdating = True
End Sub


Function DesktopFolder()
  Dim wshShell As Object, s As String
  Set wshShell = CreateObject("WScript.Shell")
  s = wshShell.SpecialFolders("Desktop")
  Set wshShell = Nothing
  DesktopFolder = s
End Function

Hey Kenneth,

Great, thank you! This does not use file picker, but can also work with creating a folder directly on desktop Thank you!
I tried to apply the updates to a similar code (which is to export individual files rather than one, consolidated file) and I got it to work, however, it's only creating 0kb files without a file extension at the moment (file names are correct though)...do you have any idea what I might be doing wrong? Tried a few things without luck, sadly...

Sub SaveAsUTF8HTMLindividualNEW()

  Dim Cell As Range
  Dim filename As String
  Dim p As String
  Dim Rng1 As Range
  Dim Rng2 As Range
  Dim index As Long
  
    On Error Resume Next
  p = DesktopFolder & "\" & Sheets("Settings").Range("C7").Value & "\" 'cell that holds the folder name to use on desktop
  MkDir p

Application.ScreenUpdating = False

 ' ADODB.Stream file I/O constants
  Const adCrLf As Long = -1
  Const adSaveCreateNotExist  As Long = 1
  Const adSaveCreateOverWrite As Long = 2
  Const adTypeText As Long = 2

        Path = p
        
        Set Rng1 = Worksheets("Translator").Range("E10:E101")  ' Range with HTMLs to export individually
        Set Rng2 = Worksheets("Settings").Range("D11:D102") ' Range of filenames to use for individual HTMLs
        
        With CreateObject("ADODB.Stream")
            .Open
            .Type = adTypeText
            .Position = 0
            .Charset = "utf-8"
            .LineSeparator = adCrLf
            
            For Each Cell In Rng1
             index = index + 1
             .WriteText Cell.Text
             filename = p & Sheets("HTML_RawData").Range("A2").Value & Replace(Rng2.Cells(index, 1).Value, " ", "_") & ".html" 'Adapt path and any prefixes here
             .SaveToFile filename, adSaveCreateOverWrite
           .SetEOS
           Next Cell
           .Close
        End With

Application.ScreenUpdating = True
 
End Sub
Function DesktopFolder()
  Dim wshShell As Object, s As String
  Set wshShell = CreateObject("WScript.Shell")
  s = wshShell.SpecialFolders("Desktop")
  Set wshShell = Nothing
  DesktopFolder = s
End Function

Thanks so much!

I have not used that method. Can you attach a simple example to test?

If you did Debug.Print filename, does it show the right filename string in Immediate Window?

Hey Kenneth,

Sure thing! Attached - hope this helps?

As said, it seems to be creating files, but just not writing anything to them :-(

Thanks so much for your help!

Hi Kenneth,

Ahhh, good spot! I did not think about that! Thanks so much! Changed the file name and this works now Yaaay!

Thanks again and have a great day!