Anzeige
Archiv - Navigation
652to656
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
652to656
652to656
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Mkro zum speichern (ohne Makros)

Mkro zum speichern (ohne Makros)
20.08.2005 10:09:12
Wuntschi
Hallo an alle,
ich mache einen letzten Versuch,
wer kann mir helfen bei folgendem Problem:
Ich benötige ein Makro mit dem ich mein Tabellenblatt speichern kann.
Folgende Bedingungen sind da dran geknüpft:
1. Es muß mit Excel 97 lauf fähig sein!
2. Es soll eine Auswahl des Pfades erscheinen wo man dann
auswählt wo diese Datei hin gespeichert werden soll.
3. Es soll die Tabelle in diesen Pfad ohne Makros speichern.
4. Die Datei die gespeichert wird soll so heißen wie der Wert in der
Zelle A1 vom Worksheet "coordinates"
Wäre echt toll wenn ihr mir da helfen könntet!
Vielen Danke!
Gruß
Wuntschi

8
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro zum speichern (ohne Makros)
20.08.2005 10:32:14
Wuntschi
Dieses ist der Code den ich aus dem Forum habe dieser Funktionoiert aber bei Excel 97 nicht!

Sub speichern_ohne_makro()
Dim i As Integer, y As Integer, totFiles As Integer, Qe As Integer
Dim Sind As Long
Dim wks As Worksheet
Dim gefFile As String
Dim Suchbegriff As String, Suchpfad As String
Dim oldStatus As Variant
'Neue Funktion erst ab Office XP verwendbar
'bzw. auch unter 2000 wenn ein Verweis auf die Office 10 Library
'gesetzt werden kann.
'Öffnet einen Dialog indem der Pfad elegant wie im normalen
'Datei-Dialog gewählt werden kann.
Dim Suchdialog As FileDialog
Set Suchdialog = Application.FileDialog(msoFileDialogFolderPicker)
If Application.Version < 10 Then
Qe = MsgBox("Diese Datei bzw. dieser Suchdialog ist erst ab EXCEL XP möglich!", vbCritical + vbOKOnly, "Tut mir leid...")
Exit Sub
End If
oldStatus = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'Hier gibt es ein Dialog der kurz zeigt was zutun ist'
ModulAnweisung.AW0002
'Hier wird der neue FolderPickerDialog aufgerufen
With Suchdialog
.Title = "Bitte wählen Sie ein Verzeichnis aus"
'Environ(25) ermittelt den Aktuellen Userpfad
.InitialFileName = Environ(25) & "\Eigene Dateien\"
.ButtonName = "Auswahl übernehmen"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Sie haben keine Auswahl getroffen", vbInformation
Set Suchdialog = Nothing
Exit Sub
Else
For Sind = 1 To .SelectedItems.Count
Suchpfad = Suchpfad & .SelectedItems(Sind)
Next Sind
End If
End With
ActiveSheet.Copy
Call DelModule
Call DelUForms
Call DelEvent
ActiveWorkbook.SaveAs Suchpfad & "\" & Worksheets("Coordinates").Cells(1, 7) & "_" & Worksheets("Coordinates").Cells(1, 1) & ".xls", xlNormal
End Sub


Sub DelModule()
'Löscht Module:
Dim n As Integer
With ActiveWorkbook
For n = .VBProject.VBComponents.Count To 1 Step -1
If .VBProject.VBComponents(n).Type = 1 Then
.VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
End If
Next
End With
End Sub


Sub DelUForms()
'Löscht Userforms:
Dim n As Integer
With ActiveWorkbook
For n = .VBProject.VBComponents.Count To 1 Step -1
If .VBProject.VBComponents(n).Type = 3 Then
.VBProject.VBComponents(n).Collection.Remove .VBProject.VBComponents(n)
End If
Next
End With
End Sub


Sub DelEvent()
'Löscht Ereignisprozeduren:
Dim n As Integer
With ActiveWorkbook
For n = .VBProject.VBComponents.Count To 1 Step -1
For i = 1 To .VBProject.VBComponents(n).CodeModule.CountOfLines
If .VBProject.VBComponents(n).Type <> 1 And .VBProject.VBComponents(n).Type <> 3 Then _
.VBProject.VBComponents(n).CodeModule.DeleteLines 1
Next
Next
End With
End Sub

Gruß
Wuntschi
Anzeige
AW: Makro zum speichern (ohne Makros)
20.08.2005 11:17:46
Nepumuk
Hi,
versuch es mal so:
Option Explicit

Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    ByRef lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByRef wParam As Any, _
    ByRef lParam As Any) As Long

