1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
| Attribute VB_Name = "fichiers_inclus"
'J@C octobre 2002
Const nouvcar = "£¤"
Sub enregistre_un_fichier()
'choix du fichier à télécharger
fich = Application.GetOpenFilename(, , "choisissez le fichier à enregistrer")
If fich = False Then Exit Sub
'détermination de la première ligne vide pour y insérer le fichier
lin = Cells.Find("*", , , , , xlPrevious).Row + 1
'détermination du nom du fichier (sans le chemin d'accès)
'et stockage dans la première colonne
nomfich = fich
Do While InStr(nomfich, "\") > 0
nomfich = Right(nomfich, Len(nomfich) - InStr(nomfich, "\"))
Loop
Cells(lin, 1) = nomfich & " (" & Format(FileLen(fich) / 1000, "0.0") & " ko)"
'détermination de l'extension et stockage dans la deuxième cellule
extn = Right(fich, 4)
If Left(extn, 1) <> "." Then extn = "." & extn
Cells(lin, 2) = extn
'ouverture du fichier en lecture binaire
Open fich For Binary Access Read As #1
longueur = LOF(1)
'lecture par paquets de 5*1024 octets (pour aller plus vite)
nbcar = 5 * 1024
col = 3
encor:
If longueur > nbcar Then
truc = Input(nbcar, #1)
longueur = longueur - nbcar
'codage par la fonction nume et inscription dans la cellule suivante
Cells(lin, col).Value = "'" & nume(truc, nouvcar)
col = col + 1
GoTo encor
Else
'lecture codage et inscription des derniers octets
truc = Input(longueur, #1)
Cells(lin, col).Value = "'" & nume(truc, nouvcar)
End If
Close #1
Cells(lin, 1).Select
End Sub
Sub récupère_le_fichier()
Dim textfin As String
'les données du fichier sont dans la ligne sélectionnée
lin = ActiveCell.Row
extn = Cells(lin, 2)
'récupération des octets
txtfin = txtfin & truc
txtfin = ""
For col = 3 To Rows(lin).Find("*", , , , , xlPrevious).Column
'utilisation de la fonction rnum pour récupérer les octets
txtfin = txtfin & rnum(Cells(lin, col).Value, nouvcar)
Next
'création du fichier avec ouverture en écriture et copie des données
Open "c:\rien" & extn For Output As #1
Print #1, txtfin
Close #1
'ouverture du fichier (pour voir le résultat)
ThisWorkbook.FollowHyperlink "c:\rien" & extn, , True
'le fichier est enregistré sur C:\ sous rien.txt, rien.wav, rien.html...
End Sub
Function nume(txt, nvcar)
Do While InStr(txt, Chr(0)) > 0
txt = Left(txt, InStr(txt, Chr(0)) - 1) & nvcar & Right(txt, Len(txt) - InStr(txt, Chr(0)))
Loop
nume = txt
End Function
Function rnum(txt, nvcar)
Do While InStr(txt, nvcar) > 0
txt = Left(txt, InStr(txt, nvcar) - 1) & Chr(0) & Right(txt, Len(txt) - InStr(txt, nvcar) + 1 - Len(nvcar))
Loop
rnum = txt
End Function |
