Nicht richtig nachvollziehbar....
06.09.2008 10:41:00
Ramses
Hallo
Für den Fragesteller, gib dies im VB-Editor im Direktfenster ein und schliesse die Eingabe mit "Enter" ab
Füge diesen Code in ein Modul deiner Mappe ein und lass den Code laufen
Sub Kill_WB()
Dim wkb As Workbook
Dim killWkb As String
Dim usn As String
killWkb = "0_Start-Menü.xls"
usn = Environ("Username")
On Error GoTo myErrHandler
For Each wkb In Application.Workbooks
If wkb.Name = killWkb Then
wkb.Close
Kill "C:\Dokumente und Einstellungen\" & usn & "\Anwendungsdaten\Microsoft\Excel\XLSTART\0_Start-Menü.xls"
MsgBox "Erfolgreich enfernt"
Exit Sub
End If
Next
Kill "C:\Dokumente und Einstellungen\" & usn & "\Anwendungsdaten\Microsoft\Excel\XLSTART\0_Start-Menü.xls"
MsgBox "Erfolgreich enfernt"
ErrorExit:
Exit Sub
myErrHandler:
MsgBox "Datei konnte nicht erfolgreich entfernt werden." & Chr$(10) & "Fehler: " & Err.Number & Chr(10) & Err.Description
Resume ErrorExit
End Sub
"...und schauen was der code so macht..."
DAS würde mich auch interessieren was hinter diesem Chaos ursprünglich steckte.
Für unbedarfte Excel-User ist das schon ein "kleiner Virus" :-)
Für alle die sich das runterladen nicht antun wollen, hier der implementierte Code
Option Explicit
Private Sub Workbook_Open()
' Application.ScreenUpdating = False
Sheets("Eingang").Select
'--------------------------------------------
'Dim usn As String
' Environ("Username")
' usn = Application.UserName 'Excelanwender
' usn = Environ("Username") 'Netzwerkanwender
' If Wer <> "" Then
' MsgBox "Anwender: " & usn & " vorhanden "
'If Wer = "walbuhl" Then
'MsgBox "Jetzt kommt Walters-Makro " 'jetzt Makro für Herrn Buhl
'Application.Environ("Username") = usn
Dim usn As String
'-- für Viste: "C:\Users\" & usn & "\AppData\Roaming\Microsoft\Excel\XLSTART"
usn = Environ("Username") 'Netzwerkanwender
' der Pfad gilt aber nur für XP, bei Vista ist der Pfad anders:
' "C:\Users\" & usn & "\AppData\Roaming\Microsoft\Excel\XLSTART"
MsgBox "Anwender: " & usn & " vorhanden "
' ActiveWorkbook.SaveAs Filename:= _
"C:\Users\" & usn & "\AppData\Roaming\Microsoft\Excel\XLSTART\0_Start-Menü.xls """ _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'ActiveWorkbook.SaveAs Filename:= _
Environ("%Appdata%") & "\Microsoft\Excel\XLSTART\0_Start-Menü.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
' ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\" & usn & "\Application Data\Microsoft\Excel\XLSTART\0_Start-Menü.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
'Dokumente und Einstellungen
'C:\Dokumente und Einstellungen\wb\Anwendungsdaten\Microsoft\Excel\XLStart
Application.DisplayAlerts = False 'mit False wird Meldung unterdrückt
ActiveWorkbook.SaveAs Filename:= _
"C:\Dokumente und Einstellungen\" & usn & "\Anwendungsdaten\Microsoft\Excel\XLSTART\0_Start-Menü.xls" _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
' Exit Sub
UFStarten.Show
'---- ab hier ICON erstellt ---------------
Dim wsh As Object
Dim tarLink As Object
Dim tarDeskTop As String
Set wsh = CreateObject("WScript.Shell")
tarDeskTop = wsh.SpecialFolders("Desktop")
Set tarLink = wsh.CreateShortcut(tarDeskTop & _
"\" & ThisWorkbook.Name & ".lnk")
With tarLink
.Targetpath = ThisWorkbook.FullName
.Save
End With
Set wsh = Nothing
'------------------------------------------
Application.ScreenUpdating = True
End Sub
Das ist der Code in der UF
Option Explicit
Private Declare Function GetDeviceCaps Lib "gdi32.dll" ( _
ByVal hdc As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetSystemMenu Lib "user32.dll" ( _
ByVal hWnd As Long, _
ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32.dll" ( _
ByVal hMenu As Long, _
ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Const SC_MOVE As Long = &HF010&
Private Const MF_BYCOMMAND As Long = &H0&
Private Const HORZRES = 8&
Private Const VERTRES = 10&
Private Const GC_CLASSNAMEMSEXCELFORM = "ThunderDFrame"
'---- 0_VF-Lauf+Abge-RR-2008.xls HOLEN ----------
Private Sub CommandButton1_Click()
'------------- Excel Dateimanager --------------
Dim strDatei
ChDrive "C:\"
ChDir "C:\"
strDatei = Application.GetOpenFilename("Microsoft Excel-Dateien ,*.*")
If strDatei = False Then Exit Sub
Workbooks.Open strDatei
End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
If CloseMode = vbFormControlMenu Then
Cancel = True
MsgBox "Sie können so nicht Beenden! " _
& Chr(13) & Chr(13) & "Bitte drücken Sie " _
& Chr(13) & Chr(13) & "Schließen - Button ! ", vbInformation, " Hinweis !"
End If
End Sub
'Private Sub UserForm_Click()
Private Sub UserForm_Initialize()
'--------------- für die Bildschirmanpassung ----------------------------------
Dim hwndForm As Long
Dim hwndMenu As Long
Dim intY As Integer
Dim intLast As Integer
Dim intNext As Integer
Dim UserForm
' On Error Resume Next
'----------------------------------------------
'Dim UserForm
'--------------- für Bildschirmanpassung ------
With Me
.StartUpPosition = 0
.Top = 0
.Left = 0
.Height = GetDeviceCaps(GetDC(0&), HORZRES)
.Width = GetDeviceCaps(GetDC(0&), VERTRES)
End With
ReleaseDC 0, GetDC(0&)
hwndForm = FindWindow(GC_CLASSNAMEMSEXCELFORM, Me.Caption)
If hwndForm <> 0 Then
hwndMenu = GetSystemMenu(hwndForm, 0)
If hwndMenu <> 0 Then DeleteMenu hwndMenu, SC_MOVE, MF_BYCOMMAND
End If
Sheets("Eingang").Select
' ActiveSheet.Unprotect (getStrPasswort)
ActiveWindow.ScrollRow = 1 '8 Zeile
ActiveWindow.ScrollColumn = 1 '2 Spalte
Range("A1").Select
End Sub
Private Sub CommandButton3_Click()
Unload Me
ActiveWindow.ScrollRow = 1 '8 Zeile
ActiveWindow.ScrollColumn = 1 '2 Spalte
Range("A1").Select
End Sub
Gruss Rainer