AW: Makro öffnet immer die alte Mappe
Matthias
so hier noch einmal mein code. Vielleicht kannst du ja noch etwas finden.
Option Explicit
Type myBreite
rechts As Boolean
breite As Integer
End Type
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Sub WriteMeNeu(fname As String)
Dim breiten() As myBreite
Dim spalten As Integer
Dim i As Long, j As Integer
Dim vlen As Integer
Dim v As String
spalten = Cells(1, Cells.Columns.Count).End(xlToLeft).Column
ReDim breiten(spalten)
For i = 1 To spalten
breiten(i).rechts = UCase(Right(Cells(1, i).Value, 1)) = "R"
breiten(i).breite = CInt(Val(Cells(1, i).Value))
Next
Open fname For Output As #1
For i = 2 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
For j = 1 To spalten
v = CStr(Cells(i, j).Value)
vlen = Len(v)
If vlen > breiten(j).breite Then v = Left(v, breiten(j).breite)
If breiten(j).rechts Then
Print #1, Spc(breiten(j).breite - vlen); v;
Else
Print #1, v; Spc(breiten(j).breite - vlen);
End If
Next j
Print #1, ""
Next i
Close #1
End Sub
Sub Stuelikomplett()
Worksheets(2).Activate
'Hier wird die Verknüpfung aktualisiert
ActiveWorkbook.UpdateLink Name:="\\Server5\Konstruktion\Lagermappe2.xls", Type:=xlExcelLinks
'Hier wird die Schnittstellendatei für Infra Erzeugt
Worksheets(3).Activate
Dim msg As String
'msg = "Wählen Sie bitte einen Ordner aus:"
'MsgBox getdirectory(msg)
MsgBox "Name des InfraTextOrdner: " & ActiveWindow.Caption
'MsgBox "Ist das Verzeichnis das wo es Hingespeichert werden soll? Wenn nicht Abbrechen und die Exceltabelle mit 'Speichern unter' dort abspeichern und dieses Makro erneut ausführen! " & ActiveWorkbook.Path
WriteMeNeu ActiveWorkbook.Path & "\" & ActiveWindow.Caption & ".txt"
Worksheets(2).Activate
ActiveWindow.SelectedSheets.PrintPreview
'WriteMeNeu getdirectory ActiveWindow.Caption & "/.txt"
'WriteMeNeu ActiveWindow.Caption & ".txt"
'WriteMeNeu getdirectory(msg) & ActiveWindow.Caption & ".txt"
'WriteMeNeu getdirectory & "/SSD.txt"
'WriteMeNeu getdirectory
'MsgBox "Ist der Name wo es gespeichert werden soll richtig? " & ActiveWorkbook.Path
'WriteMeNeu getdirectory & "ActiveWindow.Caption"
End Sub
Function getdirectory(Optional msg) As String
Dim bInfo As BROWSEINFO
Dim Path As String
Dim r As Long, x As Long, pos As Integer
' Ausgangsordner = Desktop
'bInfo.pidlRoot = 0&
bInfo.pidlRoot = 0&
' Dialogtitel
If IsMissing(msg) Then
bInfo.lpszTitle = "Wählen Sie bitte einen Ordner aus."
Else
bInfo.lpszTitle = msg
End If
' Rückgabe des Unterverzeichnisses
bInfo.ulFlags = &H1
' Dialog anzeigen
x = SHBrowseForFolder(bInfo)
' Ergebnis gliedern
Path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal Path)
If r Then
pos = InStr(Path, Chr$(0))
getdirectory = Left(Path, pos - 1)
Else
getdirectory = ""
End If
End Function