Speichern in neuen Ordner

Sub Speichern_Makro() ' Speichern Makro gblnCancel = False ThisWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Range("M1").Value & _ Format$(Range("H1").Value, "000") & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled ThisWorkbook.Sheets("Protokoll").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _ ThisWorkbook.Path & "\" & Range("M1").Value & _ Format$(Range("H1").Value, "000") & ".pdf", Quality:=xlQualityStandard, _ IncludeDocProperties:=True, IgnorePrintAreas:=False, _ OpenAfterPublish:=False If Not gblnCancel Then Workbooks.Open ThisWorkbook.Path & "\Protokoll.xlsm" Dim WB As Workbook For Each WB In Workbooks If WB.Name ThisWorkbook.Name And _ WB.Name "Protokoll.xlsm" Then WB.Close SaveChanges:=True End If Next WB ThisWorkbook.Close SaveChanges:=True End If End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Ulli,
dann so:

Option Explicit

Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As String) As Long

Public gblnCancel As Boolean

Sub Speichern_Makro()
    '
    ' Speichern Makro
    '

    Dim strPathWb As String, strPathPDF As String, strPath As String

    gblnCancel = False

    strPath = ThisWorkbook.Path & "\"
    strPathWb = strPath & "Makro\"
    strPathPDF = strPath & "PDF\"

    Call MakeSureDirectoryPathExists(strPathWb)
    Call MakeSureDirectoryPathExists(strPathPDF)

    ThisWorkbook.SaveAs Filename:=strPathWb & Range("M1").Value & _
        Format$(Range("H1").Value, "000") & ".xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ThisWorkbook.Sheets("Protokoll").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        strPathPDF & Range("M1").Value & _
        Format$(Range("H1").Value, "000") & ".pdf", Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False

    If Not gblnCancel Then

        Workbooks.Open strPath & "Protokoll.xlsm"

        Dim WB As Workbook
        For Each WB In Workbooks
            If WB.Name <> ThisWorkbook.Name And _
                WB.Name <> "Protokoll.xlsm" Then
                WB.Close SaveChanges:=True
            End If
        Next WB
        ThisWorkbook.Close SaveChanges:=True

    End If
End Sub

Gruß
Nepumuk

Public Sub Speichern() ' Speichern Makro Dim objCell As Range Dim objTargetWorkbook As Workbook Dim objTargetWorksheet As Worksheet, objSourceWorksheet As Worksheet Dim objShape As Shape, objPicture As Picture Dim objName As Name Dim lngEmptyCells As Long Dim strPath As String Set objSourceWorksheet = ThisWorkbook.Worksheets("Protokoll") Call Tabelle1.Protect(Password:="4711", UserInterfaceOnly:=True) For Each objCell In objSourceWorksheet.Range("H1,B9,B13,Bewertung") lngEmptyCells = lngEmptyCells + IIf(IsEmpty(objCell.Value), 1, 0) Next If lngEmptyCells > 0 Then Call MsgBox("Bitte zuerst alle Pflicht-Felder (Blau) ausfüllen !", vbExclamation, " _ Hinweis") Else With Application .EnableEvents = False .ScreenUpdating = False End With strPath = ThisWorkbook.Path & "\" Set objTargetWorkbook = Workbooks.Add(Template:=xlWBATWorksheet) Set objTargetWorksheet = objTargetWorkbook.Worksheets(1) With objSourceWorksheet Call .Range(.PageSetup.PrintArea).Copy End With With objTargetWorksheet .Name = "Protokoll" Call .Cells(1, 1).PasteSpecial(Paste:=xlPasteColumnWidths) Call .Cells(1, 1).PasteSpecial(Paste:=xlPasteAll) Call .Cells(1, 1).Select .UsedRange.Value = .UsedRange.Value With .PageSetup .PrintArea = objSourceWorksheet.PageSetup.PrintArea .Zoom = False .FitToPagesTall = 2 .FitToPagesWide = 1 End With End With Application.CutCopyMode = False With objSourceWorksheet For Each objCell In .Range(.PageSetup.PrintArea).Columns(1).Cells objTargetWorksheet.Rows(objCell.Row).RowHeight = objCell.RowHeight Next End With On Error Resume Next For Each objShape In objSourceWorksheet.Shapes If objShape.Type = msoPicture Then Do Call objShape.Copy DoEvents Set objPicture = objTargetWorksheet.Pictures.Paste(Link:=False) If Err.Number = 0 Then Exit Do Call Err.Clear Loop With objPicture .Top = objShape.Top .Left = objShape.Left End With End If Next On Error GoTo 0 For Each objName In ThisWorkbook.Names Call objTargetWorkbook.Names.Add(Name:=objName.Name, RefersTo:=objName.RefersTo) Next For Each objCell In objTargetWorksheet.Cells.SpecialCells(Type:=xlCellTypeAllValidation) _ Call objCell.Validation.Delete Next With objSourceWorksheet Call objTargetWorkbook.SaveAs(Filename:=strPath & .Range("M1").Value & _ Format$(.Range("H1").Value, "000") & ".xlsx", FileFormat:=xlOpenXMLWorkbook) End With Call objTargetWorkbook.Close(SaveChanges:=False) Application.DisplayAlerts = False Call ThisWorkbook.SaveAs(Filename:=Environ$("TEMP") & "\Temp.xlsm", _ FileFormat:=xlOpenXMLWorkbookMacroEnabled) Application.DisplayAlerts = True Call Workbooks.Open(Filename:=strPath & "Protokoll.xlsm") Set objSourceWorksheet = Nothing Set objTargetWorksheet = Nothing Set objTargetWorkbook = Nothing Set objPicture = Nothing With Application .EnableEvents = True .ScreenUpdating = True End With Call ThisWorkbook.Close(SaveChanges:=False) End If End Sub

