Oscar Sun on SnipSave | Web-based code snippet manager for developers

將PowerPoint簡報檔內的圖片、文字方塊、備忘稿等輸出到MS Word docx文件中 csharp

                    using System;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Drawing;
using System.Linq;
using System.Text;
using System.Threading.Tasks;
using System.Windows.Forms;
using pptx = Microsoft.Office.Interop.PowerPoint;
using docx = Microsoft.Office.Interop.Word;

namespace Export_img_txtbox_memo_in_pptx_to_docx_WindowsFormsApp1
{
    public partial class Form1 : Form
    {
        public Form1()
        {
            InitializeComponent();
        }

        private void Form1_Load(object sender, EventArgs e)
        {
            //預設按鈕
            this.AcceptButton = button1;//https://docs.microsoft.com/zh-tw/dotnet/framework/winforms/controls/how-to-designate-a-windows-forms-button-as-the-accept-button
        }

        private void button1_Click(object sender, EventArgs e)
        {
            //const string s = @"C:\Users\oscar\OneDrive\公用\mis2000lab-ASP\公用\2016_台中科大\WebService_REST精簡版2.pptx";
            string s = textBox1.Text; //@"file:///C:\Users\oscar\Dropbox\「自傳」簡報大綱.pptx";
            if (!System.IO.File.Exists(s.Replace("file:///", "").Replace("%20"," ")))
            {
                MessageBox.Show("檔案不存在，請重新操作！", "！！檔案全名（含路徑）有誤！！", MessageBoxButtons.OK, MessageBoxIcon.Error); return;
            };
            docx.Application w = new docx.Application();
            docx.Document d = w.Documents.Add();
            d.ActiveWindow.Visible = true;
            docx.Selection slct = d.ActiveWindow.Selection;
            //if (d.Path!="")
            //{
            //    if (MessageBox.Show("不是新檔，確定繼續？","11", MessageBoxButtons.OKCancel, MessageBoxIcon.Asterisk) == DialogResult.Cancel) return;
            //}
            pptx.Application papp= new pptx.Application();
            pptx.Presentations p = papp.Presentations;
            pptx.Presentation activePresentation = p.Open(s);
            string txt = "";// shapeType = "";
            foreach (pptx.Slide sl in activePresentation.Slides)
            {
                foreach (pptx.Shape sp in sl.Shapes)
                {
                    //shapeType = sp.Name;
                    //if (shapeType.IndexOf("Text") == -1 &&
                    //    shapeType.IndexOf("Title") == -1)//not textframe
                    //                                     //TextBox 、"Text Placeholder"、"Rectangle"
                    if (sp.HasTextFrame == 0)//not textframe//https://docs.microsoft.com/en-us/previous-versions/office/developer/office-2010/ff746607(v=office.14) 
                    {//判斷含不含文字方塊是用Shape的HasTexFrame這個屬性來判斷！
                        Clipboard.Clear();
                        sp.Copy();
                        try
                        {
                            slct.Paste();

                        }
                        catch (Exception)
                        {
                            sp.Copy();
                            //throw;
                        }
                        slct.Collapse(docx.WdCollapseDirection.wdCollapseEnd);
                    }
                    else
                    {
                        txt = sp.TextFrame.TextRange.Text;
                        slct.TypeText(txt);
                        slct.InsertAfter("\n\r");
                        slct.Collapse(docx.WdCollapseDirection.wdCollapseEnd);
                    }

                }
                if (sl.HasNotesPage == Microsoft.Office.Core.MsoTriState.msoTrue)//if (sl.HasNotesPage==-1)
                {
                    if (sl.NotesPage.Shapes.Count > 0)
                        foreach (pptx.Shape item in sl.NotesPage.Shapes)
                        {
                            if (item.HasTextFrame == Microsoft.Office.Core.MsoTriState.msoTrue)
                            {
                                if (item.Name.IndexOf("Slide Number")!=-1)
                                    slct.TypeText("Slide Number: " + item.TextFrame.TextRange.Text);
                                else
                                slct.TypeText(item.TextFrame.TextRange.Text);
                                slct.InsertAfter("\n\r");
                                slct.Collapse(docx.WdCollapseDirection.wdCollapseEnd);
                            }
                        }
                }
            }
            activePresentation.Close();
            papp.Quit(); activePresentation = null; p = null; papp = null;            
            MessageBox.Show("簡報內的圖文已順利匯出到Word文件了!","",MessageBoxButtons.OK,MessageBoxIcon.Information);
            this.Close();
        }

