?? form1.frm
字號:
FieldStr1 As String ' 節(jié)點(diǎn)內(nèi)容一
FieldStr2 As String ' 節(jié)點(diǎn)內(nèi)容二
FieldDelFlag As Boolean ' 刪除標(biāo)志
End Type
Private Type AdobeFontRec ' 小節(jié)結(jié)構(gòu)類型。
SubID As Long ' 節(jié)點(diǎn)ID，數(shù)組號，可用于排序中
SubStart As String ' 開始標(biāo)記
SubEnd As String ' 結(jié)束標(biāo)記
SubField() As AdobeField ' 節(jié)點(diǎn)內(nèi)容結(jié)構(gòu)數(shù)組
SubDelFlag As Boolean ' 節(jié)點(diǎn)刪除標(biāo)記
SubModiFied As Boolean ' 節(jié)點(diǎn)修改標(biāo)記
End Type
Private Type AdobeFontFile ' 創(chuàng)建 Adobe 字體文件結(jié)構(gòu)。
FontFileName As String ' 文件名
FileStart As String ' 文件開始標(biāo)記
FileEnd As String ' 文件結(jié)束標(biāo)記
FileField() As AdobeFontRec ' 節(jié)點(diǎn)結(jié)構(gòu)數(shù)組
FileDelFlag As Boolean ' 文件刪除標(biāo)記
End Type
Dim FFile As AdobeFontFile
Private Sub Cb_Click()
Dim i As Long
Dim FoundPos As Long
Dim FoundLine As Long
'查找 TextBox 控件中指定的文本。
FoundPos = RTBox.Find("WinName:" & Trim(Cb.List(Cb.ListIndex)), 0, LenB(RTBox.Text) - 1, rtfWholeWord)
RTBox.SelColor = vbRed
For i = 0 To UBound(FFile.FileField(Cb.ListIndex + 1).SubField)
Select Case FFile.FileField(Cb.ListIndex + 1).SubField(i).FieldName
Case "FontName"
Text2(1).Text = FFile.FileField(Cb.ListIndex + 1).SubField(i).FieldStr1
Case "FontType"
Text2(2).Text = FFile.FileField(Cb.ListIndex + 1).SubField(i).FieldStr1
Case "FamilyName"
Text2(0).Text = FFile.FileField(Cb.ListIndex + 1).SubField(i).FieldStr1
Case "FileLength"
Text2(3).Text = FFile.FileField(Cb.ListIndex + 1).SubField(i).FieldStr1
Case Else
'WinName
'Handler
'StyleName
'WeightClass
'WidthClass
'AngleClass
'FullName
'WritingScript
'FamilyNameNative
'StyleNameNative
'FullNameNative
End Select
Next i
CurId = Cb.ListIndex + 1
Check1.Value = IIf(FFile.FileField(Cb.ListIndex + 1).SubModiFied = True, 1, 0)
'根據(jù)是否找到文 本，顯示相應(yīng)的消息。
'If FoundPos <> -1 Then
'返回已找到文本所在行的行號。
'FoundLine = RTBox.GetLineFromChar(FoundPos)
'MsgBox "Word found on line " & CStr(FoundLine)
'Else
' MsgBox "Word not found."
'End If
End Sub
Private Sub Check1_Click()
Dim i As Long, j As Long
If Check1.Value = 1 Then '生效
If j <> -1 Then
For i = 0 To UBound(FFile.FileField(CurId).SubField)
Select Case FFile.FileField(CurId).SubField(i).FieldName
Case "FontName"
FFile.FileField(CurId).SubField(i).FieldStr1 = Text2(1).Text
Case "FamilyName"
FFile.FileField(CurId).SubField(i).FieldStr1 = Text2(0).Text
Case Else
'Handler
'StyleName
'WeightClass
'WidthClass
'AngleClass
'FullName
'WritingScript
'FamilyNameNative
'StyleNameNative
'FullNameNative
End Select
Next i
FFile.FileField(CurId).SubModiFied = True
'RTBList FFile
End If
Else
End If
End Sub
Private Sub Check2_Click()
Dim i As Long
If Check2.Value = 1 Then
For i = 0 To Text2.Count - 1
Text2(i).Locked = False
If i < 2 Then Text2(i).Enabled = True
Next i
Else
For i = 0 To Text2.Count - 1
Text2(i).Enabled = False
Text2(i).Locked = True
Next i
'Check1.Enabled = False
End If
End Sub
Private Sub Command1_Click()
Dim con As Integer
Dim ErrBool As Boolean
Dim temp() As String ' As Byte
Dim Subs() As String
Dim Subss() As String
Call CommonDialogX
If OpenFileSuccess = False Then Exit Sub
CopyFile FileName, Mid(FileName, 1, Len(FileName) - 3) & "ing", 0
Text1.Text = FileName
Open FileName For Binary Access Read As #1 '打開字體文件
Input #1, X
'RTBox.Text = X
'ReDim temp(LenB(X))
'temp = X
DoEvents
temp = Split(X, Chr(10) & Chr(10), -1, vbBinaryCompare)
ReDim Preserve FFile.FileField(UBound(temp) - IIf(temp(UBound(temp)) = "", 1, 0)) '標(biāo)記文件小節(jié)數(shù)
FFile.FontFileName = Right(FileName, Len(FileName) - InStrRev(FileName, "\")) '字體文件名
ProBar.Visible = True
ProBar.Min = 0: ProBar.Max = UBound(temp)
For ii = 0 To UBound(temp) - IIf(temp(UBound(temp)) = "", 1, 0) '使用變量描述數(shù)組元素的元素。
Subs = Split(temp(ii), Chr(10), -1, vbBinaryCompare)
ReDim Preserve FFile.FileField(ii).SubField(UBound(Subs)) ' - IIf(UBound(Subs) = 0, 0, 1))
FFile.FileField(ii).SubID = ii
For jj = 0 To UBound(Subs) '在一個(gè)字體小結(jié)內(nèi)循環(huán)
Subss = Split(Subs(jj), Chr(58), -1, vbBinaryCompare)
'For kk = 0 To UBound(Subss)
If UBound(Subss) = 2 Then
If Subss(0) = "WinName" Then Cb.AddItem Subss(1) & ":" & Subss(2): Cb.ItemData(Cb.NewIndex) = ii
'If CbList(Cb1, Subss(0)) = False Then Cb1.AddItem Subss(0)
FFile.FileField(ii).SubField(jj).FieldName = Subss(0)
FFile.FileField(ii).SubField(jj).FieldStr1 = Subss(1)
FFile.FileField(ii).SubField(jj).FieldStr2 = Subss(2)
ElseIf UBound(Subss) = 1 Then
If Subss(0) = "WinName" Then Cb.AddItem Subss(1)
'If CbList(Cb1, Subss(0)) = False Then Cb1.AddItem Subss(0)
FFile.FileField(ii).SubField(jj).FieldName = Subss(0)
FFile.FileField(ii).SubField(jj).FieldStr1 = Subss(1)
'Next kk
ElseIf UBound(Subss) = 0 Then
If Subss(0) = "%BeginFont" Then ' "小節(jié)開始！"
FFile.FileField(ii).SubStart = Subss(0)
ElseIf Subss(0) = "%EndFont" Then ' "小節(jié)結(jié)束！"
FFile.FileField(ii).SubEnd = Subss(0)
ElseIf Left(Subss(0), 10) = "%!Adobe-Fo" Then ' "文件開始！"
FFile.FileStart = Subss(0)
End If
Else
'Debug.Print "文件被修改！"
End If
xxx = xxx & Subs(jj) & Chr(10)
'''''''''RTBox.Text = RTBox.Text & Subs(jj) & Chr(10)
'RTBox.Text = RTBox.Text & StrConv(Subs(jj), vbUnicode)
Next jj
xxx = xxx & Chr(10)
'''''''''RTBox.Text = RTBox.Text & Chr(10)
ProBar.Value = ii
Next ii
RTBox.Text = MidB(xxx, 1, LenB(xxx) - 1)
xxx = X = ""
Cb.ListIndex = 0
'Cb1.ListIndex = 1
ProBar.Value = 0
ProBar.Visible = False
Command3.Enabled = True
Command1.Enabled = False
Check2.Enabled = True
Cb.Enabled = True
'CbDisply Cb1
DoEvents
'Do While Not EOF(1) '加內(nèi)容及豎標(biāo)題
'Loop
Close #1
Exit Sub
errr:
If Err.Number = 55 Then
MsgBox "文件已打開！", vbOKOnly Or vbInformation, "提示："
End If
Exit Sub 'Resume Next
End Sub
'打開文件子程序，返回 OpenFileSuccess 布爾及 FileName 字符串變量，故應(yīng)用前請定義
Sub CommonDialogX()
With CommonDialog1
On Error GoTo errr
.DialogTitle = "請選定字庫文件："
.CancelError = True
.Filter = "字體文件(*.lst)|*.lst" '|所有文件(*.*)|*.*"
.InitDir = "C:\Program Files\Common Files\Adobe\TypeSpt\"
.ShowOpen
.Flags = cdlOFNHideReadOnly
OpenFileSuccess = True
FileName = .FileName '含有文件路徑
errr:
If Err.Number = cdlCancel Then
OpenFileSuccess = False
Err.Clear
Exit Sub
End If
End With
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Command3_Click()
FileName = Text1.Text
If MsgBox("確定要保存文件？", vbYesNo Or vbInformation, "提示：") = vbYes Then
RTBList FFile
RTBox.SaveFile FileName, rtfText
MsgBox "文件保存完畢！", vbOKOnly Or vbInformation, "提示："
Command3.Enabled = False
End If
End Sub
Private Sub Command4_Click()
Dim FileS As String, i As Long
With CommonDialog1
On Error GoTo errr
.DialogTitle = "請選擇備份字體文件："
.CancelError = True
.Filter = "備份字體文件(*.ing)|*.ing"
.ShowOpen
.Flags = cdlOFNHideReadOnly
FileS = .FileName
.DialogTitle = "請選擇目標(biāo)字體文件："
.CancelError = True
.Filter = "字體文件(*.lst)|*.lst"
.Flags = cdlOFNNoReadOnlyReturn
.ShowSave
'含有文件路徑
i = CopyFile(Mid(FileS, 1, Len(FileS) - 3) & "lst", .FileName, 0)
If i <> 0 Then
MsgBox "文件已恢復(fù)完畢！", vbOKOnly Or vbInformation, "提示："
Command4.Enabled = False
Else
MsgBox "文件未能成功恢復(fù)！", vbOKOnly Or vbInformation, "提示："
End If
errr:
If Err.Number = cdlCancel Then
Err.Clear
Exit Sub
End If
End With
End Sub
Private Sub Command5_Click()
MsgBox " 初涉VB，只求實(shí)用，故沒在界面上下" & vbCrLf & vbCrLf & "功夫，如有不周，敬請告知！" & vbCrLf & vbCrLf & "E-mail：chyuying369@126.com", vbOKOnly Or vbInformation, "關(guān) 于："
End Sub
Private Sub Form_Load()
Me.Caption = "Adobe Premiere 6.5 or Pro 1.5 字體文件修改器"
Command1.Caption = "打開文件"
Command2.Caption = "退 出"
Command3.Caption = "保存文件"
Command4.Caption = "還原文件"
Command5.Caption = "關(guān) 于"
Command3.Enabled = False
RTBox.Text = ""
RTBox.Text = vbCrLf & vbCrLf & " 本工具專為修改 Adobe Premiere 6.5 或者 Adobe Premiere Pro 1.5 中所帶字體文件不能正確顯示中文而作。" _
& vbCrLf & vbCrLf & " 用法：" & vbCrLf & " 1、選擇字體文件（C:\Program Files\Common Files\Adobe\TypeSpt\AdobeFnt07.lst）；" _
& vbCrLf & " 2、點(diǎn)擊保存按鈕即可。" _
& vbCrLf & " 3、您還可以手工修改任意字體的顯示名稱（只要您自己喜歡）---選中〈手工修改〉前面的鉤，再修改，再使〈修改生效〉即可！" _
& vbCrLf & " 4、如果修改后有任何問題，請點(diǎn)擊恢復(fù)按鈕進(jìn)行修復(fù)操作！"
Dim i As Long
For i = 0 To Text2.Count - 1
Text2(i).Text = ""
Text2(i).Enabled = False
Text2(i).Locked = True
Next i
Cb.Clear
Text1.Text = "C:\Program Files\Common Files\Adobe\TypeSpt\AdobeFnt07.lst"
Cb1.Visible = False
Check1.Enabled = False
Check2.Enabled = False
Cb.Enabled = False
ProBar.Visible = False
End Sub
Public Function CbList(CbX As ComboBox, StrL As String) As Boolean
Dim i As Long
For i = 0 To CbX.ListCount
If StrL = CbX.List(i) Then
CbList = True
Exit Function
Else
CbList = False
End If
Next i
End Function
'Public Function CbIndex(CbX As ComboBox, StrL As String) As Long
' Dim i As Long
'
' For i = 0 To CbX.ListCount
' CbIndex = i
' Exit Function
' Else
' CbIndex = -1
' End If
' Next i
'End Function
'Public Function CbDisply(CbX As ComboBox) As Boolean
' Dim i As Long
'
' For i = 0 To CbX.ListCount
' Debug.Print CbX.List(i)
' Next i
'End Function
Private Sub Text2_Change(Index As Integer)
Check1.Enabled = True
End Sub
Private Function RTBList(FFile As AdobeFontFile) As Boolean
Dim i As Long, j As Long, k As Long ', iiii
Dim Strs As String, FieldName As String, FieldName2 As String
RTBox.Text = ""
Strs = Strs & FFile.FileStart & Chr(10) & Chr(10)
For i = 1 To UBound(FFile.FileField)
Strs = Strs & FFile.FileField(i).SubStart & Chr(10)
For j = 1 To UBound(FFile.FileField(i).SubField)
If FFile.FileField(i).SubField(j).FieldName = "FamilyName" Then
FieldName = FFile.FileField(i).SubField(j).FieldStr1
k = j
ElseIf FFile.FileField(i).SubField(j).FieldName = "WinName" Then
FieldName2 = FFile.FileField(i).SubField(j).FieldStr1
End If
Next j
If FieldName <> FieldName2 And Abs(Asc(FieldName2)) > 1000 Then
FieldName = FieldName2
FFile.FileField(i).SubField(k).FieldStr1 = FieldName
'iiii = iiii + 1
End If
For j = 1 To UBound(FFile.FileField(i).SubField) - 1
Strs = Strs & FFile.FileField(i).SubField(j).FieldName & ":" & FFile.FileField(i).SubField(j).FieldStr1 & _
IIf(FFile.FileField(i).SubField(j).FieldStr2 = "", Chr(10), ":" & FFile.FileField(i).SubField(j).FieldStr2 & Chr(10))
Next j
'Debug.Print iiii
Strs = Strs & FFile.FileField(i).SubEnd & Chr(10) & Chr(10)
Next i
RTBox.Text = Strs
End Function
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -