Probleme mit VBA und OneDrive

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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, _ 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 R_DESKTOP As Long = &H10 Private Const NO_ERROR As Long = 0& Private Const MAX_PATH As Long = 260& 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 Public Sub test() Dim strPath As String strPath = GetPath(R_DESKTOP) MsgBox strPath & "\" End Sub

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

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

Sub Save_and_Send() Dim c As Comment For Each c In ActiveSheet.Comments c.Visible = False Next ActiveWorkbook.Save 'letzten Stand speichern Dim pdf As String pdf = pdf_erstellen Call permail(pdf) Kill (pdf) 'pdf wieder löschen End Sub

Function pdf_erstellen() Dim pdf As String Dim sep As String sep = Application.PathSeparator pdf = ThisWorkbook.Path & sep & ActiveSheet.Range("E3").Value & ActiveSheet.Range("J3").Value & ".pdf" 'ThisWorkbook.Path & sep & ThisWorkbook.name & ".pdf" 'Speicherpfad If Sheets("Tabelle3").Visible = xlSheetVisible Then Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select Else Sheets(Array("Tabelle1", "Tabelle2")).Select End If On Error Resume Next ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdf, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 pdf_erstellen = pdf Sheets("Packaging Instruction").Select 'Gruppierung aufheben End Function

Public Sub Save_and_Send() Dim c As Comment Dim pdf As String For Each c In ActiveSheet.Comments c.Visible = False Next Thisworkbook.Save 'letzten Stand speichern pdf = pdf_erstellen Call permail(pdf) Kill pdf 'pdf wieder löschen End Sub Private Function pdf_erstellen() As String Dim pdf As String pdf = GetPath(CSIDL_DESKTOP) & "\" & Range("E3").Text & Range("J3").Text & ".pdf" If Sheets("Tabelle3").Visible = xlSheetVisible Then Sheets(Array("Tabelle1", "Tabelle2", "Tabelle3")).Select Else Sheets(Array("Tabelle1", "Tabelle2")).Select End If On Error Resume Next ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdf, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 pdf_erstellen = pdf Sheets("Packaging Instruction").Select 'Gruppierung aufheben End Function

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

7 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Probleme mit VBA und OneDrive

14 Beiträge zum Forumthread Beiträge zu diesem Forumthread

7 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread