Datei speichern und auf Desktop

02/02/2010 - 08:03 von RogHB346 | Report spam
Hallo Newsgroup

Kann man, wenn mehrere Dateien in Excel geöffnet sind
ein Makro so einrichten, das nach einer Auswahl
diese Datei, dann gespeichert und gleichzeitig auf dem Desktop abgelegt
wird.

Kann evtl. mir einer dieses Makro erstellen ?
MfG - Heinz
Zum guten Glück gibt es keine blöden Fragen. Entweder weiß man nach
deren Beantwortung mehr oder man ist im Wissen stehen geblieben.
Anfànger in Excel - Nobodys perfekt (VBA Progm. Excel 2007)
 

Lesen sie die antworten

#1 Andreas Killer
02/02/2010 - 10:07 | Warnen spam
On 2 Feb., 08:03, RogHB346 wrote:

Kann man, wenn mehrere Dateien in  Excel geöffnet sind
ein Makro so einrichten, das nach einer Auswahl
diese Datei, dann gespeichert und gleichzeitig auf dem Desktop abgelegt
wird.


Klar kann man.

Kann evtl. mir einer dieses Makro erstellen ?


Ach, das auch noch? ;-)))

Der Code gehört in eine Userform die eine ListBox (ListBox1) und zwei
Commandbutton (Commandbutton1, Commandbutton2) hat.

Was noch zu erörtern wàre:
Sollen ausgeblendete Dateien auch angezeigt werden?
Soll die Datei in der das Makro làuft auch angezeigt werden?
Diese beiden Fàlle habe ich schon mal vorsorglich im
UserForm_Initialize-Ereignis berücksichtigt, kannst Du nach belieben
auskommentieren.

Andreas.

Option Explicit

'Trick17 um im Initialize-Ereignis "Unload Me" sagen zu können
Private UnloadMe As Boolean

Private Type SHITEMID
cb As Long
abID As Byte
End Type

Private Type ITEMIDLIST
mkid As SHITEMID
End Type

Private Declare Function SHGetFolderPath Lib "shfolder" Alias _
"SHGetFolderPathA" (ByVal hwndOwner As Long, ByVal nFolder _
As Long, ByVal hToken As Long, ByVal dwFlags As Long, ByVal _
pszPath As String) As Long
Private Declare Function SHGetSpecialFolderLocation Lib _
"Shell32" (ByVal hwndOwner As Long, ByVal nFolder As Long, _
ByRef ppidl As ITEMIDLIST) As Long
Private Declare Function SHGetPathFromIDList Lib "Shell32" ( _
ByVal pidList As Long, ByVal lpBuffer As String) As Long

Private Declare Function LoadLibrary Lib "kernel32" Alias _
"LoadLibraryA" (ByVal lpLibFileName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal _
hLibModule As Long) As Long

Public Enum ShellSpecialFolderConstants
ssfDESKTOP = &H0
ssfPROGRAMS = &H2
ssfPERSONAL = &H5
ssfFAVORITES = &H6
ssfSTARTUP = &H7
ssfRECENT = &H8
ssfSENDTO = &H9
ssfSTARTMENU = &HB
ssfMYMUSIC = &HD
ssfDESKTOPDIRECTORY = &H10
ssfNETHOOD = &H13
ssfFONTS = &H14
ssfTEMPLATES = &H15
ssfCOMMONSTARTMENU = &H16
ssfCOMMONPROGRAMS = &H17
ssfCOMMONSTARTUP = &H18
ssfCOMMONDESKTOPDIRECTORY = &H19
ssfAPPDATA = &H1A
ssfPRINTHOOD = &H1B
ssfLOCALAPPDATA = &H1C
ssfALTSTARTUP = &H1D
ssfCOMMONALTSTARTUP = &H1E
ssfCOMMONFAVORITES = &H1F
ssfINTERNET_CACHE = &H20
ssfCOOKIES = &H21
ssfHISTORY = &H22
ssfCOMMONAPPDATA = &H23
ssfWINDOWS = &H24
ssfSYSTEM = &H25
ssfPROGRAMFILES = &H26
ssfMYPICTURES = &H27
ssfPROFILE = &H28
ssfPROGRAMFILESCOMMON = &H2B
ssfCOMMONTEMPLATES = &H2D
ssfCOMMONDOCUMENTS = &H2E
ssfCOMMONADMINTOOLS = &H2F
ssfADMINTOOLS = &H30
ssfCOMMONMUSIC = &H35
ssfCOMMONPICTURES = &H36
ssfCOMMONVIDEO = &H37
ssfRESOURCES = &H38
ssfRESOURCESLOCALIZED = &H39
ssfCDBURNAREA = &H3B
End Enum

Private Function GetSpecialFolder( _
ByVal Folder As ShellSpecialFolderConstants, _
Optional ByVal ForceCreate As Boolean) As String
'http://www.vb-hellfire.de/knowlib/s...folder.php
Const S_OK = 0
Const MAX_PATH = 260
Const CSIDL_FLAG_CREATE = &H8000&
Dim tIIDL As ITEMIDLIST
Dim strPath As String
Dim hMod As Long

If ForceCreate Then Folder = Folder Or CSIDL_FLAG_CREATE

If SHGetSpecialFolderLocation(0, Folder, tIIDL) = S_OK Then
strPath = Space$(MAX_PATH)
If SHGetPathFromIDList(tIIDL.mkid.cb, strPath) <> 0 Then
GetSpecialFolder = Left$(strPath, InStr(1, strPath, _
vbNullChar) - 1)
End If
Else
strPath = Space$(MAX_PATH)
hMod = LoadLibrary("shfolder")
If (hMod <> 0) Then
If SHGetFolderPath(0, Folder, 0, 0, strPath) = S_OK Then
GetSpecialFolder = Left$(strPath, InStr(1, strPath, _
vbNullChar) - 1)
End If
FreeLibrary hMod
End If
End If
End Function

Private Sub CommandButton1_Click()
'Ok geklickt
Dim WB As Workbook, fs As Object
With ListBox1
'Wurde mind. ein Eintrag ausgewàhlt?
If .ListIndex < 0 Then Exit Sub
'Ja, Mappe ggf. speichern
Set WB = Workbooks(.List(.ListIndex))
If Not WB.Saved Then WB.Save
'Kopie auf den Desktop
If WB.Saved Then WB.SaveCopyAs GetSpecialFolder(ssfDESKTOP, _
False) & "\" & WB.Name
End With
Unload Me
End Sub

Private Sub CommandButton2_Click()
'Abbruch geklickt
Unload Me
End Sub

Private Sub UserForm_Activate()
'Schließt uns ggf.
If UnloadMe Then Unload Me
End Sub

Private Sub UserForm_Initialize()
Dim WB As Workbook, Ok As Boolean
With Me
'Der Einfachheit halber:
.Caption = "Mappe für Kopie auf Desktop auswàhlen:"
With .CommandButton1
.Default = True
.Caption = "Speichern"
End With
With .CommandButton2
.Cancel = True
.Caption = "Abbruch"
End With

'Alle Mappen prüfen
For Each WB In Workbooks
Ok = True
'Diese Mappe auch?
Ok = Ok And WB.Name <> ThisWorkbook.Name
'Nur sichtbare Mappen?
Ok = Ok And WB.Windows(1).Visible
'Hinzufügen?
If Ok Then .ListBox1.AddItem WB.Name
Next
If .ListBox1.ListCount = 0 Then
'Keine Mappen gefunden
UnloadMe = True
End If
End With
End Sub

Ähnliche fragen