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

匯出Word圖片-ConsoleApp2-台大說文小篆 csharp

                    using System;
using System.Drawing;
using System.Threading;
using System.Windows.Forms;
using Microsoft.Office.Interop.Word;
using Application = Microsoft.Office.Interop.Word.Application;
// https://stackoverflow.com/questions/12287908/save-pictures-from-word-to-folder-c-sharp
namespace WordDocStats
{
    class Program
    {
        internal const string destpath = @"c:\篆書\";
        //internal const string destpath = "S:\\黃老師工作_守真\\!!!!!字源\\篆書\\";
        // General idea is based on: https://stackoverflow.com/a/7937590/700926
        static void Main()
        {
            // Open a doc file
            //const string f = @"S:\@@@華語文工具及資料@@@\大徐本說文_主控文件\說文卷01-有誤註記(跑程式時發現的).docm";
            const string f = @"c:\篆書\說文卷01-有誤註記(跑程式時發現的).docm";

            var wordApplication = new Application();
            //var document = wordApplication.Documents.Open(@"C:\Users\Username\Documents\document.docx");
            var document = wordApplication.Documents.Open(f);
            document.ActiveWindow.Visible = true;
            
            // For each inline shape, export it to a file
            // By inspection you can see that the first inline shape have index 1 ( and not zero as one might expect )
            for (var i = 1; i <= wordApplication.ActiveDocument.InlineShapes.Count; i++)
            {
               
            
            // closure
            // http://confluence.jetbrains.net/display/ReSharper/Access+to+modified+closure
            var inlineShapeId = i;
                //SaveInlineShapeToFile(inlineShapeId, wordApplication);
            
            // parameterized thread start
            // https://stackoverflow.com/a/1195915/700926
            var thread = new Thread(() => SaveInlineShapeToFile(inlineShapeId, wordApplication));

            // STA is needed in order to access the clipboard
            // https://stackoverflow.com/a/518724/700926
            thread.SetApartmentState(ApartmentState.STA);
            thread.Start();
            thread.Join();
            
        }
            Console.Beep(5000, 1000);
        // Close word
        wordApplication.Quit();
            Console.ReadLine();
        }

        // General idea is based on: https://stackoverflow.com/a/7937590/700926
        protected static void SaveInlineShapeToFile(int inlineShapeId, Application wordApplication)
        {
            // Get the shape, select, and copy it to the clipboard
            var inlineShape = wordApplication.ActiveDocument.InlineShapes[inlineShapeId];
            if (checkthePic(inlineShape) == true)
            {
                Range PRng = inlineShape.Range.Paragraphs[1].Range;
                inlineShape.Select();
                wordApplication.Selection.Copy();
                
                // Check data is in the clipboard
                if (Clipboard.GetDataObject() != null)
                {
                    var data = Clipboard.GetDataObject();

                    // Check if the data conforms to a bitmap format
                    if (data != null && data.GetDataPresent(DataFormats.Bitmap))
                    {
                        // Fetch the image and convert it to a Bitmap
                        var image = (Image)data.GetData(DataFormats.Bitmap, true);
                        var currentBitmap = new Bitmap(image);

                        // Save the bitmap to a file
                        //currentBitmap.Save(@"C:\Users\Username\Documents\" + String.Format("img_{0}.png", inlineShapeId));
                        //currentBitmap.Save(destpath + string.Format("{0}.png",inlineShapeId));
                        currentBitmap.Save(destpath + string.Format("{0}.png", gettheWord(PRng)));
                    }
            }
         }

            bool checkthePic(InlineShape inlineShpe)
            {
                Range isPRng = inlineShpe.Range.Paragraphs[1].Range;                

                if (inlineShpe.Range.Previous().Text == "　" && inlineShpe.Range.Next().Text == "（" && 
                        inlineShpe.Range.End-isPRng.Characters[1].End==6)
                {
                    return true;
                }
                else
                {
                    return false;
                }
            }

            string gettheWord(Range pRng)
            {
                string w="";int i=0;
                do
                {
                    i++;
                    if  (pRng.Characters[i].Text== "（")
                    {
                        if (i > 20)
                        {
                            break;
                        }
                        i++; break;
                    }                    
                } while (true);
                do                    
                    {
                    w = w+pRng.Characters[i].Text ;                    
                    i++;
                    if (i>20)
                    {
                        break;
                    }
                    } while (pRng.Characters[i].Text != "）");
                return  w.Replace("/","／");
            }
        }
    }
}

