AW: bestehende VBA-Scribts anpassen
11.08.2004 15:03:01
Jürg
Hallo Nepumuk!!!
sorry dass ich nicht so genau das beschrieben habe . Lege noch die Datei bei wo das bestehnde scribt drinn das angepasst werden muss .. unten ist das von mir verschlimmerte scribt
Option Explicit
Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
Private Const MAX_PATH = 260
Private Const INVALID_HANDLE_VALUE = -1
Private Const FILE_ATTRIBUTE_ARCHIVE = &H20
Private Const FILE_ATTRIBUTE_DIRECTORY = &H10
Private Const FILE_ATTRIBUTE_HIDDEN = &H2
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Const FILE_ATTRIBUTE_READONLY = &H1
Private Const FILE_ATTRIBUTE_SYSTEM = &H4
Private Const FILE_ATTRIBUTE_TEMPORARY = &H100
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Private Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * MAX_PATH
cAlternate As String * 14
End Type
Private lngDirCount As Long
Private lngFileCount As Long
Private strFiles() As String
Public Sub start()
Dim intIndex As Integer, strDateiname As String
Dim myFSO As Object, myDrives As Object, myDrive As Object
lngDirCount = 1
lngFileCount = 0
' ******************* Diesen Teil verwenden, wenn alle Mappen auf allen Laufwerke bearbeitet werden
' Set myFSO = CreateObject("Scripting.FileSystemObject")
' Set myDrives = myFSO.Drives
' For Each myDrive In myDrives
' If myDrive.IsReady Then Call FindFiles(myDrive.DriveLetter & ":\", "*.xls")
' Next
' **************************************************************************************************
' ******************* Diesen Teil verwenden, wenn alle Mappen in einem Ordner bearbeitet werden
Call FindFiles("D:\test\feda", "*.xls")
Print Ersazlaufwerk; zu; ausproieren
'Call FindFiles("X:\Common\Sop\Stammdaten\Fertigungsunterlagen\Fertigungsdaten\", "*.xls")
' **************************************************************************************************
Application.ScreenUpdating = False
For intIndex = 1 To lngFileCount
If strFiles(intIndex) ThisWorkbook.FullName Then
strDateiname = Right(strFiles(intIndex), InStr(1, StrReverse(strFiles(intIndex)), "\") - 1)
On Error Resume Next
Application.ScreenUpdating = False
Workbooks.Open strFiles(intIndex)
Call Teistring_tauschen(strDateiname)
Workbooks(strDateiname).Close SaveChanges:=True
End If
Next
Application.ScreenUpdating = True
MsgBox "Fertig.", 64, "Info"
End Sub
Private Sub FindFiles(ByVal strFolderPath As String, ByVal strSearch As String)
Dim WFD As WIN32_FIND_DATA
Dim lngSearch As Long
Dim strDirName As String
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & "*.*", WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
GetFilesInFolder strFolderPath, strSearch
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) Then
strDirName = TrimNulls(WFD.cFileName)
If (strDirName <> ".") And (strDirName <> "..") Then
lngDirCount = lngDirCount + 1
FindFiles strFolderPath & strDirName, strSearch
End If
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
End Sub
Private Sub GetFilesInFolder(ByVal strFolderPath As String, ByVal strSearch As String)
Dim WFD As WIN32_FIND_DATA
Dim lngSearch As Long
Dim strFileName As String
If Right$(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\"
lngSearch = FindFirstFile(strFolderPath & strSearch, WFD)
If lngSearch <> INVALID_HANDLE_VALUE Then
Do
If (WFD.dwFileAttributes And FILE_ATTRIBUTE_DIRECTORY) <> FILE_ATTRIBUTE_DIRECTORY Then
strFileName = TrimNulls(WFD.cFileName)
lngFileCount = lngFileCount + 1
ReDim Preserve strFiles(1 To lngFileCount)
strFiles(lngFileCount) = strFolderPath & strFileName
End If
Loop While FindNextFile(lngSearch, WFD)
FindClose lngSearch
End If
End Sub
Private Function TrimNulls(ByVal strStringIn As String) As String
If InStr(strStringIn, Chr(0)) > 0 Then strStringIn = Left$(strStringIn, InStr(strStringIn, Chr(0)) - 1)
TrimNulls = strStringIn
End Function
Private Sub Teistring_tauschen(strDateiname As String)
Dim objVBC As Object, intLine As Integer, strFront As String, strBack As String
For Each objVBC In Workbooks(strDateiname).VBProject.VBComponents
With objVBC.CodeModule
For intLine = 1 To .CountOfLines
If InStr(1, .Lines(intLine, 1), "S:\sop\STAMMDATEN\FERTIGUNGSUNTERLAGEN\FERTIGUNGSDATEN\" & Filename & ".XLS") <> 0 Then
' Direktory ab bestehndem FEDA-Test hineinkopiert
strFront = Left$(.Lines(intLine, 1), InStr(1, .Lines(intLine, 1), "S:\sop\STAMMDATEN\FERTIGUNGSUNTERLAGEN\FERTIGUNGSDATEN\" & Filename & ".XLS") - 1)
strBack = Mid$(.Lines(intLine, 1), InStr(1, .Lines(intLine, 1), "S:\sop\STAMMDATEN\FERTIGUNGSUNTERLAGEN\FERTIGUNGSDATEN\" & Filename & ".XLS") + 75)
.DeleteLines intLine
.InsertLines intLine, strFront & "X:\Common\Sop\Stammdaten\Fertigungsunterlagen\Fertigungsdaten\" & Filename & ".XLS" & strBack
' NEUE Laufwerksbezeichnung mit file
End If
Next
End With
Next
End Sub
vielen Dank für deine Hilfe
Gruss
Jürg
Link zu bearbitende datei: https://www.herber.de/bbs/user/9517.xls