Créer un fichier binaire de type midi ou autres (*.*)

Soyez le premier à donner votre avis sur cette source.

Vue 11 165 fois - Téléchargée 548 fois

Description

Tout d'abord je tiens à remercier XENTOR pour son aide et ses conseils précieux !!!

Ce code permet de créer par défaut des fichiers binaire.mid mais également des fichiers de tout format à condition de connaitre les "header" correspondant !?!

Par la suite ce programmme sera un générateur de mélodies aléatoires dirigées ( c'est à dire compatible avec la tonalité choisie ) et sauvegardées dans des fichiers.mid

Actuellement le fichier midi créé par défaut joue la note "LA" = 51 !!!
00 90 51 3C 8F 00 80 51 00

Source / Exemple :


Option Explicit

Dim fichier As String
Dim canal As Byte
Dim x() As String
Dim chaine As String

Private Sub Command1_Click()
'création du fichier midi ---------------------------
On Error Resume Next
'CMD est le nom que j'ai donné à une boite CommonDialog
CMD.Filter = "Fichier MIDI (*.mid)|*.mid|All (*.*)|*.*"
CMD.DialogTitle = "Enregistrer le fichier sous !?! - ( fichier.mid ou fichier.* )"
CMD.ShowSave
'initialisation à chaque sauvegarde
Kill fichier
'création du nouveau fichier
fichier = CMD.FileName
canal = FreeFile
Open fichier For Binary As canal
'écrit dans le fichier ouvert le texte binaire saisi
écrire (Text1.Text)
Close canal
End Sub

Function codeAt(lettre As String) As Integer
'cette fonction renvoie le code ascii d'un caractère
Dim alpha As String
Dim k As Integer
alpha = "0123456789ABCDEF"
For k = 1 To 10
If lettre = Mid(alpha, k, 1) Then
codeAt = (k - 1) + 48
End If
Next
For k = 11 To 16
If lettre = Mid(alpha, k, 1) Then
codeAt = (k - 11) + 65
End If
Next
End Function

Function codeHex(L As String) As Integer
'cette fonction renvoie la valeur en base dix d'une chaine hexadécimale
'exemple: codeHex("4D") = 77
Dim gauche As Integer
Dim droite As Integer
Dim h As Integer
gauche = codeAt(Mid(L, 1, 1))
droite = codeAt(Mid(L, 2, 1))
'test si le premier caractère est un chiffre ou une lettre
'pour lui donner sa valeur HEXA-DIXAINE en base 10
If gauche >= 48 And gauche <= 57 Then
gauche = (gauche - 48) * 16
End If
If gauche >= 65 And gauche <= 70 Then
gauche = (gauche - 55) * 16
End If
'test si le deuxième caractère est un chiffre ou une lettre
'pour lui donner sa valeur HEXA-UNITE en base 10
If droite >= 48 And droite <= 57 Then
droite = droite - 48
End If
If droite >= 65 And droite <= 70 Then
droite = droite - 55
End If
h = gauche + droite
codeHex = h
End Function

Function écrire(mot As String)
'cette fonction permet d'écrire des codes Hexadécimaux dans un fichier binaire
Dim car As String * 1
Dim i As Integer
Dim m As String
For i = 1 To Len(mot) Step 3
m = Mid(mot, i, 2)
car = Chr(codeHex(m))
Put canal, , car
Next
End Function

Private Sub Form_Load()
atlas.Left = 2000
atlas.Top = 2000
End Sub

Conclusion :


J'aimerais amélioré un peu l'esthétique de mon programme et notamment ne faire apparaitre la SCROLLBAR de la TextBox que lorsque le texte dépasse du cadre et la faire disparaitre dans le cas contraire !!!
Ou bien utiliser une TextBox (sans scrollbar) et une SCROLLBAR séparée qui apparaisse et disparaisse selon les cas et faire en sorte que les deux marchent ensemble !!!

Si quelqu'un peut m'expliquer comment faire ça !?!

Codes Sources

A voir également

Ajouter un commentaire Commentaires
Messages postés
1
Date d'inscription
jeudi 26 octobre 2006
Statut
Membre
Dernière intervention
28 octobre 2006

je crois que ce programme mache bien. mais j'ai pas encore le tester aujourd'hui. Bonne continuation à vous
Messages postés
51
Date d'inscription
vendredi 20 février 2004
Statut
Membre
Dernière intervention
7 juillet 2006

LUTO t'es vraiment qu'une tête de teub... LoL sisi je t'assure, c'est super constructif ta réaction à deux francs...
Messages postés
248
Date d'inscription
vendredi 10 novembre 2000
Statut
Membre
Dernière intervention
19 décembre 2008

essaye Put 1, 1, "MThd" & Chr(0) & Chr(255) & Chr(47) & Chr(0) ...
Messages postés
102
Date d'inscription
mercredi 9 janvier 2002
Statut
Membre
Dernière intervention
6 juin 2010

Je ne connais pas la reponse, mais ces quesrtions se posent dans le forum. C'est fait pour ca. Ici, on met plutot les programmes qui marchent.
Bonne continuation

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.