匯出字圖 vbscript

View Snippet

                    Option Explicit
Sub 匯出字圖()
Dim ip As InlineShapes, d As Document, p As Paragraph, w As String ', d2 As Document
Const f As String = "C:\黃老師工作_守真\!!!!!字源\小篆\"
Dim pic As IPictureDisp 'https://stackoverflow.com/questions/31922261/word-vba-how-to-save-picture-from-image-object-to-file
'Dim MyChart ' As Chart
'https://stackoverflow.com/questions/31922261/word-vba-how-to-save-picture-from-image-object-to-file
'Dim clipboardData As New DataObject
'https://stackoverflow.com/questions/25333558/export-pictures-excel-vba
'https://ithelp.ithome.com.tw/articles/10159745
'https://www.experts-exchange.com/questions/21068673/Saving-Images-from-Word-Documents-Programatically.html
filesystem_checkPathExists f
Set d = ActiveDocument
'Set d2 = Documents.Add
For Each p In d.Paragraphs
    w = "test" 'p.Range
    'p.Range.InlineShapes(1).ConvertToShape
    If p.Range.InlineShapes.Count > 0 And InStr(p.Range, "（") > 0 Then
        'p.Range.InlineShapes(1).Range.CopyAsPicture
        'Set MyChart = d.InlineShapes.AddChart2
        'Set MyChart = d.Shapes.AddChart2(
        'MyChart.ChartArea.Select
        'MyChart.Range.Paste
'        Set MyChart = p.Range.InlineShapes(1)
        'MyChart.Chart.Export f & w & ".png"
        'Set pic = myForm.Image1.Picture
        'stdole.SavePicture pic, f & w & ".png" '"C:\myfile.jpg"
        'p.Range.InlineShapes(1).Range.CopyAsPicture
        p.Range.InlineShapes(1).Select
        Selection.CopyAsPicture
'        d2.Range.Paste
'        d2.InlineShapes(1).Chart.Export f & w & ".png"
        stdole.SavePicture ClipBoard_GetData, f & w & ".png" '"C:\myfile.jpg"
    End If
    'SavePicture
    'https://www.experts-exchange.com/questions/21068673/Saving-Images-from-Word-Documents-Programatically.html
    'https://groups.google.com/forum/#!topic/microsoft.public.word.drawing.graphics/juGgXPzlWxA
    'https://social.msdn.microsoft.com/Forums/office/en-US/e04c24e6-3057-4664-ad35-9bb5967d98e0/saving-embedded-picture-object-as-files?forum=worddev
    'https://social.msdn.microsoft.com/Forums/en-US/df63ed1d-94a7-4748-846b-aa9d26134141/how-do-i-savepicture-in-my-code?forum=isvvba
