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
| Private Sub CommandButton1_Click()
Dim S As String, Dl As Long, Dc As Long
Dim Hauteur As Long, Largeur As Long
Dim nomF As String, Tbcol(), t2()
Dim Fichier As Variant, col As Long
Dim i As Long, F As Long, j As Long
Dim b As Byte, mes As String
Dim Feuille As Worksheet
'Affichage de la la boîte de dialogue standard "Ouvrir" pour sélectionner une image GIF
'sur le disque dur.
'GetOpenFilename permet de lire le nom du fichier sélectionné par l'utilisateur sans
'réellement ouvrir le fichier.
Fichier = Application.GetOpenFilename("Fichiers Images (*.gif),*.gif")
'Vérifie si l'utilisateur a cliqué sur le bouton "Annuler" ou sur la croix de fermeture.
If Fichier = False Then
MsgBox "Opération Annulée"
'pour sortir de la procédure
Exit Sub
End If
col = 0
'----------- message pendant le transfert ----
'Permet de créer un message d'attente défilant dans le WebBrowser pendant le transfert
'des données (au format binaire) dans les cellules de la nouvelle feuille.
LeTexte = "Veuillez patienter... traitement en cours ..."
LaCouleur = "#CC0000"
WebBrowser1.Navigate _
"about:<html><body BGCOLOR ='#CCCCCC' scroll='no'><font color= " & LaCouleur & _
" size='5' face='Arial'>" & _
"<marquee>" & LeTexte & "</marquee></font></body></html>"
'----------------------------------------------
'Boucle sur les données binaire du fichier sélectionné et alimente la variable tableau
F = FreeFile
Open Fichier For Binary Access Read As F
While Not EOF(F)
Get #F, , b
'DoEvents
col = col + 1
ReDim Preserve Tbcol(1 To col)
Tbcol(col) = b
Wend
Close F
nomF = InputBox("Si vous voulez sauvegarder l'image dans le fichier" & Chr(10) & "Choisir un nom pour" & Chr(10) & "la feuille qui contiendra l'image")
'Ajoute une feuille dans le claseur et la positionne à la fin.
If nomF <> "" Then
Set Feuille = ThisWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count))
'Renomme la feuille
Feuille.Name = nomF
'Masque la feuille
Feuille.Visible = xlSheetHidden
'--- transfert des données dans la feuille ----
'Boucle sur la variable tableau et transfère les données dans les cellules de la feuille de calcul.
Sheets(nomF).Range("A1").Resize(UBound(Tbcol), 1) = WorksheetFunction.Transpose(Tbcol)
'For i = 1 To UBound(Tbcol)
'Sheets(nomF).Range("A" & i) = Tbcol(i)
'Next i
End If
mes = MsgBox("voulez-vous voir l'image, dès maintenant ?", vbYesNo)
If mes = 6 Then
'----- Création de l'image pour un affichage dans l'USF -----
S = "C:\Users\Dominique\Documents\imageTemp.gif"
F = FreeFile
Open S For Binary Access Write As F
For i = 1 To UBound(Tbcol)
b = Tbcol(i)
Put #F, , b
DoEvents
Next i
Close F
'Définit les dimensions d'affichage de l'image dans le WebBrowser.
Largeur = WebBrowser1.Width * 96 / 72
Hauteur = WebBrowser1.Height * 96 / 72
'Affiche l'image dans le WebBrowser en supprimant les marges et les barres de défilement
WebBrowser1.Navigate _
"ABOUT:<HTML><CENTER><HEAD><body scroll='no' LEFTMARGIN=0 TOPMARGIN=0><IMG WIDTH=" & _
Largeur & " HEIGHT=" & Hauteur & _
" SRC='" & S & "'</IMG></BODY></CENTER></HTML>"
' Affiche une page blanche dans le webBrowser
'WebBrowser1.Navigate "about:blank"
Else
MsgBox "Opération terminée"
'Ferme et réouvre l'UserForm (permet une réinitialisation rapide)
Unload Me
UserForm1.Show
End If
End Sub |
Variable tableau et transpose
Répondre avec citation
Partager