        private void textBox1_Click(object sender, EventArgs e)
        {
            try
            {
                textBox1.Text= Clipboard.GetText();
            }
            catch (Exception)
            {
                return;
                //throw;
            }
        }
    }
}

Word文件在選取處貼上超連結 vbscript

View Snippet

                    Sub 貼上超連結()
On Error GoTo eH
Dim fDataObject As New MSForms.DataObject, adres As String
fDataObject.GetFromClipboard 'initialize the object
adres = fDataObject.GetText
 Selection.Hyperlinks.Add Selection.Range, adres
 Exit Sub
eH:
Select Case Err.Number
    Case Else
        MsgBox Err.Number & Err.Description
End Select
End Sub

Word文件開新視窗到臉書直播區段並且自動插入剪貼簿裡已複製的連結網址 vbscript

View Snippet

                    Sub 開新視窗到臉書直播()
Dim heading  As Paragraph, a, docName As String, s As Integer, docOpened As Boolean
Dim d主控文件 As Document
s = InStr(ActiveDocument.Name, "_子文件")
docName = Mid(ActiveDocument.Name, 1, s - 1) '取得主控文件的檔名
If s Then
    For Each a In Documents
        If a.Name = docName Then '主控文件有開啟
            docOpened = True
            Exit For
        End If
    Next a
    If Not docOpened Then Set d主控文件 = Documents.Open(ActiveDocument.Path & "\" & docName & ".docm")
    With Documents(docName)
        .Activate
        If docOpened Then .Windows.Add
    End With
Else
    Windows.Add
End If

For Each heading In ActiveWindow.Document.Paragraphs
    If heading.Style = "標題 4" And heading.Range = "臉書直播" & Chr(13) Then
        heading.Next.Range.Select
        Selection.Collapse wdCollapseStart
        For Each a In heading.Next.Range.Characters
            If a = Chr(9) Then
                If a.Next.Hyperlinks.Count = 0 Then
                    a.Next.Select '開始選取
                    If Selection.MoveEndUntil(Chr(9), 6) <> 0 Then
                        If VBA.Left(系統處理.GetClipboard(), 43) = "https://www.facebook.com/oscarsun72/videos/" Then _
                            Selection.Hyperlinks.Add Selection.Range, 系統處理.GetClipboard
                            d主控文件.Subdocuments.Expanded = True
                            d主控文件.SaveAs2 d主控文件.FullName
                        Exit Sub
                    End If
                End If
            End If
        Next a
        Exit For
    End If
Next
End Sub

文件字頻 vbscript

View Snippet

                    Sub 文件字頻(xlsxSkip As Boolean)
Dim Char, charText As String, preChar As String _
    , x() As String, xT() As Long, i As Long, j As Long, ds As Date, de As Date     '
'Dim ExcelSheet  As New Excel.Worksheet 'As Object,
'Dim xlApp As Excel.Application, xlBook As Excel.Workbook, xlSheet As Excel.Worksheet
Dim xlApp As Object, xlBook As Object, xlSheet As Object
Dim ReadingLayoutB As Boolean

Static xlsp As String
On Error GoTo ErrH:
'xlsp = "C:\Documents and Settings\Superwings\桌面\"
xlsp = GetDeskDir & "\" 'GetDeskDir() & "\"
If Dir(xlsp) = "" Then xlsp = GetDeskDir 'GetDeskDir ' "C:\Users\Wong\Desktop\" '& Replace(ActiveDocument.Name, ".doc", "") & "字頻.XLS"
'If Dir(xlsp) = "" Then xlsp = "C:\Documents and Settings\Superwings\桌面\" & Replace(ActiveDocument.Name, ".doc", "") & "字頻.XLS"
'xlsp = "C:\Documents and Settings\Superwings\桌面\" & Replace(ActiveDocument.Name, ".doc", "") & "字頻.XLS"
xlsp = InputBox("請輸入存檔路徑及檔名(全檔名,含副檔名)!" & vbCr & vbCr & _
        "預設將以此word文件檔名 + ""字頻.XLSX""字綴,存於桌面上", "字頻調查", xlsp & Replace(ActiveDocument.Name, ".doc", "") & "字頻" & VBA.StrConv(VBA.Time, vbWide) & ".XLSX")
If xlsp = "" Then Exit Sub
'If MsgBox("確定不匯出excel檔？", vbQuestion + vbOKCancel) = vbOK Then xlsxSkip = True

ds = VBA.Timer

'For Each Char In d.Characters
'    If InStr(" 　()：>" & vba.Chr(13) & vba.Chr(10) & vba.Chr(11) & vba.ChrW(12) & vba.Chr(94) & vba.Chr(-23991) & vba.Chr(-24205) & vba.Chr(64), Char) > 0 Or Char = "-" Or Char Like "[a-zA-Z0-9０-９!-*""~""-"")""！-＊]" Then
'        Char.Delete
'    ElseIf InStr(vba.ChrW(-24153) & vba.ChrW(-24152) & vba.Chr(2) & "‧[]〔〕﹝﹞…；,，.。． 　、'""‘’`/\{}｛｝「」『』（）《》〈〉－？！]`‵～", Char) > 0 Then
'        Char.Delete
'    End If
'            'vba.Chr(2)可能是註腳標記
'Next
    
    '先清理文本
Str.clearSymbol d.Range, Str.Symbol_withoutEnter

With d

    For Each Char In d.Characters
        charText = Char
        If InStr("()：>" & VBA.Chr(13) & VBA.Chr(10) & VBA.Chr(11) & VBA.ChrW(12), charText) = 0 And charText <> "-" And Not charText Like "[a-zA-Z0-9０-９]" Then
            'If Not charText Like "[a-z1-9]" & vba.Chr(-24153) & vba.Chr(-24152) & " 　、'""「」『』（）－？！]" Then
