Harte Nuss / speichern ohne makros
26.03.2007 12:48:00
Swen
Hallo ich möchte eigentlich nur das alles sichtbaren Tabellenblätter in einem neuen workbook ohne die makros abgespeichert wreden leider funktioniert das nicht!
Hat jemand eine idee warum?
hier ist mein code ( den habe ich auch aus dem forum und habe ihn ein wenig um gebaut!
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" Alias _
"SHGetPathFromIDList" (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
On Error GoTo Fehler
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
Exit Function
Fehler:
Call ModulVarDek.Fehler_routine(strProzedurNameInklModul, Err.Number, Err.Description)
End Function
Private Function BrowseCallback(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, _
ByVal lParam As Long) As Long
On Error GoTo Fehler
If uMsg = BFFM_INITIALIZED Then
Call SendMessage(hwnd, BFFM_SETSELECTION, ByVal 1&, ByVal s_BrowseInitDir)
Call prcCenterDialog(hwnd)
End If
BrowseCallback = 0
Exit Function
Fehler:
Call ModulVarDek.Fehler_routine(strProzedurNameInklModul, Err.Number, Err.Description)
End Function
Private Function FncCallback(ByVal nParam As Long) As Long
On Error GoTo Fehler
FncCallback = nParam
Exit Function
Fehler:
Call ModulVarDek.Fehler_routine(strProzedurNameInklModul, Err.Number, Err.Description)
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
On Error GoTo Fehler
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
Exit Sub
Fehler:
Call ModulVarDek.Fehler_routine(strProzedurNameInklModul, Err.Number, Err.Description)
End Sub
Public Sub speichern_ohne_Makros()
On Error GoTo Fehler
Dim strName As String
Dim Anwendung As Integer
Dim strFolder As String, strFilename As String, strFilename2 As String
Dim objVBC As Object, objSheet As Worksheet
strFolder = Trim$(fncGetFolder())
If strFolder "" Then
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
If Right$(strFolder, 1) "\" Then strFolder = strFolder & "\"
strFilename = Worksheets("Coordinates").Cells(1, 7) & "a_" & _
Worksheets("Coordinates").Cells(1, 1).text & ".xls"
strFilename = Replace(Left(strFilename, 1), "P", "V") & Mid(strFilename, 2, 255)
'******* Anweisung für die Prozedur und Warnung *******'
strName = strFilename
'***** Sprache wird festgelegt *****'
Dim strTextSprache1 As String
Dim strTextSprache2 As String
Dim strTextsprache3 As String
Dim strTextsprache4 As String
Dim strTextsprache5 As String
Dim strUeberschrift As String
strTextSprache1 = Worksheets("Sprache").Cells(115, intSpracheValue).Value
strTextSprache2 = Worksheets("Sprache").Cells(116, intSpracheValue).Value
strTextsprache3 = Worksheets("Sprache").Cells(117, intSpracheValue).Value
strTextsprache4 = Worksheets("Sprache").Cells(118, intSpracheValue).Value
strTextsprache5 = Worksheets("Sprache").Cells(119, intSpracheValue).Value
strUeberschrift = Worksheets("Sprache").Cells(124, intSpracheValue).Value
'*** Hier wird eine Abfrage gestartet ob wirklich abgespeichert werden soll und das
'*** gleichnamige Datein gelöscht werden sollen (Dieses kann man in den Optionen aber _
ausschalten dann
'*** wird ohne abfrage gespeichert und gegebenfalls überschrieben)
If Worksheets(strUserOptionen).Cells(4, 2) = False Then
Anwendung = MsgBox(strTextSprache1 & Chr(13) & Chr(13) _
& strTextSprache2 & _
Chr(13) & Chr(13) & "' " & strName & " '" & Chr(13) & Chr(13) & _
strTextsprache3 & Chr(13) & Chr(13) & strFolder & Chr(13) & Chr(13) _
& strTextsprache4 & Chr(13) & Chr(13) & _
strTextsprache5, _
vbYesNo + vbInformation, strUeberschrift)
Else
Anwendung = 6
End If
'*** Ab hier wird abgespeichert und überschrieben '
If Anwendung = 6 Then
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
With Workbooks(strFilename)
For Each objSheet In .Worksheets
If objSheet.Visible = xlSheetVeryHidden Then
objSheet.Visible = xlSheetVisible
objSheet.Delete
End If
Next
.BuiltinDocumentProperties(1) = Worksheets("Coordinates") _
.Cells(1, 7).Value & " - " & Worksheets("Coordinates") _
.Cells(1, 1).Value
.BuiltinDocumentProperties(18) = "fpc-documentation - needle layout"
.BuiltinDocumentProperties(3) = Worksheets("Coordinates") _
.Cells(5, 3).Value
.BuiltinDocumentProperties(4) = Worksheets("Coordinates") _
.Cells(3, 4).Value
.BuiltinDocumentProperties(5) = "design by PTR2"
.BuiltinDocumentProperties(7) = Worksheets("Coordinates") _
.Cells(5, 3).Value
.BuiltinDocumentProperties(21) = "NXP-Semiconductors , TCH"
.BuiltinDocumentProperties(10) = Date
.BuiltinDocumentProperties(11) = Date
.BuiltinDocumentProperties(12) = Date
.Close savechanges:=True
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
End If
End If
Exit Sub
Fehler:
Call ModulVarDek.Fehler_routine(strProzedurNameInklModul, Err.Number, Err.Description)
End Sub
gruß
swen