Private Type InfoT
    hWnd As Long
    Root As Long
    DisplayName As Long
    Title As Long
    Flags As Long
    FName As Long
    lParam As Long
    Image As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Public Enum BIF_Flag
    BIF_RETURNONLYFSDIRS = &H1
    BIF_DONTGOBELOWDOMAIN = &H2
    BIF_STATUSTEXT = &H4
    BIF_RETURNFSANCESTORS = &H8
    BIF_EDITBOX = &H10
    BIF_VALIDATE = &H20
    BIF_NEWDIALOGSTYLE = &H40
    BIF_BROWSEINCLUDEURLS = &H80
    BIF_BROWSEFORCOMPUTER = &H1000
    BIF_BROWSEFORPRINTER = &H2000
    BIF_BROWSEINCLUDEFILES = &H4000
    BIF_SHAREABLE = &H8000
End Enum

Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11

Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1

Private s_BrowseInitDir As String

Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As BIF_Flag = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String

    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
    s_BrowseInitDir = sPath
    With xl
        .hWnd = FindWindow("XLMAIN", vbNullString)
        .Root = 0
        .Title = lstrcat(sMsg, "")
        .Flags = lFlag
        .FName = FncCallback(AddressOf BrowseCallback)
    End With
    IDList = SHBrowseForFolder(xl)
    If IDList <> 0 Then
        FolderName = Space(256)
        RVal = SHGetPathFromIDList(IDList, FolderName)
        CoTaskMemFree (IDList)
        FolderName = Trim$(FolderName)
        FolderName = Left$(FolderName, Len(FolderName) - 1)
    End If
    fncGetFolder = FolderName
End Function

Private Function BrowseCallback( _
        ByVal hWnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long

    If uMsg = BFFM_INITIALIZED Then
        Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
        Call prcCenterDialog(hWnd)
    End If
    BrowseCallback = 0
End Function

Private Function FncCallback(ByVal nParam As Long) As Long
    FncCallback = nParam
End Function

Private Sub prcCenterDialog(ByVal hWnd As Long)
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
    Dim DlgWidth As Integer, DlgHeight As Integer
    GetWindowRect hWnd, WinRect
    DlgWidth = WinRect.Right - WinRect.Left
    DlgHeight = WinRect.Bottom - WinRect.Top
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
    MoveWindow hWnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub

Public Sub speichern_ohne_Makros()
    Dim strFolder As String, strFilename As String
    Dim objVBC As Object
    strFolder = Trim$(fncGetFolder())
    If strFolder <> "" Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
        strFilename = Worksheets("coordinates").Cells(1, 1).Text & ".xls"
        strFolder = strFolder & strFilename
        ThisWorkbook.SaveCopyAs strFolder
        Workbooks.Open strFolder
        With Workbooks(strFilename).VBProject
            For Each objVBC In .VBComponents
                Select Case objVBC.Type
                    Case 1, 2, 3
                        .VBComponents.Remove .VBComponents(objVBC.Name)
                    Case 100
                        With objVBC.CodeModule
                            .DeleteLines 1, .CountOfLines
                        End With
                End Select
            Next
        End With
        Workbooks(strFilename).Close SaveChanges:=True
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub

Gruß
Nepumuk
Excel & VBA – Beispiele
Anzeige
AW: Makro zum speichern (ohne Makros)
20.08.2005 11:31:19
Wuntschi
Hallo Nepumuk,
ich habe dein Code in ein Makro wie folgt gestzt,

Sub speichern_ohne_makro
DEIN CODE
End Sub

bekomme dann aber immer die Meldung bei Kompelieren das,
Nach End Sub , End Funczion oder Property können nur Komentare stehen
was mache ich falsch?
Gruß
Wuntschi
AW: Makro zum speichern (ohne Makros)
20.08.2005 11:35:15
Wuntschi
Hallo,
war mein fehler!
das Makro funktioniert einsame spitze !
vielen DAnk!
gruß
Wuntschi
AW: Makro zum speichern (ohne Makros)
20.08.2005 11:52:09
Nepumuk
Hi,
ich habe gerade gesehen, das da noch ein ENUM drin ist. Das mag Excel97 nicht. So sollte es laufen:
Option Explicit

Private Declare Function MoveWindow Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal bRepaint As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" ( _
    ByVal nIndex As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hWnd As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" ( _
    ByRef lpbi As InfoT) As Long
Private Declare Function CoTaskMemFree Lib "ole32" ( _
    ByVal hMem As Long) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" ( _
    ByVal lpStr1 As String, _
    ByVal lpStr2 As String) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" ( _
    ByVal pList As Long, _
    ByVal lpBuffer As String) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
    ByVal lpClassname As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" ( _
    ByVal hWnd As Long, _
    ByVal Msg As Long, _
    ByRef wParam As Any, _
    ByRef lParam As Any) As Long

Private Type InfoT
    hWnd As Long
    Root As Long
    DisplayName As Long
    Title As Long
    Flags As Long
    FName As Long
    lParam As Long
    Image As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_EDITBOX = &H10
Private Const BIF_VALIDATE = &H20
Private Const BIF_NEWDIALOGSTYLE = &H40
Private Const BIF_BROWSEINCLUDEURLS = &H80
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const BIF_BROWSEINCLUDEFILES = &H4000
Private Const BIF_SHAREABLE = &H8000