'            If InStr(vba.Chr(-24153) & vba.Chr(-24152) & vba.Chr(2) & "‧[]〔〕﹝﹞…；,，.。． 　、'""‘’`\{}｛｝「」『』（）《》〈〉－？！]", charText) = 0 Then
            If InStr(VBA.ChrW(-24153) & VBA.ChrW(-24152) & VBA.Chr(2) & "‧[]〔〕﹝﹞…；,，.。． 　、'""‘’`/\{}｛｝「」『』（）《》〈〉－？！]˙", charText) = 0 Then
            'vba.Chr(2)可能是註腳標記
                If preChar <> charText Then
                    'If UBound(X) > 0 Then
                        If preChar = "" Then 'If IsEmpty(X) Then'如果是一開始
                            GoTo 1
                        ElseIf UBound(Filter(x, charText)) Then ' <> charText Then  '如果尚無此字
1                           ReDim Preserve x(i)
                            ReDim Preserve xT(i)
                            x(i) = charText
                            xT(i) = xT(i) + 1
                            i = i + 1
                        Else
                            GoSub 字頻加一
                        End If
                    'End If
                Else
                    GoSub 字頻加一
                End If
                preChar = Char
            End If
        End If
    Next Char
End With

Dim Doc As New Document, Xsort() As String, U As Long ', xTsort() As Integer, k As Long, so As Long, ww As String
'ReDim Xsort(i) As String ', xtsort(i) as Integer
'ReDim Xsort(d.Characters.Count) As String
If U = 0 Then U = 1 '若無執行「字頻加一:」副程序,若無超過1次的字頻，則　Xsort(xT(j - 1)) = Xsort(xT(j - 1)) & "、" & x(j - 1) & _
                                會出錯：陣列索引超出範圍 2015/11/5

