7,759
社区成员
发帖
与我相关
我的任务
分享
Option Explicit
Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function SendMessageW Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const EM_REPLACESEL = &HC2
Private Declare Function TextOut Lib "gdi32" Alias "TextOutW" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As Long, ByVal nCount As Long) As Long
Private Sub Command2_Click()
Dim str As String
Me.FontName = "My symbol"
Me.FontSize = 45
str = ChrW(&H2021)
TextOut Me.hdc, 0, 0, StrPtr(str), Len(str)
Me.Refresh
End Sub
Private Sub Command1_Click()
Dim str As String
RichTextBox1.SelFontName = "My symbol"
str = ChrW(&H2021)
SendMessageW RichTextBox1.hwnd, EM_REPLACESEL, 0, ByVal str '发送按键字符
End Sub
Private Sub Form_Load()
Debug.Print AddFontResource(App.Path & "\My symbol.ttf")
End Sub
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1250]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1251]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1252]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1253]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1254]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1255]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1256]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1257]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|1258]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|874]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|932]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|936]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|949]
[HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\RtlQueryRegistryConfig\TrustedTypesKeyList\USR|EUDC|950]
[HKEY_USERS\.DEFAULT\EUDC]
[HKEY_USERS\.DEFAULT\EUDC\932]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\.DEFAULT\EUDC\936]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\.DEFAULT\EUDC\949]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\.DEFAULT\EUDC\950]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-19\EUDC]
[HKEY_USERS\S-1-5-19\EUDC\932]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-19\EUDC\936]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-19\EUDC\949]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-19\EUDC\950]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-20\EUDC]
[HKEY_USERS\S-1-5-20\EUDC\932]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-20\EUDC\936]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-20\EUDC\949]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-20\EUDC\950]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-21-3287820392-1537789725-1580799788-500\EUDC]
[HKEY_USERS\S-1-5-21-3287820392-1537789725-1580799788-500\EUDC\932]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-21-3287820392-1537789725-1580799788-500\EUDC\936]
"SystemDefaultEUDCFont"="C:\\WINDOWS\\FONTS\\EUDC.TTE"
[HKEY_USERS\S-1-5-21-3287820392-1537789725-1580799788-500\EUDC\949]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-21-3287820392-1537789725-1580799788-500\EUDC\950]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-18\EUDC]
[HKEY_USERS\S-1-5-18\EUDC\932]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-18\EUDC\936]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-18\EUDC\949]
"SystemDefaultEUDCFont"="EUDC.TTE"
[HKEY_USERS\S-1-5-18\EUDC\950]
"SystemDefaultEUDCFont"="EUDC.TTE"
VERSION 5.00
Begin VB.Form Form1
Caption = "EUDCsetup"
ClientHeight = 1005
ClientLeft = 60
ClientTop = 345
ClientWidth = 6165
LinkTopic = "Form1"
ScaleHeight = 1005
ScaleWidth = 6165
StartUpPosition = 3 '窗口缺省
Begin VB.Timer Timer1
Enabled = 0 'False
Interval = 1000
Left = 2520
Top = 240
End
Begin VB.Label Label1
Caption = "[]"
BeginProperty Font
Name = "宋体"
Size = 24
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 1335
Left = 120
TabIndex = 0
Top = 120
Width = 7335
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim ReturnValue
Dim fontsdir As String
Dim i As Integer
Private Sub Form_Load()
On Error Resume Next
fontsdir = Environ("windir") + "\Fonts"
Kill fontsdir + "\eudc.tte"
Kill fontsdir + "\eudc.euf"
FileCopy App.Path + "\eudc.tte", fontsdir + "\eudc.tte"
FileCopy App.Path + "\eudc.euf", fontsdir + "\eudc.euf"
i = 0
Timer1.Enabled=True
End Sub
Private Sub Timer1_Timer()
i = i + 1
If i = 1 Then
ReturnValue = Shell("eudcedit.EXE", 1) '运行TrueType造字程序
AppActivate ReturnValue ' 激活
SendKeys "%{F4}%{F4}", True ' 按两次 ALT+F4 关闭TrueType造字程序
End If
If i >= 3 Then
End 'Form
End If
End Sub
Private Sub Command1_Click()
Dim str As String
RichTextBox1.SelFontName = "楷体"
str = ChrW(&H4E01)
SendMessageW RichTextBox1.hwnd, EM_REPLACESEL, 0, ByVal str '发送按键字符
End Sub
我是说,不用自定义字体,而用系统字体,就可行。