Private Const SM_CXFULLSCREEN = &H10
Private Const SM_CYFULLSCREEN = &H11

Private Const BFFM_SETSELECTION = &H466
Private Const BFFM_INITIALIZED = &H1

Private s_BrowseInitDir As String

Public Function fncGetFolder( _
        Optional ByVal sMsg As String = "Bitte wählen Sie ein Verzeichnis", _
        Optional ByVal lFlag As Long = BIF_RETURNONLYFSDIRS, _
        Optional ByVal sPath As String = "C:\") As String

    Dim xl As InfoT, IDList As Long, RVal As Long, FolderName As String
    s_BrowseInitDir = sPath
    With xl
        .hWnd = FindWindow("XLMAIN", vbNullString)
        .Root = 0
        .Title = lstrcat(sMsg, "")
        .Flags = lFlag
        .FName = FncCallback(AddressOf BrowseCallback)
    End With
    IDList = SHBrowseForFolder(xl)
    If IDList <> 0 Then
        FolderName = Space(256)
        RVal = SHGetPathFromIDList(IDList, FolderName)
        CoTaskMemFree (IDList)
        FolderName = Trim$(FolderName)
        FolderName = Left$(FolderName, Len(FolderName) - 1)
    End If
    fncGetFolder = FolderName
End Function

Private Function BrowseCallback( _
        ByVal hWnd As Long, _
        ByVal uMsg As Long, _
        ByVal wParam As Long, _
        ByVal lParam As Long) As Long

    If uMsg = BFFM_INITIALIZED Then
        Call SendMessage(hWnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
        Call prcCenterDialog(hWnd)
    End If
    BrowseCallback = 0
End Function

Private Function FncCallback(ByVal nParam As Long) As Long
    FncCallback = nParam
End Function

Private Sub prcCenterDialog(ByVal hWnd As Long)
    Dim WinRect As RECT, ScrWidth As Integer, ScrHeight As Integer
    Dim DlgWidth As Integer, DlgHeight As Integer
    GetWindowRect hWnd, WinRect
    DlgWidth = WinRect.Right - WinRect.Left
    DlgHeight = WinRect.Bottom - WinRect.Top
    ScrWidth = GetSystemMetrics(SM_CXFULLSCREEN)
    ScrHeight = GetSystemMetrics(SM_CYFULLSCREEN)
    MoveWindow hWnd, (ScrWidth - DlgWidth) / 2, _
        (ScrHeight - DlgHeight) / 2, DlgWidth, DlgHeight, 1
End Sub

Public Sub speichern_ohne_Makros()
    Dim strFolder As String, strFilename As String
    Dim objVBC As Object
    strFolder = Trim$(fncGetFolder())
    If strFolder <> "" Then
        With Application
            .ScreenUpdating = False
            .EnableEvents = False
        End With
        If Right$(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
        strFilename = Worksheets("coordinates").Cells(1, 1).Text & ".xls"
        strFolder = strFolder & strFilename
        ThisWorkbook.SaveCopyAs strFolder
        Workbooks.Open strFolder
        With Workbooks(strFilename).VBProject
            For Each objVBC In .VBComponents
                Select Case objVBC.Type
                    Case 1, 2, 3
                        .VBComponents.Remove .VBComponents(objVBC.Name)
                    Case 100
                        With objVBC.CodeModule
                            .DeleteLines 1, .CountOfLines
                        End With
                End Select
            Next
        End With
        Workbooks(strFilename).Close SaveChanges:=True
        With Application
            .ScreenUpdating = True
            .EnableEvents = True
        End With
    End If
End Sub

Gruß
Nepumuk
Excel & VBA – Beispiele
Anzeige
AW: Makro zum speichern (ohne Makros)
20.08.2005 14:19:56
Wuntschi
Hallo Nepumuk,
wenn du die Zeit hast könntest du dann evtl.
noch einige Erklärungen in den Code mit rein nehmen.
Damit ich den Code auch verstehe!
Und nochmal vielen Dank der Code funktionier super!
Gruß
Wuntschi
AW: Makro zum speichern (ohne Makros)
20.08.2005 20:44:21
HansH
Hallo Nepumuk,
wenn ich versuche deinen Code zu benutzen meckert mein Virenprogramm. Es erkennt beim Speichern einen "Virus.VBA" und blockiert.
Excel warnt: Datei wurde unter dem Namen "xxx" gespeichert. Kann nicht in "XXX" umbenannt werden. Sie müssen diese Datei schließen.
Was ist denn so gefährliches daran?
Gruß
HansH
AW: Makro zum speichern (ohne Makros)
20.08.2005 21:13:18
Ramses
Hallo
vermutlich wird der Zugriff auf die VBA-Module von deinem Virenprogramm als "Angriff" interpretiert.
Update oder Einstellung möglich ?
Gruss Rainer
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige