J'ai le code suivant qui fonctionne tres bien sous excel
J'aimerais savoir comment le faire tourner en vbs
Merci par avance
Private Sub Workbook_Open()
Application.OnTime Now + TimeValue("00:00:5"), "Quitter"
Chemin = "J:\sesame\remontees_standard\CE\mode_auto\*.txt"
Fich = Dir(Chemin)
SuiteFich:
NFich = "J:\sesame\remontees_standard\CE\mode_auto" & Fich
NFich1 = "J:\sesame\remontees_standard\CE\mode_auto" & Fich & "1"
DateFich = Mid(Fich, Len(Fich) - 18, Len(Fich) - 4)
Open NFich For Input As #1
Open NFich1 For Output As #2
Do While Not EOF(1)
Line Input #1, ligne
rem Remplacement des Noms Gex AutoIf Left(ligne, 7) "NOM_GEX" And (ligne Like "*1146797_ILOTA_MAUS1X*") Then ligne "NOM_GEX, 1146797_ILOTA_MAUS1XXX9P"If Left(ligne, 7) "NOM_GEX" And (ligne Like "*1146798_ILOTB_MAUS1X*") Then ligne "NOM_GEX, 1146798_ILOTB_MAUS1XXX9P"
If Left(ligne, 7) "NOM_GEX" And (ligne Like "*1146797_ilota_maus1x*") Then ligne "NOM_GEX, 1146797_ilota_maus1xxx9p"If Left(ligne, 7) "NOM_GEX" And (ligne Like "*1146798_ilotb_maus1x*") Then ligne "NOM_GEX, 1146798_ilotb_maus1xxx9p"
If Left(ligne, 8) "CODE_FON" And (ligne Like "*MS*") Then ligne "CODE_FON, MP"
If Left(ligne, 8) "CODE_FON" And (ligne Like "*ms*") Then ligne "CODE_FON, mp"
If Left(ligne, 7) "CRE_VER" And (ligne Like "**") Then ligne "CRE_VER, N"
If Left(ligne, 9) "NOM_GAMME" And (ligne Like "*maus_xxxxxxx_ms_ce_xxxxx*") Then ligne "NOM_GAMME, maus_xxxxxxx_mp_ce_xxxxx"If Left(ligne, 9) "NOM_GAMME" And (ligne Like "*MAUS_XXXXXXX_MS_CE_XXXXX*") Then ligne "NOM_GAMME, MAUS_XXXXXXX_MP_CE_XXXXX"
Print #2, ligne
Loop
Close #1
Close #2
Fich = Dir
If Fich <> "" Then GoTo SuiteFich
MsgBox ShowFolderList("J:\sesame\remontees_standard\CE\mode_auto"),vbInformation,"Copie de Fichiers"
Function ShowFolderList(strPath) Const ForReading 1, ForWriting 2
Dim objFso, colFile, objTextStream, objTextFile
Dim strLine, imax, strListe
Set objFso = CreateObject("Scripting.FileSystemObject")
imax = 0
For Each colFile in objFso.GetFolder(strPath).Files
If LCase(objFso.GetExtensionName(colFile)) = "txt" Then
ReDim arrLines(0)
Set objTextStream = objFso.OpenTextFile(colFile, ForReading)
Do While Not objTextStream.AtEndOfStream
strLine = objTextStream.ReadLine
Select Case Left(strLine, 7)
Case "NOM_GEX"
If InStr(1, strLine, "1146797_ILOTA_MAUS1X") Then
Call WriteTab("NOM_GEX, 1146797_ILOTA_MAUS1XXX9P", arrLines)
ElseIf InStr(1, strLine, "1146798_ILOTB_MAUS1X") Then
Call WriteTab("NOM_GEX, 1146798_ILOTB_MAUS1XXX9P", arrLines)
ElseIf InStr(1, strLine, "1146797_ilota_maus1x") Then
Call WriteTab("NOM_GEX, 1146797_ilota_maus1xxx9p", arrLines)
ElseIf InStr(1, strLine, "1146798_ilotb_maus1xxx9p") Then
Call WriteTab("NOM_GEX, 1146798_ilotb_maus1xxx9p", arrLines)
End If
Case "CODE_FO"
If InStr(1, strLine, "MS") Then
Call WriteTab("CODE_FON, MP", arrLines)
ElseIf InStr(1, strLine, "ms") Then
Call WriteTab("CODE_FON, mp", arrLines)
End If
Case "CRE_VER"
If InStr(1, strLine, "**") Then
Call WriteTab("CRE_VER, N", arrLines)
End If
Case "NOM_GAM"
If InStr(1, strLine, "MAUS_XXXXXXX_MS_CE_XXXXX") Then
Call WriteTab("NOM_GAMME, MAUS_XXXXXXX_MP_CE_XXXXX", arrLines)
ElseIf InStr(1, strLine, "maus_xxxxxxx_ms_ce_xxxxx") Then
Call WriteTab("NOM_GAMME, maus_xxxxxxx_mp_ce_xxxxx", arrLines)
End If
End Select
Loop
objTextStream.Close
'Ecriture dans nouveau fichier
If Ubound(arrLines) <> 0 Then
colFile = objFso.GetParentFolderName(colFile) & "" & _
objFso.GetBaseName(colFile) & "_new." & _
objFso.GetExtensionName(colFile)
strListe = strListe &vbcrlf& colFile
Set objTextFile = objFso.CreateTextFile(colFile, ForWriting)
Dim i
For i = 0 to Ubound(arrLines)-1
objTextFile.Write arrLines(i) &vbCrLf
Next
objTextFile.Close
End If
End if
Next
ShowFolderList = "Fichiers créés" &vbCrLf&vbCrLf& strListe
Set objTextStream = Nothing
Set objTextFile = Nothing
Set objFso = Nothing
End Function
Function WriteTab(strLine, arrLines)
arrLines(UBound(arrLines)) = strLine
ReDim Preserve arrLines(UBound(arrLines) + 1)
End Function
J'ai essaye le code mais comment faire pour qu'il reprenne la totalite du fichier
txt existant en changeant les lignes que je veux et le renommer en txt1
Quelques ajouts de Call WriteTab(strLine, arrLines) et :
Select Case Left(strLine, 7)
Case "NOM_GEX"
If InStr(1, strLine, "1146797_ILOTA_MAUS1X") Then
Call WriteTab("NOM_GEX, 1146797_ILOTA_MAUS1XXX9P", arrLines)
ElseIf InStr(1, strLine, "1146798_ILOTB_MAUS1X") Then
Call WriteTab("NOM_GEX, 1146798_ILOTB_MAUS1XXX9P", arrLines)
ElseIf InStr(1, strLine, "1146797_ilota_maus1x") Then
Call WriteTab("NOM_GEX, 1146797_ilota_maus1xxx9p", arrLines)
ElseIf InStr(1, strLine, "1146798_ilotb_maus1xxx9p") Then
Call WriteTab("NOM_GEX, 1146798_ilotb_maus1xxx9p", arrLines)
Else
Call WriteTab(strLine, arrLines)
End If
Case "CODE_FO"
If InStr(1, strLine, "MS") Then
Call WriteTab("CODE_FON, MP", arrLines)
ElseIf InStr(1, strLine, "ms") Then
Call WriteTab("CODE_FON, mp", arrLines)
Else
Call WriteTab(strLine, arrLines)
End If
Case "CRE_VER"
If InStr(1, strLine, "**") Then
Call WriteTab("CRE_VER, N", arrLines)
Else
Call WriteTab(strLine, arrLines)
End If
Case "NOM_GAM"
If InStr(1, strLine, "MAUS_XXXXXXX_MS_CE_XXXXX") Then
Call WriteTab("NOM_GAMME, MAUS_XXXXXXX_MP_CE_XXXXX", arrLines)
ElseIf InStr(1, strLine, "maus_xxxxxxx_ms_ce_xxxxx") Then
Call WriteTab("NOM_GAMME, maus_xxxxxxx_mp_ce_xxxxx", arrLines)
Else
Call WriteTab(strLine, arrLines)
End If
Case Else
Call WriteTab(strLine, arrLines)
End Select