Hallo Nepumuk,
ich habe noch eine Frage zu einem Code den du mir erstellt hast.
Ich speichere Fotos mit der webcam in definierte Zellen mit z.B. folgenden code.

Public Sub NewPhoto5()
With UserForm1
Set .Range = Range("Foto5")
Call .Show
End With
End Sub

Jetzt würde ich gerne das Foto in einer beliebigen "AKtiven Zelle" (nicht wie hier vorgegeben in Zelle "Foto5") einfügen. Ich möchte das Makro mit einem Tastenkürzel aufrufen.
Habe schon einiges mit ActiveCell versucht, bekomme es aber nicht hin.
Hast du noch einen Tipp für mich?
Ich hoffe es ist nur eine Kleinigkeit.
Ich weis nicht ob folgendes auch noch angepasst werden muss.
Gruß Ulli
Option Explicit
Private mblnStop As Boolean
Private mobjRange As Range

Private Sub CommandButton1_Click()
mblnStop = True
CommandButton1.Enabled = False
CommandButton2.Enabled = True
CommandButton3.Enabled = True
End Sub

Private Sub CommandButton2_Click()
mblnStop = False
Call UserForm_Activate
End Sub

Private Sub CommandButton3_Click()
'ActiveSheet.Unprotect
Dim objPicture As Picture
Set objPicture = Tabelle1.Pictures.Paste(Link:=False)
With objPicture
.ShapeRange.LockAspectRatio = msoTrue
.Width = Range.MergeArea.Width
.Height = Range.MergeArea.Height
If .Width > Range.MergeArea.Width Then .Width = Range.MergeArea.Width
.Left = Range.Columns(1).Left + Range.MergeArea.Width / 2 - .Width / 2
.Top = Range.Rows(1).Top + Range.MergeArea.Height / 2 - .Height / 2
End With
Set objPicture = Nothing
'ActiveSheet.Protect
End Sub

Private Sub CommandButton4_Click()
mblnStop = True
Call CloseCamera
Call Unload(Object:=UserForm2)
Call Unload(Object:=Me)
Call Tabelle1.Protect(Password:="4711", UserInterfaceOnly:=True) ' neu 09.12.2020
End Sub

Private Sub UserForm_Activate()
CommandButton1.Enabled = True
CommandButton2.Enabled = False
CommandButton3.Enabled = False
Do
Set Image1.Picture = GetCameraPicture
DoEvents
Loop Until mblnStop Or gblnCancelDialog
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = 1
Else
Set Range = Nothing
End If
End Sub

Friend Property Get Range() As Range
Set Range = mobjRange
End Property
Friend Property Set Range(ByRef probjRange As Range)
Set mobjRange = probjRange
End Property

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

80 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Speichern in neuen Ordner

20 Beiträge zum Forumthread Beiträge zu diesem Forumthread

80 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

20
Beiträge zum Forumthread

Beiträge zu diesem Forumthread