Probleme mit VBA und OneDrive

Stefan · 2022-02-16T14:55:04+00:00

Hallo zusammen, ich hoffe ihr könnt helfen. Unser VBA Excel Arbeitsmappe hat seither funktioniert. Ich bin der Meinung, seit unsere Firma unsere Dokumente mit OneDrive sichert, funktioniert die Mappe nicht mehr. Nun zum Problem. 1) Die Arbeitsmappe wird durch Drücken eines Buttons gespeichert und dann eine pdf auf dem User Desktop erstellt. Mittlerweile kommt der Fehler: Error No 1004. Das dokument wurde nicht gespeichert. Das Dokument ist möglicherweise geöffnet, oder beim Speichern ist ein Fehler aufgetreten. Der Desktop wird durch OneDrive gesichert/synchronisiert. Kann ich den Code entsprechend OneDrive tauglich gestalten? Sub create_pdf() Dim c As Comment For Each c In ActiveSheet.Comments c.Visible = False Next ActiveWorkbook.Save 'letzten Stand speichern On Error GoTo Fehler 'siehe Fehlerbehandlung unten Dim pfad As String Dim name As String If Sheets("Tabelle3").Visible = xlSheetVisible Then Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select Else Sheets(Array("Tabelle1", "Tabelle2")).Select End If name = Range("E3").Value & Range("J3").Value pfad = Environ("UserProfile") & "\Desktop\" ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ pfad & name & ".pdf", Quality:= _ xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False MsgBox Sheets("Packaging Instruction").Range("E3").Value & Sheets("Packaging Instruction").Range("J3").Value & " " & "saved on desktop.", vbInformation, "Information" End Sub

Hallo Stefan,
dann so:


Option Explicit
Private Declare PtrSafe Function SHGetPathFromIDListA Lib "shell32.dll" ( _
ByVal pidl As LongLong, _
ByVal pszPath As String) As Long
Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
ByVal hwndOwner As LongPtr, _
ByVal nFolder As Long, _
ByRef pidl As ITEMIDLIST) As Long
Private Type ITEMID
cb As LongLong
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As ITEMID
End Type
Private Const CSIDL_DESKTOP As Long = &H0
Private Const NO_ERROR As Long = 0&
Private Const MAX_PATH As Long = 260&
Public Sub Create_PDF()
Dim strPath As String
Dim objComment As Comment
Dim objFileDialog As FileDialog
For Each objComment In ActiveSheet.Comments
objComment.Visible = False
Next
ThisWorkbook.Save 'letzten Stand speichern
If Sheets("Tabelle3").Visible = xlSheetVisible Then
Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select
Else
Sheets(Array("Tabelle1", "Tabelle2")).Select
End If
strPath = GetPath(CSIDL_DESKTOP) & "\" & Range("E3").Text & Range("J3").Text
Set objFileDialog = Application.FileDialog(msoFileDialogSaveAs)
With objFileDialog
.FilterIndex = 26
.InitialFileName = strPath
If .Show Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=.SelectedItems(1), _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
MsgBox Sheets("Packaging Instruction").Range("E3").Value & _
Sheets("Packaging Instruction").Range("J3").Value & _
" saved on desktop.", vbInformation, "Information"
End If
End With
Set objFileDialog = Nothing
End Sub
Private Function GetPath(ByVal pvlngFolderType As Long) As String
Dim lngResult As Long
Dim strBuffer As String
Dim udtIDL As ITEMIDLIST
lngResult = SHGetSpecialFolderLocation(Application.Hwnd, pvlngFolderType, udtIDL)
If lngResult = NO_ERROR Then
strBuffer = Space$(MAX_PATH)
lngResult = SHGetPathFromIDListA(ByVal udtIDL.mkid.cb, ByVal strBuffer)
If lngResult = 1 Then GetPath = Left$(strBuffer, InStr(1, strBuffer, vbNullChar) - 1)
End If
End Function

Gruß
Nepumuk

Hallo Stefan,
das sollte in beiden Versionen laufen:


Option Explicit
Private Declare PtrSafe Function SHGetPathFromIDListA Lib "shell32.dll" ( _
ByVal pidl As LongPtr, _
ByVal pszPath As String) As Long
Private Declare PtrSafe Function SHGetSpecialFolderLocation Lib "shell32.dll" ( _
ByVal hwndOwner As LongPtr, _
ByVal nFolder As Long, _
ByRef pidl As ITEMIDLIST) As Long
Private Type ITEMID
cb As LongPtr
abID As Byte
End Type
Private Type ITEMIDLIST
mkid As ITEMID
End Type
Private Const CSIDL_DESKTOP As Long = &H0
Private Const NO_ERROR As Long = 0&
Private Const MAX_PATH As Long = 260&
Public Sub Create_PDF()
Dim strPath As String
Dim objComment As Comment
Dim objFileDialog As FileDialog
For Each objComment In ActiveSheet.Comments
objComment.Visible = False
Next
ThisWorkbook.Save 'letzten Stand speichern
If Sheets("Tabelle3").Visible = xlSheetVisible Then
Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select
Else
Sheets(Array("Tabelle1", "Tabelle2")).Select
End If
strPath = GetPath(CSIDL_DESKTOP) & "\" & Range("E3").Text & Range("J3").Text
Set objFileDialog = Application.FileDialog(msoFileDialogSaveAs)
With objFileDialog
.FilterIndex = 26
.InitialFileName = strPath
If .Show Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=.SelectedItems(1), _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
MsgBox Sheets("Packaging Instruction").Range("E3").Value & _
Sheets("Packaging Instruction").Range("J3").Value & _
" saved on desktop.", vbInformation, "Information"
End If
End With
Set objFileDialog = Nothing
End Sub
Private Function GetPath(ByVal pvlngFolderType As Long) As String
Dim lngResult As Long
Dim strBuffer As String
Dim udtIDL As ITEMIDLIST
lngResult = SHGetSpecialFolderLocation(Application.Hwnd, pvlngFolderType, udtIDL)
If lngResult = NO_ERROR Then
strBuffer = Space$(MAX_PATH)
lngResult = SHGetPathFromIDListA(ByVal udtIDL.mkid.cb, ByVal strBuffer)
If lngResult = 1 Then GetPath = Left$(strBuffer, InStr(1, strBuffer, vbNullChar) - 1)
End If
End Function

Gruß
Nepumuk

Forumthread: Probleme mit VBA und OneDrive

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial