Plantage sur Get en lecture sur un fichier ouvert en binary
5 réponses
Michel Angelosanto
Bonjour,
je voudrais lire deux octets à une position précise dans un fichier que j'ai
ouvert en binary.
J'obtiens l'erreur:
"erreur d'exécution 458, Cette variable utilise un type automation non géré
par Visual basic"
Savez-vous ce que cela veut dire?
J'ai pu faire tourner le programme une fois depuis j'ai du faire une
modification inadéquate mais je ne trouve pas.
En fait le but de la manouvre est de comparer deux fichiers, peut être avez
vous un exemple tout prêt?
l'extrait du code ou ça plante:
Dim ch as string*2
ch=" "
'F nom du fichier à ouvrir
Open F For Binary As #1
seek #1,100 'on va à la position 100 dans le fichier
Get #1, , ch 'on lit 2 octets que l'on place dans ch (idem avec une
variable integer)
...
Close #1
merci pour votre aide.
--
Michel Angelosanto, Bordeaux
http://angelosa.free.fr/
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
MichDenis
Je n'ai aucune erreur dans cette procédure :
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
"Michel Angelosanto" a écrit dans le message de news:
Bonjour,
je voudrais lire deux octets à une position précise dans un fichier que j'ai ouvert en binary. J'obtiens l'erreur: "erreur d'exécution 458, Cette variable utilise un type automation non géré par Visual basic"
Savez-vous ce que cela veut dire? J'ai pu faire tourner le programme une fois depuis j'ai du faire une modification inadéquate mais je ne trouve pas. En fait le but de la manouvre est de comparer deux fichiers, peut être avez vous un exemple tout prêt?
l'extrait du code ou ça plante: Dim ch as string*2 ch=" " 'F nom du fichier à ouvrir Open F For Binary As #1 seek #1,100 'on va à la position 100 dans le fichier Get #1, , ch 'on lit 2 octets que l'on place dans ch (idem avec une variable integer) ... Close #1
merci pour votre aide. -- Michel Angelosanto, Bordeaux http://angelosa.free.fr/
Je n'ai aucune erreur dans cette procédure :
Sub test()
Dim ch As String * 2
ch = " "
F = "c:atravailtest.txt"
Open F For Binary As #1
Seek #1, 100
Get #1, , ch
Close #1
MsgBox ch
End Sub
"Michel Angelosanto" <angelosa@free.fr> a écrit dans le message de news:
e2o3olDYIHA.3400@TK2MSFTNGP03.phx.gbl...
Bonjour,
je voudrais lire deux octets à une position précise dans un fichier que j'ai
ouvert en binary.
J'obtiens l'erreur:
"erreur d'exécution 458, Cette variable utilise un type automation non géré
par Visual basic"
Savez-vous ce que cela veut dire?
J'ai pu faire tourner le programme une fois depuis j'ai du faire une
modification inadéquate mais je ne trouve pas.
En fait le but de la manouvre est de comparer deux fichiers, peut être avez
vous un exemple tout prêt?
l'extrait du code ou ça plante:
Dim ch as string*2
ch=" "
'F nom du fichier à ouvrir
Open F For Binary As #1
seek #1,100 'on va à la position 100 dans le fichier
Get #1, , ch 'on lit 2 octets que l'on place dans ch (idem avec une
variable integer)
...
Close #1
merci pour votre aide.
--
Michel Angelosanto, Bordeaux
http://angelosa.free.fr/
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
"Michel Angelosanto" a écrit dans le message de news:
Bonjour,
je voudrais lire deux octets à une position précise dans un fichier que j'ai ouvert en binary. J'obtiens l'erreur: "erreur d'exécution 458, Cette variable utilise un type automation non géré par Visual basic"
Savez-vous ce que cela veut dire? J'ai pu faire tourner le programme une fois depuis j'ai du faire une modification inadéquate mais je ne trouve pas. En fait le but de la manouvre est de comparer deux fichiers, peut être avez vous un exemple tout prêt?
l'extrait du code ou ça plante: Dim ch as string*2 ch=" " 'F nom du fichier à ouvrir Open F For Binary As #1 seek #1,100 'on va à la position 100 dans le fichier Get #1, , ch 'on lit 2 octets que l'on place dans ch (idem avec une variable integer) ... Close #1
merci pour votre aide. -- Michel Angelosanto, Bordeaux http://angelosa.free.fr/
MichDenis
As-tu essayé en utilisant FreeFile
Sub Test() Dim ch As String * 2 ch = " " No = FreeFile F = "c:atravailtest.txt" Open F For Binary As No Seek No, 100 Get No, , ch Close No1 MsgBox ch End Sub
"MichDenis" a écrit dans le message de news:
Je n'ai aucune erreur dans cette procédure :
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
"Michel Angelosanto" a écrit dans le message de news:
Bonjour,
je voudrais lire deux octets à une position précise dans un fichier que j'ai ouvert en binary. J'obtiens l'erreur: "erreur d'exécution 458, Cette variable utilise un type automation non géré par Visual basic"
Savez-vous ce que cela veut dire? J'ai pu faire tourner le programme une fois depuis j'ai du faire une modification inadéquate mais je ne trouve pas. En fait le but de la manouvre est de comparer deux fichiers, peut être avez vous un exemple tout prêt?
l'extrait du code ou ça plante: Dim ch as string*2 ch=" " 'F nom du fichier à ouvrir Open F For Binary As #1 seek #1,100 'on va à la position 100 dans le fichier Get #1, , ch 'on lit 2 octets que l'on place dans ch (idem avec une variable integer) ... Close #1
merci pour votre aide. -- Michel Angelosanto, Bordeaux http://angelosa.free.fr/
As-tu essayé en utilisant FreeFile
Sub Test()
Dim ch As String * 2
ch = " "
No = FreeFile
F = "c:atravailtest.txt"
Open F For Binary As No
Seek No, 100
Get No, , ch
Close No1
MsgBox ch
End Sub
"MichDenis" <michdenis@hotmail.com> a écrit dans le message de news:
OK0zhsDYIHA.1208@TK2MSFTNGP05.phx.gbl...
Je n'ai aucune erreur dans cette procédure :
Sub test()
Dim ch As String * 2
ch = " "
F = "c:atravailtest.txt"
Open F For Binary As #1
Seek #1, 100
Get #1, , ch
Close #1
MsgBox ch
End Sub
"Michel Angelosanto" <angelosa@free.fr> a écrit dans le message de news:
e2o3olDYIHA.3400@TK2MSFTNGP03.phx.gbl...
Bonjour,
je voudrais lire deux octets à une position précise dans un fichier que j'ai
ouvert en binary.
J'obtiens l'erreur:
"erreur d'exécution 458, Cette variable utilise un type automation non géré
par Visual basic"
Savez-vous ce que cela veut dire?
J'ai pu faire tourner le programme une fois depuis j'ai du faire une
modification inadéquate mais je ne trouve pas.
En fait le but de la manouvre est de comparer deux fichiers, peut être avez
vous un exemple tout prêt?
l'extrait du code ou ça plante:
Dim ch as string*2
ch=" "
'F nom du fichier à ouvrir
Open F For Binary As #1
seek #1,100 'on va à la position 100 dans le fichier
Get #1, , ch 'on lit 2 octets que l'on place dans ch (idem avec une
variable integer)
...
Close #1
merci pour votre aide.
--
Michel Angelosanto, Bordeaux
http://angelosa.free.fr/
Sub Test() Dim ch As String * 2 ch = " " No = FreeFile F = "c:atravailtest.txt" Open F For Binary As No Seek No, 100 Get No, , ch Close No1 MsgBox ch End Sub
"MichDenis" a écrit dans le message de news:
Je n'ai aucune erreur dans cette procédure :
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
"Michel Angelosanto" a écrit dans le message de news:
Bonjour,
je voudrais lire deux octets à une position précise dans un fichier que j'ai ouvert en binary. J'obtiens l'erreur: "erreur d'exécution 458, Cette variable utilise un type automation non géré par Visual basic"
Savez-vous ce que cela veut dire? J'ai pu faire tourner le programme une fois depuis j'ai du faire une modification inadéquate mais je ne trouve pas. En fait le but de la manouvre est de comparer deux fichiers, peut être avez vous un exemple tout prêt?
l'extrait du code ou ça plante: Dim ch as string*2 ch=" " 'F nom du fichier à ouvrir Open F For Binary As #1 seek #1,100 'on va à la position 100 dans le fichier Get #1, , ch 'on lit 2 octets que l'on place dans ch (idem avec une variable integer) ... Close #1
merci pour votre aide. -- Michel Angelosanto, Bordeaux http://angelosa.free.fr/
Michel Angelosanto
Voici le code complêt car c'est très bizarre je viens de changer la variable en integer et c'est passé une fois et à la 2e fois de nouveau plantage Le but est de supprimer les doublons dans les répertoires jpg1 et jpg1video je fais le test sur les fichiers jpg,avi,mpg,mpeg,wmv J'utilise la feuille courante pour stocker le nom des fichiers en colonne 1 en colonne 2 je stocke un entier lu à une position fixe de chaque fichier puis je trie les 2 colonnes afin d'éviter la comparaison sur les fichiers déja différents sur les 2 octets lus.
Dim t, t1, maxt, maxt1, r2, r3, temp2, temp3, zone, zone1 As Integer 'il doit y avoir des variables inutilisées Dim lg1, lg2 As Double
Sub doubles() aig = 0 extension: aig = aig + 1 Columns("A:B").Select Selection.ClearContents Select Case aig Case 1: ChDir "C:jpg1" ext$ = "*." + "jpg" Case 2: ChDir "C:jpg1video" ext$ = "*." + "mpg" Case 3: ChDir "C:jpg1video" ext$ = "*." + "avi" Case 4: ChDir "C:jpg1video" ext$ = "*." + "wmv" Case Else Exit Sub End Select
t = 1
r$ = Dir$(ext$) If r$ = "" Then GoTo fin: Else Cells(t, 1) = r$ End If 'Lecture repertoire While Cells(t, 1) <> "" t = t + 1 Cells(t, 1) = Dir$ Wend maxt = t - 1
'lecture début fichiers, on met la valeur des 2 premiers octets en colonne 2 For t = 1 To maxt Open Cells(t, 1).Text For Binary As #2 Get #2, 50, r2 Cells(t, 2) = r2 Close #2 Next t 'on trie la liste sur la colonne 2 Range("A1:B" & maxt).Select ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("B1:B" & maxt) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Feuil1").Sort .SetRange Range("A1:B" & maxt) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With
'on supprime les doubles For t = 1 To maxt - 1 If Cells(t, 1) = "" Then t = t + 1 Open Cells(t, 1).Text For Binary As #1 lg = LOF(1) For t1 = 2 To maxt If Cells(t1, 1) = "" Then t1 = t1 + 1 If Cells(t, 2) <> Cells(t1, 2) Then Exit For 'comparaison Seek #1, 1 'on se positionne sur le premier octet Open Cells(t1, 1).Text For Binary As #2 different = 0 If lg < LOF(2) Then lg1 = lg Else lg1 = LOF(2) For t3 = 1 To (lg1 / 2) - 1 Get #1, , zone: Get #2, , zone1 If zone <> zone1 Then different = 1 Exit For End If Next t3 Close #2 If different = 0 Then Kill Cells(t1, 1).Text Cells(t1, 1) = "" End If Next t1 Close #1 Next t GoTo extension:
fin: End Sub
"MichDenis" a écrit dans le message de news:
Je n'ai aucune erreur dans cette procédure :
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
Voici le code complêt car c'est très bizarre je viens de changer la variable
en integer et c'est passé une fois et à la 2e fois de nouveau plantage
Le but est de supprimer les doublons dans les répertoires jpg1 et
jpg1video je fais le test sur les fichiers jpg,avi,mpg,mpeg,wmv
J'utilise la feuille courante pour stocker le nom des fichiers en colonne 1
en colonne 2 je stocke un entier lu à une position fixe de chaque fichier
puis je trie les 2 colonnes afin d'éviter la comparaison sur les fichiers
déja différents sur les 2 octets lus.
Dim t, t1, maxt, maxt1, r2, r3, temp2, temp3, zone, zone1 As Integer 'il
doit y avoir des variables inutilisées
Dim lg1, lg2 As Double
Sub doubles()
aig = 0
extension:
aig = aig + 1
Columns("A:B").Select
Selection.ClearContents
Select Case aig
Case 1:
ChDir "C:jpg1"
ext$ = "*." + "jpg"
Case 2:
ChDir "C:jpg1video"
ext$ = "*." + "mpg"
Case 3:
ChDir "C:jpg1video"
ext$ = "*." + "avi"
Case 4:
ChDir "C:jpg1video"
ext$ = "*." + "wmv"
Case Else
Exit Sub
End Select
t = 1
r$ = Dir$(ext$)
If r$ = "" Then
GoTo fin:
Else
Cells(t, 1) = r$
End If
'Lecture repertoire
While Cells(t, 1) <> ""
t = t + 1
Cells(t, 1) = Dir$
Wend
maxt = t - 1
'lecture début fichiers, on met la valeur des 2 premiers octets en colonne 2
For t = 1 To maxt
Open Cells(t, 1).Text For Binary As #2
Get #2, 50, r2
Cells(t, 2) = r2
Close #2
Next t
'on trie la liste sur la colonne 2
Range("A1:B" & maxt).Select
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("B1:B" &
maxt) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
.SetRange Range("A1:B" & maxt)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'on supprime les doubles
For t = 1 To maxt - 1
If Cells(t, 1) = "" Then t = t + 1
Open Cells(t, 1).Text For Binary As #1
lg = LOF(1)
For t1 = 2 To maxt
If Cells(t1, 1) = "" Then t1 = t1 + 1
If Cells(t, 2) <> Cells(t1, 2) Then Exit For
'comparaison
Seek #1, 1 'on se positionne sur le premier octet
Open Cells(t1, 1).Text For Binary As #2
different = 0
If lg < LOF(2) Then lg1 = lg Else lg1 = LOF(2)
For t3 = 1 To (lg1 / 2) - 1
Get #1, , zone: Get #2, , zone1
If zone <> zone1 Then
different = 1
Exit For
End If
Next t3
Close #2
If different = 0 Then
Kill Cells(t1, 1).Text
Cells(t1, 1) = ""
End If
Next t1
Close #1
Next t
GoTo extension:
fin:
End Sub
"MichDenis" <michdenis@hotmail.com> a écrit dans le message de
news:OK0zhsDYIHA.1208@TK2MSFTNGP05.phx.gbl...
Je n'ai aucune erreur dans cette procédure :
Sub test()
Dim ch As String * 2
ch = " "
F = "c:atravailtest.txt"
Open F For Binary As #1
Seek #1, 100
Get #1, , ch
Close #1
MsgBox ch
End Sub
Voici le code complêt car c'est très bizarre je viens de changer la variable en integer et c'est passé une fois et à la 2e fois de nouveau plantage Le but est de supprimer les doublons dans les répertoires jpg1 et jpg1video je fais le test sur les fichiers jpg,avi,mpg,mpeg,wmv J'utilise la feuille courante pour stocker le nom des fichiers en colonne 1 en colonne 2 je stocke un entier lu à une position fixe de chaque fichier puis je trie les 2 colonnes afin d'éviter la comparaison sur les fichiers déja différents sur les 2 octets lus.
Dim t, t1, maxt, maxt1, r2, r3, temp2, temp3, zone, zone1 As Integer 'il doit y avoir des variables inutilisées Dim lg1, lg2 As Double
Sub doubles() aig = 0 extension: aig = aig + 1 Columns("A:B").Select Selection.ClearContents Select Case aig Case 1: ChDir "C:jpg1" ext$ = "*." + "jpg" Case 2: ChDir "C:jpg1video" ext$ = "*." + "mpg" Case 3: ChDir "C:jpg1video" ext$ = "*." + "avi" Case 4: ChDir "C:jpg1video" ext$ = "*." + "wmv" Case Else Exit Sub End Select
t = 1
r$ = Dir$(ext$) If r$ = "" Then GoTo fin: Else Cells(t, 1) = r$ End If 'Lecture repertoire While Cells(t, 1) <> "" t = t + 1 Cells(t, 1) = Dir$ Wend maxt = t - 1
'lecture début fichiers, on met la valeur des 2 premiers octets en colonne 2 For t = 1 To maxt Open Cells(t, 1).Text For Binary As #2 Get #2, 50, r2 Cells(t, 2) = r2 Close #2 Next t 'on trie la liste sur la colonne 2 Range("A1:B" & maxt).Select ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("B1:B" & maxt) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Feuil1").Sort .SetRange Range("A1:B" & maxt) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With
'on supprime les doubles For t = 1 To maxt - 1 If Cells(t, 1) = "" Then t = t + 1 Open Cells(t, 1).Text For Binary As #1 lg = LOF(1) For t1 = 2 To maxt If Cells(t1, 1) = "" Then t1 = t1 + 1 If Cells(t, 2) <> Cells(t1, 2) Then Exit For 'comparaison Seek #1, 1 'on se positionne sur le premier octet Open Cells(t1, 1).Text For Binary As #2 different = 0 If lg < LOF(2) Then lg1 = lg Else lg1 = LOF(2) For t3 = 1 To (lg1 / 2) - 1 Get #1, , zone: Get #2, , zone1 If zone <> zone1 Then different = 1 Exit For End If Next t3 Close #2 If different = 0 Then Kill Cells(t1, 1).Text Cells(t1, 1) = "" End If Next t1 Close #1 Next t GoTo extension:
fin: End Sub
"MichDenis" a écrit dans le message de news:
Je n'ai aucune erreur dans cette procédure :
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
MichDenis
J'ai fait une petite boucle comme ceci et aucune erreur s'est produite :
Dim No As Long, As Integer Dim ch As String * 2
F = "c:atravailtest.txt"
For a = 1 To 10 ch = " " No = FreeFile Open F For Binary As No Seek No, 2 * a Get No, , ch Close No MsgBox ch Next
Pour ce qui est du reste, je n'ai pas l'environnement pour tester !
"Michel Angelosanto" a écrit dans le message de news:
Voici le code complêt car c'est très bizarre je viens de changer la variable en integer et c'est passé une fois et à la 2e fois de nouveau plantage Le but est de supprimer les doublons dans les répertoires jpg1 et jpg1video je fais le test sur les fichiers jpg,avi,mpg,mpeg,wmv J'utilise la feuille courante pour stocker le nom des fichiers en colonne 1 en colonne 2 je stocke un entier lu à une position fixe de chaque fichier puis je trie les 2 colonnes afin d'éviter la comparaison sur les fichiers déja différents sur les 2 octets lus.
Dim t, t1, maxt, maxt1, r2, r3, temp2, temp3, zone, zone1 As Integer 'il doit y avoir des variables inutilisées Dim lg1, lg2 As Double
Sub doubles() aig = 0 extension: aig = aig + 1 Columns("A:B").Select Selection.ClearContents Select Case aig Case 1: ChDir "C:jpg1" ext$ = "*." + "jpg" Case 2: ChDir "C:jpg1video" ext$ = "*." + "mpg" Case 3: ChDir "C:jpg1video" ext$ = "*." + "avi" Case 4: ChDir "C:jpg1video" ext$ = "*." + "wmv" Case Else Exit Sub End Select
t = 1
r$ = Dir$(ext$) If r$ = "" Then GoTo fin: Else Cells(t, 1) = r$ End If 'Lecture repertoire While Cells(t, 1) <> "" t = t + 1 Cells(t, 1) = Dir$ Wend maxt = t - 1
'lecture début fichiers, on met la valeur des 2 premiers octets en colonne 2 For t = 1 To maxt Open Cells(t, 1).Text For Binary As #2 Get #2, 50, r2 Cells(t, 2) = r2 Close #2 Next t 'on trie la liste sur la colonne 2 Range("A1:B" & maxt).Select ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("B1:B" & maxt) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Feuil1").Sort .SetRange Range("A1:B" & maxt) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With
'on supprime les doubles For t = 1 To maxt - 1 If Cells(t, 1) = "" Then t = t + 1 Open Cells(t, 1).Text For Binary As #1 lg = LOF(1) For t1 = 2 To maxt If Cells(t1, 1) = "" Then t1 = t1 + 1 If Cells(t, 2) <> Cells(t1, 2) Then Exit For 'comparaison Seek #1, 1 'on se positionne sur le premier octet Open Cells(t1, 1).Text For Binary As #2 different = 0 If lg < LOF(2) Then lg1 = lg Else lg1 = LOF(2) For t3 = 1 To (lg1 / 2) - 1 Get #1, , zone: Get #2, , zone1 If zone <> zone1 Then different = 1 Exit For End If Next t3 Close #2 If different = 0 Then Kill Cells(t1, 1).Text Cells(t1, 1) = "" End If Next t1 Close #1 Next t GoTo extension:
fin: End Sub
"MichDenis" a écrit dans le message de news:
Je n'ai aucune erreur dans cette procédure :
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
J'ai fait une petite boucle comme ceci et aucune erreur s'est produite :
Dim No As Long, As Integer
Dim ch As String * 2
F = "c:atravailtest.txt"
For a = 1 To 10
ch = " "
No = FreeFile
Open F For Binary As No
Seek No, 2 * a
Get No, , ch
Close No
MsgBox ch
Next
Pour ce qui est du reste, je n'ai pas l'environnement pour tester !
"Michel Angelosanto" <angelosa@free.fr> a écrit dans le message de news:
OVG740DYIHA.4440@TK2MSFTNGP06.phx.gbl...
Voici le code complêt car c'est très bizarre je viens de changer la variable
en integer et c'est passé une fois et à la 2e fois de nouveau plantage
Le but est de supprimer les doublons dans les répertoires jpg1 et
jpg1video je fais le test sur les fichiers jpg,avi,mpg,mpeg,wmv
J'utilise la feuille courante pour stocker le nom des fichiers en colonne 1
en colonne 2 je stocke un entier lu à une position fixe de chaque fichier
puis je trie les 2 colonnes afin d'éviter la comparaison sur les fichiers
déja différents sur les 2 octets lus.
Dim t, t1, maxt, maxt1, r2, r3, temp2, temp3, zone, zone1 As Integer 'il
doit y avoir des variables inutilisées
Dim lg1, lg2 As Double
Sub doubles()
aig = 0
extension:
aig = aig + 1
Columns("A:B").Select
Selection.ClearContents
Select Case aig
Case 1:
ChDir "C:jpg1"
ext$ = "*." + "jpg"
Case 2:
ChDir "C:jpg1video"
ext$ = "*." + "mpg"
Case 3:
ChDir "C:jpg1video"
ext$ = "*." + "avi"
Case 4:
ChDir "C:jpg1video"
ext$ = "*." + "wmv"
Case Else
Exit Sub
End Select
t = 1
r$ = Dir$(ext$)
If r$ = "" Then
GoTo fin:
Else
Cells(t, 1) = r$
End If
'Lecture repertoire
While Cells(t, 1) <> ""
t = t + 1
Cells(t, 1) = Dir$
Wend
maxt = t - 1
'lecture début fichiers, on met la valeur des 2 premiers octets en colonne 2
For t = 1 To maxt
Open Cells(t, 1).Text For Binary As #2
Get #2, 50, r2
Cells(t, 2) = r2
Close #2
Next t
'on trie la liste sur la colonne 2
Range("A1:B" & maxt).Select
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("B1:B" &
maxt) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Feuil1").Sort
.SetRange Range("A1:B" & maxt)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'on supprime les doubles
For t = 1 To maxt - 1
If Cells(t, 1) = "" Then t = t + 1
Open Cells(t, 1).Text For Binary As #1
lg = LOF(1)
For t1 = 2 To maxt
If Cells(t1, 1) = "" Then t1 = t1 + 1
If Cells(t, 2) <> Cells(t1, 2) Then Exit For
'comparaison
Seek #1, 1 'on se positionne sur le premier octet
Open Cells(t1, 1).Text For Binary As #2
different = 0
If lg < LOF(2) Then lg1 = lg Else lg1 = LOF(2)
For t3 = 1 To (lg1 / 2) - 1
Get #1, , zone: Get #2, , zone1
If zone <> zone1 Then
different = 1
Exit For
End If
Next t3
Close #2
If different = 0 Then
Kill Cells(t1, 1).Text
Cells(t1, 1) = ""
End If
Next t1
Close #1
Next t
GoTo extension:
fin:
End Sub
"MichDenis" <michdenis@hotmail.com> a écrit dans le message de
news:OK0zhsDYIHA.1208@TK2MSFTNGP05.phx.gbl...
Je n'ai aucune erreur dans cette procédure :
Sub test()
Dim ch As String * 2
ch = " "
F = "c:atravailtest.txt"
Open F For Binary As #1
Seek #1, 100
Get #1, , ch
Close #1
MsgBox ch
End Sub
J'ai fait une petite boucle comme ceci et aucune erreur s'est produite :
Dim No As Long, As Integer Dim ch As String * 2
F = "c:atravailtest.txt"
For a = 1 To 10 ch = " " No = FreeFile Open F For Binary As No Seek No, 2 * a Get No, , ch Close No MsgBox ch Next
Pour ce qui est du reste, je n'ai pas l'environnement pour tester !
"Michel Angelosanto" a écrit dans le message de news:
Voici le code complêt car c'est très bizarre je viens de changer la variable en integer et c'est passé une fois et à la 2e fois de nouveau plantage Le but est de supprimer les doublons dans les répertoires jpg1 et jpg1video je fais le test sur les fichiers jpg,avi,mpg,mpeg,wmv J'utilise la feuille courante pour stocker le nom des fichiers en colonne 1 en colonne 2 je stocke un entier lu à une position fixe de chaque fichier puis je trie les 2 colonnes afin d'éviter la comparaison sur les fichiers déja différents sur les 2 octets lus.
Dim t, t1, maxt, maxt1, r2, r3, temp2, temp3, zone, zone1 As Integer 'il doit y avoir des variables inutilisées Dim lg1, lg2 As Double
Sub doubles() aig = 0 extension: aig = aig + 1 Columns("A:B").Select Selection.ClearContents Select Case aig Case 1: ChDir "C:jpg1" ext$ = "*." + "jpg" Case 2: ChDir "C:jpg1video" ext$ = "*." + "mpg" Case 3: ChDir "C:jpg1video" ext$ = "*." + "avi" Case 4: ChDir "C:jpg1video" ext$ = "*." + "wmv" Case Else Exit Sub End Select
t = 1
r$ = Dir$(ext$) If r$ = "" Then GoTo fin: Else Cells(t, 1) = r$ End If 'Lecture repertoire While Cells(t, 1) <> "" t = t + 1 Cells(t, 1) = Dir$ Wend maxt = t - 1
'lecture début fichiers, on met la valeur des 2 premiers octets en colonne 2 For t = 1 To maxt Open Cells(t, 1).Text For Binary As #2 Get #2, 50, r2 Cells(t, 2) = r2 Close #2 Next t 'on trie la liste sur la colonne 2 Range("A1:B" & maxt).Select ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("B1:B" & maxt) _ , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal With ActiveWorkbook.Worksheets("Feuil1").Sort .SetRange Range("A1:B" & maxt) .Header = xlGuess .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With
'on supprime les doubles For t = 1 To maxt - 1 If Cells(t, 1) = "" Then t = t + 1 Open Cells(t, 1).Text For Binary As #1 lg = LOF(1) For t1 = 2 To maxt If Cells(t1, 1) = "" Then t1 = t1 + 1 If Cells(t, 2) <> Cells(t1, 2) Then Exit For 'comparaison Seek #1, 1 'on se positionne sur le premier octet Open Cells(t1, 1).Text For Binary As #2 different = 0 If lg < LOF(2) Then lg1 = lg Else lg1 = LOF(2) For t3 = 1 To (lg1 / 2) - 1 Get #1, , zone: Get #2, , zone1 If zone <> zone1 Then different = 1 Exit For End If Next t3 Close #2 If different = 0 Then Kill Cells(t1, 1).Text Cells(t1, 1) = "" End If Next t1 Close #1 Next t GoTo extension:
fin: End Sub
"MichDenis" a écrit dans le message de news:
Je n'ai aucune erreur dans cette procédure :
Sub test() Dim ch As String * 2 ch = " " F = "c:atravailtest.txt" Open F For Binary As #1 Seek #1, 100 Get #1, , ch Close #1 MsgBox ch End Sub
Michel Angelosanto
Oui c'est pareil .
"MichDenis" a écrit dans le message de news:
As-tu essayé en utilisant FreeFile
Sub Test() Dim ch As String * 2 ch = " " No = FreeFile F = "c:atravailtest.txt" Open F For Binary As No Seek No, 100 Get No, , ch Close No1 MsgBox ch End Sub
Oui c'est pareil .
"MichDenis" <michdenis@hotmail.com> a écrit dans le message de
news:eyw9IzDYIHA.6044@TK2MSFTNGP05.phx.gbl...
As-tu essayé en utilisant FreeFile
Sub Test()
Dim ch As String * 2
ch = " "
No = FreeFile
F = "c:atravailtest.txt"
Open F For Binary As No
Seek No, 100
Get No, , ch
Close No1
MsgBox ch
End Sub
Sub Test() Dim ch As String * 2 ch = " " No = FreeFile F = "c:atravailtest.txt" Open F For Binary As No Seek No, 100 Get No, , ch Close No1 MsgBox ch End Sub