form1.frm

修改 Adobe Premiere 6.5 或者 Adobe Premiere Pro 1.5 中所带字体文件

        FieldStr1 As String         ' 节点内容一
        FieldStr2 As String         ' 节点内容二
        FieldDelFlag As Boolean     ' 删除标志
End Type

Private Type AdobeFontRec           ' 小节结构类型。
        SubID As Long               ' 节点ID，数组号，可用于排序中
        SubStart As String          ' 开始标记
        SubEnd As String            ' 结束标记
        SubField() As AdobeField    ' 节点内容结构数组
        SubDelFlag As Boolean       ' 节点删除标记
        SubModiFied As Boolean      ' 节点修改标记
End Type
    
Private Type AdobeFontFile          ' 创建 Adobe 字体文件结构。
        FontFileName As String      ' 文件名
        FileStart As String         ' 文件开始标记
        FileEnd As String           ' 文件结束标记
        FileField() As AdobeFontRec ' 节点结构数组
        FileDelFlag As Boolean      ' 文件删除标记
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)
       '根据是否找到文  本，显示相应的消息。
    
       '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))                                   '标记文件小节数
            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) '使用变量描述数组元素的元素。
                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)      '在一个字体小结内循环
                
                    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                 ' "小节开始！"
                            FFile.FileField(ii).SubStart = Subss(0)
                        ElseIf Subss(0) = "%EndFont" Then               ' "小节结束！"
                            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)         '加内容及竖标题
            '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 字符串变量，故应用前请定义
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 = "请选择目标字体文件："
                    .CancelError = True
                    .Filter = "字体文件(*.lst)|*.lst"
                    .Flags = cdlOFNNoReadOnlyReturn
                    .ShowSave
                       '含有文件路径
                  i = CopyFile(Mid(FileS, 1, Len(FileS) - 3) & "lst", .FileName, 0)
                If i <> 0 Then
                    MsgBox "文件已恢复完毕！", vbOKOnly Or vbInformation, "提示："
                    Command4.Enabled = False
                Else
                    MsgBox "文件未能成功恢复！", 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，只求实用，故没在界面上下" & vbCrLf & vbCrLf & "功夫，如有不周，敬请告知！" & vbCrLf & vbCrLf & "E-mail：[e-mail]", vbOKOnly Or vbInformation, "关  于："
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 = "关  于"
    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、点击保存按钮即可。" _
                     & vbCrLf & "    3、您还可以手工修改任意字体的显示名称（只要您自己喜欢）---选中〈手工修改〉前面的钩，再修改，再使〈修改生效〉即可！" _
                     & vbCrLf & "    4、如果修改后有任何问题，请点击恢复按钮进行修复操作！"
    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
'        If StrL = CbX.List(i) Then
'            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