-
Notifications
You must be signed in to change notification settings - Fork 0
/
FontsOps.bas
99 lines (91 loc) · 3.76 KB
/
FontsOps.bas
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
92
93
94
95
96
97
98
Attribute VB_Name = "FontsOps"
Option Explicit
Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Dim fontOk
Sub removeNoFont()
Dim fontname As String
fontname = ThisDocument.Name
fontname = Mid(fontname, 1, InStr(fontname, "(") - 1)
Dim a
For Each a In ThisDocument.Characters
If a.Font.NameFarEast = fontname And a.Font.Name = fontname Then
Else
a.Delete
End If
Next a
ThisDocument.Save
Beep
playSound
End Sub
'https://analystcave.com/vba-status-bar-progress-bar-sounds-emails-alerts-vba/#:~:text=The%20VBA%20Status%20Bar%20is%20a%20panel%20that,Bar%20we%20need%20to%20Enable%20it%20using%20Application.DisplayStatusBar%3A
Sub playSound() 'Public Declare Function sndPlaySound32 Lib "winmm.dll" Alias "sndPlaySoundA" (ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
On Error Resume Next
'播放聲音、音效、音樂
sndPlaySound32 "c:\Windows\Media\Alarm08.wav", &H0 '"C:\Windows\Media\Chimes.wav", &H0
' sndPlaySound32 "C:\Program Files (x86)\Microsoft Office\Office16\MEDIA\LYNC_ringtone2.wav", &H0
' sndPlaySound32 "C:\Program Files (x86)\Microsoft Office\Office16\MEDIA\LYNC_fsringing.wav", &H0
End Sub
Sub FontIterator()
Dim fnt 'As String
For Each fnt In Application.FontNames
If (InStr(fnt, "隸") Or InStr(1, fnt, "li", vbTextCompare)) And InStr(1, fnt, "@", vbTextCompare) = 0 And InStr(1, fnt, "lian", vbTextCompare) = 0 And InStr(1, fnt, "Libre", vbTextCompare) = 0 And InStr(1, fnt, "Lith", vbTextCompare) = 0 And InStr(1, fnt, "Liber", vbTextCompare) = 0 And InStr(1, fnt, "light", vbTextCompare) = 0 And InStr(1, fnt, "Franklin", vbTextCompare) = 0 And InStr(1, fnt, "Italic", vbTextCompare) = 0 Then
ThisDocument.Range.Font.Name = fnt
Debug.Print fnt
Stop
End If
Next fnt
playSound
Beep
'Dim strFont As String
'Dim intResponse As Integer
'
'For Each strFont In FontNames
' intResponse = MsgBox(Prompt:=strFont, Buttons:=vbOKCancel)
' If intResponse = vbCancel Then Exit For
'Next strFont
End Sub
Sub FontsListView()
Dim fnt 'As String
Dim fontCount As Integer, x As String, i As Integer, xp As String
fontCount = Application.FontNames.Count
x = Chr(13) & Left(ThisDocument.Paragraphs(1).Range.Text, Len(ThisDocument.Paragraphs(1).Range.Text) - 1)
For i = 2 To fontCount
xp = xp & x
Next i
ThisDocument.Range.InsertAfter xp
i = 0
For Each fnt In Application.FontNames
i = i + 1
ThisDocument.Paragraphs(i).Range.Font.Name = fnt
Next fnt
Dim e
fontokList
For Each fnt In ThisDocument.Paragraphs
For Each e In fontOk
If e = fnt.Range.Font.NameFarEast Then fnt.Range.Delete
Next e
Next fnt
playSound
Beep
End Sub
Sub fontokList()
fontOk = Array("標楷體", "新細明體", "微軟正黑體", "新細明體 (本文中文字型)", "+本文中文字型" _
, "細明體_HKSCS", "細明體", "細明體_HKSCS-ExtB", "細明體-ExtB", _
"教育部隸書", _
_
"64卦圖", "行書", _
"小篆", "甲骨文", "金文", "隸書", "文鼎隸書B", "文鼎隸書DB", "文鼎隸書HKM", "文鼎隸書M", _
"華康行書體", "文鼎行楷L", "DFGGyoSho-W7", "DFPGyoSho-W7", "DFPOYoJun-W5", "DFPPenJi-W4", _
"文鼎魏碑B", "文鼎行楷碑體B", "文鼎鋼筆行楷M", _
_
"FangSong", "Adobe 仿宋 Std R", "文鼎仿宋B", "文鼎仿宋L", _
"教育部標準楷書", "Adobe 楷体 Std R", "KaiTi", "文鼎標準楷體ProM", _
"文鼎顏楷H", "文鼎顏楷U", "文鼎毛楷B", "文鼎毛楷EB", "文鼎毛楷H", _
"DFMinchoP-W5", _
"DFGothicP-W5", _
"DFGKanTeiRyu-W11", "文鼎古印體B", _
"文鼎雕刻體B", "DFKinBun-W3", _
"DFGFuun-W7", _
_
"華康行書體(P)", "DFPFuun-W7", "DFGyoSho-W7") '華康行書體(P)以下為沒必要做的
End Sub