ReDim Xsort(U) As String

If xlsxSkip = False Then
    
    'Set ExcelSheet = CreateObject("Excel.Sheet")
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets(1)
    With xlSheet.Application
        For j = 1 To i
            .Cells(j, 1) = x(j - 1)
            .Cells(j, 2) = xT(j - 1)
            Xsort(xT(j - 1)) = Xsort(xT(j - 1)) & "、" & x(j - 1) 'Xsort(xT(j - 1)) & ww '陣列排序'2010/10/29
        Next j
    End With
    'Doc.ActiveWindow.Visible = False
    'U = UBound(Xsort)
    
    For j = U To 0 Step -1 '陣列排序'2010/10/29
        If Xsort(j) <> "" Then
            With Doc
                If Len(.Range) = 1 Then '尚未輸入內容
                    .Range.InsertAfter "字頻 = " & j & "次：（" & Len(Replace(Xsort(j), "、", "")) & "字）"
                    .Range.Paragraphs(1).Range.Font.Size = 12
                    .Range.Paragraphs(.Paragraphs.Count).Range.Font.Name = "新細明體"
                    .Range.Paragraphs(.Paragraphs.Count).Range.Font.NameAscii = "Times New Roman"
                    '.Range.Paragraphs(1).Range.Font.Bold = True
                Else
                    .Range.InsertParagraphAfter
                    .ActiveWindow.Selection.Range.Collapse Direction:=wdCollapseEnd
                    .Range.InsertAfter "字頻 = " & j & "次：（" & Len(Replace(Xsort(j), "、", "")) & "字）"
                    .Range.Paragraphs(.Paragraphs.Count).Range.Font.Size = 12
                    '.Range.Paragraphs(.Paragraphs.Count).Range.Bold = True
                    .Range.Paragraphs(.Paragraphs.Count).Range.Font.Name = "新細明體"
                    .Range.Paragraphs(.Paragraphs.Count).Range.Font.NameAscii = "Times New Roman"
                End If
                .Range.InsertParagraphAfter
                .ActiveWindow.Selection.Range.Collapse Direction:=wdCollapseEnd
                .Range.Paragraphs(.Paragraphs.Count).Range.Font.Size = 12
    '            .Range.Paragraphs(.Paragraphs.Count).Range.Bold = False
                .Range.InsertAfter Replace(Xsort(j), "、", VBA.Chr(9), 1, 1) 'vba.Chr(9)為定位字元(Tab鍵值)
                .Range.InsertParagraphAfter
                If InStr(.Range.Paragraphs(.Paragraphs.Count).Range, "字頻") = 0 Then
                    .Range.Paragraphs(.Paragraphs.Count - 1).Range.Font.Name = "標楷體"
                Else
                    .Range.Paragraphs(.Paragraphs.Count).Range.Font.Name = "新細明體"
                    .Range.Paragraphs(.Paragraphs.Count).Range.Font.NameAscii = "Times New Roman"
                End If
            End With
        End If
    Next j

End If

With Doc.Paragraphs(1).Range
     .InsertParagraphBefore
     .Font.NameAscii = "times new roman"
    Doc.Paragraphs(1).Range.InsertParagraphAfter
    Doc.Paragraphs(1).Range.InsertParagraphAfter
    Doc.Paragraphs(1).Range.InsertAfter "你提供的文本共使用了" & i & "個不同的字（傳統字與簡化字不予合併）"
End With

Doc.ActiveWindow.Visible = True
'

