Copier font dans le disque C

**MADA BLACK** · 26/01/2019, 10h28

Bonjour tout le monde
Svp gentelman
Si vous pouvez m'aider a resoudre ce probleme
J'ai un font nomme (Bubblegum) .. je l'ai posé dans le dossier (Fontart\Debug)
Je veux copier ce font dans le disque (C\windows\Fonts)
Malheureusement j'obtien ce message d'erreur
"L'acces au chemin d'acces C:\windows\Fonts\Bubblegum.TTF est refuse"
Comment resoudre ce probleme svp je ne veux pas copier ce font manuellement
Voici tout mon code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Imports System.Runtime.InteropServices
Imports System.IO
Imports Microsoft.Win32
Public Class Form1
    <DllImport("gdi32.dll", EntryPoint:="AddFontResourceW")>
    Private Shared Function AddFontResourceW(<MarshalAs(UnmanagedType.LPWStr)> ByVal lpFilename As String) As Integer
    End Function
 
    <DllImport("gdi32.dll", EntryPoint:="RemoveFontResourceW")>
    Private Shared Function RemoveFontResourceW(<MarshalAs(UnmanagedType.LPWStr)> ByVal lpFileName As String) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
    <DllImport("user32.dll", EntryPoint:="SendMessageW")>
    Private Shared Function SendMessageW(ByVal hWnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
    End Function
    Private Const WM_FONTCHANGE As Integer = &H1D
    Private Const HWND_BROADCAST As Integer = &HFFFF
    Private Sub Transmettre_Font()
        Dim Font_Name As String = "Bubblegum (TrueType)"
        Dim Font_File_Name As String = "Bubblegum.ttf"
 
        Dim SourceFontFile As String = (Application.StartupPath & "\Fontart\Bubblegum.TTF")
 
        Dim DestinationFontFile As String = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Fonts), Path.GetFileName(SourceFontFile))
        If Not File.Exists(DestinationFontFile) Then
            Try
                File.Copy(SourceFontFile, DestinationFontFile) 'copy the font file to the system's font folder
            Catch ex As Exception
                MessageBox.Show(ex.Message, "Copy Failed...")
                Exit Sub
            End Try
            'Add the 'copied' font file to the system's font resource table. If AddFontResource fails it returns 0, otherwise it returns the number of fonts successfully added to the table.
            If AddFontResourceW(DestinationFontFile) > 0 Then
                'open the Fonts registry key with 'write' access.
                Dim FontRegKey As RegistryKey = Registry.LocalMachine.OpenSubKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts", True)
                If FontRegKey IsNot Nothing Then
                    Try
                        FontRegKey.SetValue(Path.GetFileNameWithoutExtension(DestinationFontFile) & " (TrueType)", Path.GetFileName(DestinationFontFile)) 'add a Value to the Fonts registry key for your font.
                    Catch ex As Exception
                        MessageBox.Show(ex.Message, "Failed To Register Font...")
                    End Try
                    FontRegKey.Close()
                Else
                    MessageBox.Show("Could not open the fonts registry key.", "Failed To Register Font...")
                End If
                'broadcast the WM_FONTCHANGE message to all opened applications to let them know a font resource has changed.
                SendMessageW(New IntPtr(HWND_BROADCAST), WM_FONTCHANGE, IntPtr.Zero, IntPtr.Zero)
            Else
                MessageBox.Show("Could not add the font to the system resource table.", "Install Failed...")
            End If
        Else
            MessageBox.Show("A font with the same filename already exists in the system font folder.", "Install Failed...")
        End If
    End Sub
    Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
        Call Transmettre_Font()
    End Sub
End Class

Merci beaucoup d'avance pour l'aide
Cordialement
MADA

**clementmarcotte** · 26/01/2019, 19h35

Bonjour,

Je ne suis pas prêt à le jurer, mais je pense que VB doit être lancé en tant qu'administrateur. Sauf horreur de ma part, la sécurité de Windows considère le dossier des polices comme un dossier système.

**MADA BLACK** · 26/01/2019, 21h28

Merci beaucoup maitre clementmarcotte pour l'aide
Oui vous avez bien raison .. il s'agit d'administrateur .. mais y'a pas un moyen pour passer l'affaire dans windows\fonts
Cordialement
MADA

**StringBuilder** · 27/01/2019, 10h15

Ça fait longtemps que j'ai pas fait ça, mais depuis Windows 95 (donc ça date un peu) normalement le répertoire "windows\fonts" est totalement protégé et géré par le système.

Le fait que tu puisses faire des copiers/coller en interactif dans ce dossier n'est en réalité qu'un artifice de l'exporateur.
Il me semble qu'en BATCH, un copy dans ce dossier ne fonctionne pas non plus.

Si mes souvenirs sont bons, pour placer une font dans ce dossier, il ne faut pas la copier dedans, mais tout simplement l'installer.

Et si mes souvenirs sont bon, il suffit de faire un Process.Start() sur la font elle-même.
=> Ça va alors installer la font sur le système, et la recopier dans "windows\fonts".

**MADA BLACK** · 27/01/2019, 11h51

Salut StringBuilder
Merci beaucoup pour vos remarques et impeccables .. logiques conseils
Je vais chercher comment l'installer dans C et j'espère qu'elle fonctionne
Amicalement
MADA

Gentelman..
Franchement j'ai beaucoup cherché sur le net..dans google..dans tous les titres ayant ( installe font Vb net )
Mais je n'ai pas réussi
Si vous avez quelques suggestions svp
Amicalement
MADA

**wallace1** · 28/01/2019, 18h07

Bonsoir,

Si tu ne trouves pas de réponses en vbnet cherches en c# et adaptes le code en vbnet :
https://stackoverflow.com/questions/...92546#21992546

Ceci fonctionne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
        Dim shell = New Shell32.Shell()
        Dim fontFolder As Shell32.Folder = shell.NameSpace(&H14)
        fontFolder.CopyHere("D:\Bureau\LATINWD.TTF")

AU PRÉALABLE IL FAUT :

1- Importer dans les références du projet C:\Windows\SysWow64\Shell32.dll pour un OS 64bits ou C:\Windows\System32\Shell32.dll pour un OS 32bits
2- Paramétrer le fichier Manifest en RequireAdministrator.

++

**MADA BLACK** · 28/01/2019, 18h42

Merci beaucoup wallace1 pour l'aide
Svp ou je pose ces lignes dans mon code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
 
        Dim shell = New Shell32.Shell()
        Dim fontFolder As Shell32.Folder = shell.NameSpace(&H14)
        fontFolder.CopyHere("D:\Bureau\LATINWD.TTF")

J'ai pas pu les mettre correctement
Amicalement
MADA

**wallace1** · 28/01/2019, 18h51

Merci beaucoup wallace1 pour l'aide
Svp ou je pose ces lignes dans mon code

Déjà as-tu importés Shell32.dll dans tes références de projet ??
Ensuite tu le place dans le corps d'une méthode quelconque que tu appelles ensuites dans un event (dans ton cas plus haut tu l'avais placés dans l'event Load de ton Form)

PS : Pour info ce code (adapté de ton code original) testé chez moi avec le fichier Manifest paramétré à RequireAdministrator fonctionne très bien :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
   <DllImport("gdi32.dll", EntryPoint:="AddFontResourceW")>
    Private Shared Function AddFontResourceW(<MarshalAs(UnmanagedType.LPWStr)> ByVal lpFilename As String) As Integer
    End Function
 
    <DllImport("gdi32.dll", EntryPoint:="RemoveFontResourceW")>
    Private Shared Function RemoveFontResourceW(<MarshalAs(UnmanagedType.LPWStr)> ByVal lpFileName As String) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
    <DllImport("user32.dll", EntryPoint:="SendMessageW")>
    Private Shared Function SendMessageW(ByVal hWnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
    End Function
    Private Const WM_FONTCHANGE As Integer = &H1D
    Private Const HWND_BROADCAST As Integer = &HFFFF
    Private Sub Transmettre_Font()
        Dim SourceFontFile As String = ("D:\Bureau\LATINWD.TTF")
 
        Dim DestinationFontFile As String = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Fonts), Path.GetFileName(SourceFontFile))
        If Not File.Exists(DestinationFontFile) Then
            Try
                File.Copy(SourceFontFile, DestinationFontFile) 'copy the font file to the system's font folder
            Catch ex As Exception
                MessageBox.Show(ex.Message, "Copy Failed...")
                Exit Sub
            End Try
            'Add the 'copied' font file to the system's font resource table. If AddFontResource fails it returns 0, otherwise it returns the number of fonts successfully added to the table.
            If AddFontResourceW(DestinationFontFile) > 0 Then
                'open the Fonts registry key with 'write' access.
                Dim FontRegKey As RegistryKey = Registry.LocalMachine.OpenSubKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts", True)
                If FontRegKey IsNot Nothing Then
                    Try
                        'On récupère le nom de la police pour l'utiliser au niveau de la clé de registre
                        Dim fontCol = New PrivateFontCollection()
                        fontCol.AddFontFile(DestinationFontFile)
                        Dim actualFontName = fontCol.Families(0).Name
                        FontRegKey.SetValue(actualFontName & " (TrueType)", Path.GetFileName(DestinationFontFile)) 'add a Value to the Fonts registry key for your font.
                    Catch ex As Exception
                        MessageBox.Show(ex.Message, "Failed To Register Font...")
                    End Try
                    FontRegKey.Close()
                Else
                    MessageBox.Show("Could not open the fonts registry key.", "Failed To Register Font...")
                End If
                'broadcast the WM_FONTCHANGE message to all opened applications to let them know a font resource has changed.
                SendMessageW(New IntPtr(HWND_BROADCAST), WM_FONTCHANGE, IntPtr.Zero, IntPtr.Zero)
            Else
                MessageBox.Show("Could not add the font to the system resource table.", "Install Failed...")
            End If
        Else
            MessageBox.Show("A font with the same filename already exists in the system font folder.", "Install Failed...")
        End If
    End Sub

Tu as un access denied car tu n'as pas paramétrés ton fichier Manifest de projet correctement !

**MADA BLACK** · 28/01/2019, 19h13

Merci beaucoup wallace1
J'ai une petite erreur dans le code :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Dim fontCol = New PrivateFontCollection()

Erreur : Type 'PrivateFontCollection' is not defined
Voici tout le code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Imports System.Runtime.InteropServices
Imports System.IO
Imports Microsoft.Win32
Public Class Form1
    <DllImport("gdi32.dll", EntryPoint:="AddFontResourceW")>
    Private Shared Function AddFontResourceW(<MarshalAs(UnmanagedType.LPWStr)> ByVal lpFilename As String) As Integer
    End Function
    <DllImport("gdi32.dll", EntryPoint:="RemoveFontResourceW")>
    Private Shared Function RemoveFontResourceW(<MarshalAs(UnmanagedType.LPWStr)> ByVal lpFileName As String) As <MarshalAs(UnmanagedType.Bool)> Boolean
    End Function
    <DllImport("user32.dll", EntryPoint:="SendMessageW")>
    Private Shared Function SendMessageW(ByVal hWnd As IntPtr, ByVal Msg As UInteger, ByVal wParam As IntPtr, ByVal lParam As IntPtr) As Integer
    End Function
    Private Const WM_FONTCHANGE As Integer = &H1D
    Private Const HWND_BROADCAST As Integer = &HFFFF
    Private Sub Transmettre_Font()
        'Dim SourceFontFile As String = ("D:\Bureau\LATINWD.TTF")
        Dim SourceFontFile As String = (Application.StartupPath & "\Fontart\Bubblegum.TTF")
        Dim DestinationFontFile As String = Path.Combine(Environment.GetFolderPath(Environment.SpecialFolder.Fonts), Path.GetFileName(SourceFontFile))
        If Not File.Exists(DestinationFontFile) Then
            Try
                File.Copy(SourceFontFile, DestinationFontFile) 'copy the font file to the system's font folder
            Catch ex As Exception
                MessageBox.Show(ex.Message, "Copy Failed...")
                Exit Sub
            End Try
            'Add the 'copied' font file to the system's font resource table. If AddFontResource fails it returns 0, otherwise it returns the number of fonts successfully added to the table.
            If AddFontResourceW(DestinationFontFile) > 0 Then
                'open the Fonts registry key with 'write' access.
                Dim FontRegKey As RegistryKey = Registry.LocalMachine.OpenSubKey("SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts", True)
                If FontRegKey IsNot Nothing Then
                    Try
                        'On récupère le nom de la police pour l'utiliser au niveau de la clé de registre
                        Dim fontCol = New PrivateFontCollection()
                        fontCol.AddFontFile(DestinationFontFile)
                        Dim actualFontName = fontCol.Families(0).Name
                        FontRegKey.SetValue(actualFontName & " (TrueType)", Path.GetFileName(DestinationFontFile)) 'add a Value to the Fonts registry key for your font.
                    Catch ex As Exception
                        MessageBox.Show(ex.Message, "Failed To Register Font...")
                    End Try
                    FontRegKey.Close()
                Else
                    MessageBox.Show("Could not open the fonts registry key.", "Failed To Register Font...")
                End If
                'broadcast the WM_FONTCHANGE message to all opened applications to let them know a font resource has changed.
                SendMessageW(New IntPtr(HWND_BROADCAST), WM_FONTCHANGE, IntPtr.Zero, IntPtr.Zero)
            Else
                MessageBox.Show("Could not add the font to the system resource table.", "Install Failed...")
            End If
        Else
            MessageBox.Show("A font with the same filename already exists in the system font folder.", "Install Failed...")
        End If
    End Sub
End Class

Cordialement
MADA

**wallace1** · 28/01/2019, 19h21

Il faut importer system.drawing.text

**MADA BLACK** · 28/01/2019, 20h52

Merci beaucoup wallace1 pour votre impeccable solution
Enfin J'ai pu transmettre font a windows C .. mais il faut passer par click droit ( Executer en tant qu'administrateur )
Tres gentil de votre part gentelman
Cordialement
MADA

Copier font dans le disque C

VB.NET

Discussions similaires

Partager

Partager