Next
End Sub
Sub filesystem_checkPathExists(path As String)
Dim fs As Object, x As String, s As Integer
If Right(path, 1) <> "\" Then path = path & "\"
Set fs = CreateObject("scripting.filesystemobject")
s = InStr(path, "\")
Do
    x = Mid(path, 1, InStr(s + 1, path, "\"))
    If x = "" Then Exit Do
    If fs.folderexists(x) = False Then fs.createfolder (x)
    s = InStr(s + 1, path, "\")
Loop
End Sub

檢查可能未標點者、檢查卦名不加書名號 vbscript

View Snippet

                    Option Explicit
Dim cnt As New ADODB.Connection
Const dbF As String = "E:\@@@華語文工具及資料@@@\Macros\說文資料庫原造字取代為系統字參照用.mdb"
Sub 易學書加書名號() '目前不止於易學書
Dim rst As New ADODB.Recordset ', i As Long
Dim d As Document, rng As Range, rText As String
Set d = ActiveDocument
Set rng = d.Range(1, d.Range.End) '只操作指定點之後的文本
'Set rng = d.Range(Selection.End, d.Range.End) '只操作插入點之後的文本
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
'rst.Open "select * from 《易》學書標書名號 where (組別=" & 7 & " or 先後順序 =10000 or 先後順序 =99999) order by 先後順序,ID", cnt  '要取代哪一組格式的文字
rst.Open "select * from 《易》學書標書名號 where (組別=1 or 組別=7 or 組別=8 or 組別=9 or 先後順序 =10000 or 先後順序 =99999) order by 組別,先後順序,ID", cnt  '要取代哪一組格式的文字
Application.ScreenUpdating = False
With rst
    Do Until .EOF
        If InStr(rng.Text, .Fields("須標書名號字詞").Value) > 0 Then
'            i = i + 1
'            If i Mod 20 = 0 Then d.UndoClear
            rng.Find.ClearFormatting
            rng.Find.ClearAllFuzzyOptions
            If VBA.IsNull(.Fields("標成書名號結果").Value) Then
                rText = "《" & .Fields("須標書名號字詞").Value & "》"
            Else
                rText = .Fields("標成書名號結果").Value
            End If
            rng.Find.Execute .Fields("須標書名號字詞").Value, , , , , , True, wdFindStop, , rText, wdReplaceAll
            '若用 wdFindContinue仍會取代前面部分
        End If
        .MoveNext
    Loop
End With
Do While rng.Find.Execute("《《", , , , , , True, wdFindStop, , "《", wdReplaceAll)
Loop
Do While rng.Find.Execute("》》", , , , , , True, wdFindStop, , "》", wdReplaceAll)
Loop
Application.ScreenUpdating = True
Application.ScreenRefresh
Beep
d.Save
'MsgBox "done!", vbInformation
rst.Close: Set rst = Nothing
End Sub
Sub 檢查可能未標點者()
Dim rst As New ADODB.Recordset, d As Document, r As Range, x As String, e As Long
Dim rstPass As New ADODB.Recordset
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
Set d = ActiveDocument
Set r = d.Range
'rst.Open "select * from 《易》學書標書名號 where (組別=1 or 組別=7 or 組別=8 or 組別=9 or 先後順序 =10000 or 先後順序 =99999) order by 組別,先後順序,ID", cnt  '要取代哪一組格式的文字
'rst.Open "《易》學書標書名號", CNT, adOpenKeyset, adLockReadOnly
rst.Open "select * from 《易》學書標書名號 where 組別<>64 and 組別<>2 and 組別<>3 and 組別<>4", cnt, adOpenKeyset, adLockReadOnly
With rst
    Do Until .EOF
        x = .Fields("須標書名號字詞").Value
        If InStr(d.Range, x) > 0 Then
            rstPass.Open "select 略過不標書名號,字長 from 《易》學書標書名號_略過不標者 where instr(略過不標書名號,""" & x & """)>0", cnt, adOpenKeyset, adLockOptimistic
            Set r = d.Range
            r.Find.ClearAllFuzzyOptions: r.Find.ClearFormatting
            Do While r.Find.Execute(x, , , , , , True, wdFindStop)
                If (r.Previous <> "《" And r.Previous <> "·" And r.Previous <> "‧") And (r.Next <> "·" And r.Next <> "》" And r.Next <> "‧") And r.HighlightColorIndex = 0 Then
                    e = r.End
'                    r.Select
'                    Stop
                    chkPass rstPass, r, e, x
                    'If rstPass.RecordCount > 0 Then rstPass.MoveFirst
                    r.SetRange e, d.Range.End
                End If
            Loop
            rstPass.Close
        End If
        .MoveNext
    Loop
End With
MsgBox "done!", vbInformation
End Sub
Function 比對略過不標書名號(rst As ADODB.Recordset, xR As Range) As Boolean
Dim r As Range, l As Byte, i As Integer, ps As Long
Set r = xR: ps = xR.End
With rst
    If rst.RecordCount > 0 Then
        Do Until .EOF
            l = Len(.Fields("略過不標書名號").Value) '擴充漢字，End屬性一樣是算二個長度
            For i = -l To l
                r.SetRange ps + i, ps + i + l
                If StrComp(r.Text, .Fields("略過不標書名號").Value) = 0 Then
                    比對略過不標書名號 = True
                    .MoveFirst
                    Exit Function
                End If
            Next i
            .MoveNext
        Loop
        .MoveFirst
    End If
End With
End Function
Sub 略過不標書名號(rst As ADODB.Recordset, xSelection As Range)
Dim rstp As New ADODB.Recordset
rstp.Open "select 略過不標書名號 from 《易》學書標書名號_略過不標者 where strcomp(略過不標書名號,""" & xSelection & """)=0", cnt, adOpenKeyset, adLockReadOnly
If rstp.RecordCount = 0 Then
    With rst
        .AddNew
        .Fields("略過不標書名號").Value = xSelection
        .Fields("字長").Value = xSelection.Characters.Count
        .Update
        .Requery
    End With
End If
rstp.Close
End Sub


Sub 檢查卦名不加書名號()
Dim rst As New ADODB.Recordset, rstPass As New ADODB.Recordset
Dim d As Document, rng As Range, e As Long, x As String
Set d = ActiveDocument
'Set rng = d.Range(Selection.End, d.Range.End) '只操作插入點之後的文本
Set rng = d.Range(1, d.Range.End) '只操作指定點之後的文本
rng.Find.ClearFormatting
rng.Find.ClearAllFuzzyOptions
If cnt.State = 0 Then cnt.Open "Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=" & dbF
rst.Open "select * from 《易》學書標書名號 where (組別=" & 64 & " ) ", cnt
Application.ScreenUpdating = False

With rst
    Do Until .EOF
        x = .Fields("須標書名號字詞").Value
        If InStr(rng.Text, x) > 0 Then
            rstPass.Open "select 略過不標書名號,字長 from 《易》學書標書名號_略過不標者 where instr(略過不標書名號,""" & x & """)>0", cnt, adOpenKeyset, adLockOptimistic
            Do While rng.Find.Execute(x, , , , , , True, wdFindStop)
                If (rng.Previous = "《" Or rng.Previous = "·" Or rng.Previous = "‧") Or (rng.Next = "·" Or rng.Next = "》" Or rng.Next = "‧") Then
                    rng.Select
                    e = rng.End
                    chkPass rstPass, rng, e, x
                    rng.SetRange e, d.Range.End
                End If
            Loop
            rstPass.Close
        End If
        .MoveNext
        Set rng = d.Range
    Loop
End With
Application.ScreenUpdating = True
Application.ScreenRefresh
Beep
d.Save
MsgBox "done!", vbInformation
rst.Close: Set rst = Nothing
End Sub
Sub chkPass(rstPass As ADODB.Recordset, r As Range, e As Long, findWord As String)
If Not 比對略過不標書名號(rstPass, r) Then
    r.SetRange e - Len(findWord), e
    r.Select: Beep
    Stop
    If Selection.Type <> wdSelectionIP And VBA.Len(Selection.Text) > VBA.Len(findWord) Then 略過不標書名號 rstPass, Selection.Range
End If
End Sub

找出易卦形造字並標紫紅色 vbscript

View Snippet

                    
Sub 找出易卦形造字並標紫紅色()
Dim d As Document, a, d1 As Document, x As String, a1
Set d = ActiveDocument
Set d1 = Documents("易八卦形造字")
x = Replace(d1.Range.Text, Chr(13), "")
For Each a In d.Characters
    If a <> Chr(13) Then
        If InStr(x, a) > 0 And a.HighlightColorIndex <> 5 Then '紫紅色
            a.Select
            Stop
        End If
    End If
Next
MsgBox "OK!", vbInformation
End Sub

抓出易卦形造字 vbscript

View Snippet

                    Sub 抓出易卦形造字()
Dim d As Document, a, d1 As Document, x As String
Dim dnew As Document
Set d = ActiveDocument
Set dnew = Documents.Add
Set d1 = Documents("可能是易卦形造字.docx")
x = d1.Range.Text
For Each a In d.Characters
    If InStr(x, a) > 0 And a.HighlightColorIndex = 5 Then
        If InStr(dnew.Range.Text, a) = 0 Then dnew.Range.InsertAfter a
    End If
Next
End Sub

← Prev Page Next Page →