'U = UBound(xT)
'ReDim Xsort(U) As String, xTsort(U) As Long
'
'i = d.Characters
'For j = 1 To i '用數字相比
'    For k = 0 To U 'xT陣列中每個元素都與j比
'        If xT(k) = j Then
'            Xsort(so) = x(k)
'            xTsort(so) = xT(k)
'            so = so + 1
'        End If
'    Next k
'Next j

'With doc
'    .Range.InsertAfter "字頻=0001"
'    .Range.InsertParagraphAfter
'End With


' Cells.Select
'    Selection.Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
'        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom


'Set ExcelSheet = Nothing'此行會使消失
'Set d = Nothing
de = VBA.Timer
If ReadingLayoutB Then d.ActiveWindow.View.ReadingLayout = Not d.ActiveWindow.View.ReadingLayout
MsgBox "完成！" & vbCr & vbCr & "費時" & VBA.Left(de - ds, 5) & "秒!", vbInformation
If xlsxSkip = False Then
    xlSheet.Application.Visible = True
    xlSheet.Application.UserControl = True
    xlSheet.SaveAs xlsp '"C:\Macros\守真TEST.XLS"
End If
Doc.SaveAs Replace(xlsp, "XLSX", "docx") '分大小寫
'Doc.SaveAs "c:\test1.doc"
'AppActivate "microsoft excel"
Exit Sub
字頻加一:
For j = 0 To UBound(x)
    If x(j) = charText Then
        xT(j) = xT(j) + 1
        If U < xT(j) Then U = xT(j) '記下最高字頻,以便排序(將欲排序之陣列最高元素值設為此,則不會超出陣列.
        '多此一行因為要重複判斷計算好幾次,故效能不增反減''效能還是差不多啦.
        Exit For
    End If
Next j

Return
ErrH:
Select Case Err.Number
    Case 4605 '閱讀模式不能編輯'此方法或屬性無法使用，因為此命令無法在閱讀中使用。
    '    If ActiveWindow.View.SplitSpecial = wdPaneNone Then
    '        ActiveWindow.ActivePane.View.Type = wdNormalView
    '    Else
    '        ActiveWindow.View.Type = wdNormalView
    '    End If
    '    If ActiveWindow.View.SplitSpecial = wdPaneNone Then
    '        ActiveWindow.ActivePane.View.Type = wdPrintView
    '    Else
    '        ActiveWindow.View.Type = wdPrintView
    '    End If
        'Doc.Application.ActiveWindow.View.ReadingLayout
        d.ActiveWindow.View.ReadingLayout = Not d.ActiveWindow.View.ReadingLayout
        Doc.ActiveWindow.View.ReadingLayout = False
        Doc.ActiveWindow.Visible = False
        ReadingLayoutB = True
        Resume
    Case 4198 '指令失敗
    Case Else
        MsgBox Err.Number & Err.Description, vbCritical 'STOP: Resume
        'Resume
        End
    
End Select
End Sub

unicode字元檔名轉換＿避免非Big5字成「?」問號 vbscript

View Snippet

                    Function unicode字元檔名轉換() '以利燒錄與ACDSee存取也.2006/11/21
Dim rst As Recordset, X As String, Y As String, OldName As String, NewName As String
Dim rstFirst As DAO.Recordset
Dim fs, f, fc, fl, i As Long, j As Byte, q As Long
On Error GoTo errH
If P = "" Then P = "D:\Users\ssz3\Downloads\簡反正後上傳" '"W:\Emule\新資料夾"
P = InputBox("請輸入路徑", , P)
If P = "" Then Exit Function
If Dir(P, vbDirectory) = "" Then MsgBox "路徑錯誤！", vbExclamation: Exit Function
Set rst = CurrentDb.OpenRecordset("亂碼檔名轉換用", dbOpenTable)
Set rstFirst = CurrentDb.OpenRecordset("亂碼檔名轉換用_優先", dbOpenTable)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(P)
Set fc = f.files
For Each fl In fc
    OldName = fl.Name
    If InStr(OldName, "  ") Then
        OldName = Replace(OldName, "  ", " ") '2個半形空格直接取代為1個 2017/12/24 臺南極樂寺冬至佛七三時繫念法會圓滿之時、雙溪小築三重別院三時繫念第三時施食圓滿時
        fl.Name = OldName
    End If
    Do Until rst.EOF '先取代不必檢查之字!
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
                If rst("檢查") = False Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            End If
        End If
        rst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    Do Until rstFirst.EOF
        X = rstFirst("須改字"): Y = rstFirst("改成字")
        If InStr(OldName, X) Then
            If rstFirst("檢查") Then
                If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            Else
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
            End If
        End If
        rstFirst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rstFirst.MoveFirst
    Do Until rst.EOF
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
1               If rst("檢查") Then
                    If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                    End If
                Else
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                End If
            End If
        End If
2       rst.MoveNext
    Loop
    If j = 1 Then
'        Name P & "\" & fl.Name As P & "\" & NewName'此法不接受亂碼(unicode)字也
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
Next
rst.Close
CurrentDb.Close
For Each fl In fc '轉換uvz檔名
    If InStr(fl.Name, ".uvz.zip") Then
        fl.Name = Replace(fl.Name, ".uvz.zip", ".uvz")
    End If
Next
MsgBox "完成!!" & vbCr & vbCr & "共有" & q & "種字被取代", vbInformation
Exit Function
errH:
Select Case Err.Number
    Case 7 '記憶體不足'碰到日文或亂碼
        If InStrB(OldName, X) Then
            Resume 1
        Else
            Resume 2
        End If
        
    Case Else
        MsgBox Err.Number & Err.Description
        Stop
        Resume
End Select
End Function
Function unicode字元檔名轉換_Folder() '20190907子資料夾重新命名
Dim rst As Recordset, X As String, Y As String, OldName As String, NewName As String
Dim rstFirst As DAO.Recordset
Dim fs, f, fSubs, fSub, i As Long, j As Byte, q As Long
On Error GoTo errH
If P = "" Then P = "D:\Users\ssz3\Downloads\簡反正後上傳" '"W:\Emule\新資料夾"
P = InputBox("請輸入路徑", , P)
If P = "" Then Exit Function
If Dir(P, vbDirectory) = "" Then MsgBox "路徑錯誤！", vbExclamation: Exit Function
Set rst = CurrentDb.OpenRecordset("亂碼檔名轉換用", dbOpenTable)
Set rstFirst = CurrentDb.OpenRecordset("亂碼檔名轉換用_優先", dbOpenTable)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(P) 'folder
Set fSubs = f.subfolders
For Each fSub In fSubs
    OldName = fSub.Name
    If InStr(OldName, "  ") Then
        OldName = Replace(OldName, "  ", " ") '2個半形空格直接取代為1個 2017/12/24 臺南極樂寺冬至佛七三時繫念法會圓滿之時、雙溪小築三重別院三時繫念第三時施食圓滿時
        fSub.Name = OldName
    End If
    Do Until rst.EOF '先取代不必檢查之字!
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
                If rst("檢查") = False Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            End If
        End If
        rst.MoveNext
    Loop
    If j = 1 Then
        fSub.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    Do Until rstFirst.EOF
        X = rstFirst("須改字"): Y = rstFirst("改成字")
        If InStr(OldName, X) Then
            If rstFirst("檢查") Then
                If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & _
                                            Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            Else
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
            End If
        End If
        rstFirst.MoveNext
    Loop
    If j = 1 Then
        fSub.Name = NewName
        j = 0
    End If
    rstFirst.MoveFirst
    Do Until rst.EOF
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
1               If rst("檢查") Then
                    If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & _
                                        Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                    End If
                Else
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                End If
            End If
        End If
2       rst.MoveNext
    Loop
    If j = 1 Then
'        Name P & "\" & fl.Name As P & "\" & NewName'此法不接受亂碼(unicode)字也
        fSub.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    q = q + unicode字元檔名轉換_subfolderFiles(fSub.Path)
Next
rst.Close
CurrentDb.Close
MsgBox "完成!!" & vbCr & vbCr & "共有" & q & "種字被取代", vbInformation
Exit Function
errH:
Select Case Err.Number
    Case 7 '記憶體不足'碰到日文或亂碼
        If InStrB(OldName, X) Then
            Resume 1
        Else
            Resume 2
        End If
        
    Case Else
        MsgBox Err.Number & Err.Description
        Stop
        Resume
End Select
End Function

Function unicode字元檔名轉換_subfolderFiles(P As String) As Long '子資料夾中的檔案
Dim rst As Recordset, X As String, Y As String, OldName As String, NewName As String
Dim rstFirst As DAO.Recordset
Dim fs, f, fc, fl, i As Long, j As Byte, q As Long
On Error GoTo errH
If P = "" Then Exit Function
If Dir(P, vbDirectory) = "" Then MsgBox "路徑錯誤！", vbExclamation: Exit Function
Set rst = CurrentDb.OpenRecordset("亂碼檔名轉換用", dbOpenTable)
Set rstFirst = CurrentDb.OpenRecordset("亂碼檔名轉換用_優先", dbOpenTable)
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.getfolder(P)
Set fc = f.files
For Each fl In fc
    OldName = fl.Name
    If InStr(OldName, "  ") Then
        OldName = Replace(OldName, "  ", " ") '2個半形空格直接取代為1個 2017/12/24 臺南極樂寺冬至佛七三時繫念法會圓滿之時、雙溪小築三重別院三時繫念第三時施食圓滿時
        fl.Name = OldName
    End If
    Do Until rst.EOF '先取代不必檢查之字!
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
                If rst("檢查") = False Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            End If
        End If
        rst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
    Do Until rstFirst.EOF
        X = rstFirst("須改字"): Y = rstFirst("改成字")
        If InStr(OldName, X) Then
            If rstFirst("檢查") Then
                If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
                End If
            Else
                    NewName = Replace(OldName, X, Y)
                    j = 1: q = q + 1
                    OldName = NewName
            End If
        End If
        rstFirst.MoveNext
    Loop
    If j = 1 Then
        fl.Name = NewName
        j = 0
    End If
    rstFirst.MoveFirst
    Do Until rst.EOF
        X = rst("須改字"): Y = rst("改成字")
        If Not Nz(rst("備註"), "") Like "迅雷*" Then
            If InStr(OldName, X) Then
1               If rst("檢查") Then
                    If MsgBox(Replace(OldName, X, X & "●") & " 是否要改成" & vbCr & Replace(OldName, X, Y & "●"), vbOKCancel + vbExclamation) = vbOK Then
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                    End If
                Else
                        NewName = Replace(OldName, X, Y)
                        j = 1: q = q + 1
                        OldName = NewName
                End If
            End If
        End If
2       rst.MoveNext
    Loop
    If j = 1 Then
'        Name P & "\" & fl.Name As P & "\" & NewName'此法不接受亂碼(unicode)字也
        fl.Name = NewName
        j = 0
    End If
    rst.MoveFirst
Next
rst.Close
CurrentDb.Close
For Each fl In fc '轉換uvz檔名
    If InStr(fl.Name, ".uvz.zip") Then
        fl.Name = Replace(fl.Name, ".uvz.zip", ".uvz")
    End If
Next
'MsgBox "完成!!" & vbCr & vbCr & "共有" & q & "種字被取代", vbInformation
unicode字元檔名轉換_subfolderFiles = q
Exit Function
errH:
Select Case Err.Number
    Case 7 '記憶體不足'碰到日文或亂碼
        If InStrB(OldName, X) Then
            Resume 1
        Else
            Resume 2
        End If
        
    Case Else
        MsgBox Err.Number & Err.Description
        Stop
        Resume
End Select
End Function

← Prev Page Next Page →