VBScriptで大量のワードファイルをUnicodeテキストとして保存する方法

このQ&Aのポイント
  • VBScriptを使って、フォルダ内にある大量のワードファイルをテキスト保存する方法を知りたいです。
  • テキストボックスやオートシェープの中のテキストも抜き出す方法を教えてください。
  • ワードのファイル拡張子によって、Unicode形式で保存されない問題が発生しています。どうすれば解決できますか?
回答を見る
  • ベストアンサー

VBScript ワードunicodeテキスト保存

大量のワードのファイルをテキスト保存する仕事が入り、フォルダ内にあるワードファイルをテキスト保存し、テキストボックスやオートシェープの中のテキストも抜き出すプログラムを「VBScript」で作りました。 テキスト保存する際、Unicode形式で保存しなければならず、調べると、「SaveAs …, 7」がUnicodeによるテキスト保存だと分かったのですが、実際にやってみると、拡張子が「.rtf」ファイルだけが、Unicodeによるテキスト保存され、「.doc」や「.docx」は、「シフトJIS」保存されてしまいました。 私、何か間違っているのでしょうか? 以下、一応、プログラムをコピーしておきます。 問題の部分は「行13」です。 なお、ワードは「Word2010」です。 01 Option Explicit 02 Public a, b, c, d, e, f, g, h, t, u, v, w, x, y, z 03 Set w = CreateObject("Word.Application") 04 w.Application.DisplayAlerts = False 05 w.Visible = False 06 Set x = CreateObject("Scripting.FileSystemObject") 07 Set y = x.GetFolder(".") 08 For Each a In y.Files 09 b = LCase(x.GetExtensionName(a.Name)) 10 If b = "doc" or b = "docx" or b = "rtf" Then 11 h = x.GetBaseName(a.Name) 12 Set z = w.Documents.Open(y & "\" & a.Name) 13 z.SaveAs y & "\" & h & ".txt", 7 14 z.Close 15 Set z = Nothing 16 End If 17 If b = "docx" Then 18 Set z = w.Documents.Open(y & "\" & a.Name) 19 z.SaveAs y & "\qkza934irs2801wuptc56ynv7bm.doc", 0 20 z.Close 21 Set z = Nothing 22 Set z = w.Documents.Open(y & "\qkza934irs2801wuptc56ynv7bm.doc") 23 Call o 24 z.Close 25 Set z = Nothing 26 x.DeleteFile(y & "\qkza934irs2801wuptc56ynv7bm.doc") 27 ElseIf b = "doc" or b = "rtf" Then 28 Set z = w.Documents.Open(y & "\" & a.Name) 29 Call o 30 z.Close 31 Set z = Nothing 32 End If 33 If f > "" Then 34 Set t = x.CreateTextFile(y & "\TB_" & h & ".txt", True, True) 35 t.Write f 36 t.Close 37 End If 38 Next 39 w.Quit 40 Set z = Nothing 41 Set y = Nothing 42 Set x = Nothing 43 Set w = Nothing 44 MsgBox("Finished!") 45 Sub o 46 f = "" 47 For Each c In w.ActiveDocument.Shapes 48 If c.Type = 1 or c.Type = 17 then 49 Set v = c.TextFrame 50 e = v.TextRange 51 f = f & e 52 Set d = Nothing 53 ElseIf c.Type = 6 Then 54 For Each g In c.GroupItems 55 Set u = g.TextFrame 56 e = u.TextRange 57 f = f & e 58 Set u = Nothing 59 Next 60 End if 61 Next 62 End Sub よろしく、お願いします。

質問者が選んだベストアンサー

  • ベストアンサー
回答No.1

VBScriptについては門外漢なので、どこが問題なのか知りませんが。 WordのVB関連についての参考サイトだけ紹介しますね。 Document.SaveAs メソッド http://msdn.microsoft.com/ja-jp/library/microsoft.office.tools.word.document.saveas.aspx MsoEncoding Enumeration http://msdn.microsoft.com/ja-jp/library/microsoft.office.core.msoencoding.aspx Document.SaveAs2 メソッド http://msdn.microsoft.com/ja-jp/library/ff836084(v=office.15).aspx Word VBA ファイル操作  テキスト・ファイルの文字コード変換 http://makoto-watanabe.main.jp/WordVba_file.html#encode msoEncodingUTF7で指定できませんか?

Prome_Lin
質問者

お礼

ありがとうございます。 教えて頂いたサイトのいくつかは私も調べていく中で、発見していて、その中から、「7」という数字を見つけました。 そして、上記のとおり、「rtf」ファイルでは、実際に「7」だと、「Unicode」のテキストファイルになっているのです。 いろいろ調べて頂き、ありがとうございました。

Prome_Lin
質問者

補足

ありがとうございます! 教えて頂いたサイトを、今一度じっくり見ていると、そこから、「SaveAs」のパラメータの一覧があり、「Encode」のところで「1200」を指定すると、思っていた「UTF-16LE(BOM付き)」に書き出せました。 具体的には、「行13」を 「z.SaveAs y & "\" & h & ".txt", 7,,,,,,,,,,1200」 とすれば良かったのです。 しかし、マイクロソフトの説明などでは、「SaveAs FileName, 7」でUnicodeによるテキスト保存になっているのに…、分かりにくい! なお、ついでに、「65001」がよく使う「UTF-8」だそうです。 すなわち、「1200」のところを「65001」にすると、「UTF-8」でテキスト保存されます。 ありがとうございました。 問題は解決しました。

関連するQ&A

  • VBScript Unicodeテキスト読み書き

    VBScriptで存在するUnicodeテキストファイルを開き、別途、Unicodeテキストファイルを作成し、存在する方のテキストファイルから1行ずつ読み込んで、作成したテキストファイルに、そのまま書き込むだけのプログラムを組みました。 それなのに、新たに出来たテキストファイルは文字化けしてしまっています。 どうすればいいのでしょうか? Option Explicit Dim a, w, x, y, z Set w = CreateObject("Scripting.FileSystemObject") Set x = w.GetFolder(".") Set y = w.OpenTextFile(x & "\Test.txt", 1, True) Set z = w.CreateTextFile(x & "\Result.txt", True, True) Do Until y.AtEndOfLine = True a = y.ReadLine z.WriteLine(a) Loop z.Close y.Close Set z = Nothing Set y = Nothing Set x = Nothing Set w = Nothing MsgBox("Finished!") 元々存在するテキストファイルは、テキストエディタで開いて、間違いなく文字コードが「Unicode」であることは確認していますし、新たに作成されたテキストファイルも、エディタで開くと、文字コードが「Unicode」である旨、表示されています。 元々存在するファイルの中に、「Unicode」文字がたくさん含まれていますので、どうしても、「Unicode」で処理しなければなりません。 もちろん、プログラムは、本当はもっと他のことをするために作るのですが、最初のこの部分でつまづいてしまっています。 お分かりになる方、お教えください。

  • VBScript Excel Workbooks

    全く下らない質問で申し訳ございません。 あくまでも、興味があったので質問しているだけで、 以下のやり方でなくても、やりたいことが実現できることは 分かっているのですが、教えて頂ければ幸いです。 VBScriptで Option Explicit Dim x, y Set x = CreateObject("Excel.Application") Set y = x.Workbooks.Open("D:\Sample.xlsx").Worksheets(1) | x.Workbooks(1).Close x.Quit Set y = Nothing Set x = Nothing 普通は、 Set y = x.Workbooks.Open("D:\Sample.xlsx") Set z = y.Worksheets(1) として、 y.Close とする方が分かりやすいのは分かっているのですが、 あえて、勉強を兼ねて、上記のように記述しました。 私が知りたい疑問は、Excelのファイルを2つ開いた場合です。 Option Explicit Dim x, y, z Set x = CreateObject("Excel.Application") x.Application.DisplayAlerts = False x.Visible = False Set y = x.Workbooks.Open("F:\Sample.xlsx").Worksheets(1) Set z = x.Workbooks.Add().Worksheets(1) z.Range("A1").Value = y.Range("A1").Value x.Workbooks(1).Close x.Workbooks(2).SaveAs("F:\Test_02.xlsx") x.Workbooks(2).Close x.Quit Set z = Nothing Set y = Nothing Set x = Nothing このプログラムで、 Set y = x.Workbooks.Open("F:\Sample.xlsx").Worksheets(1) の行が無ければ、「x.Workbooks(1).Close」もなく、 その下の行は、 x.Workbooks(1).SaveAs("F:\Test_02.xlsx") x.Workbooks(1).Close となり、問題なく「Test_02.xlsx」ファイルが出来ていました。 ファイルを2つ開いたので、「Workbooks(2)」となる、 と思ったのですが、どうやら違うようです。 (「インデックスが有効範囲にありません」というエラーになります) 何度も言いますが、こんなことで悩む必要がないのは 分かっているのですが、何か気になります。 上記のやり方で、Excelのファイルを2つ開いている場合の 2つ目のファイルを閉じる方法を教えてください。 ホント、下らない質問で申し訳ございませんが よろしくお願い致します。 以上

  • VbscriptによるExcelのコピー&ペースト

    いつもお世話になります。 教えて頂きたいのは、 「VBScript」でExcelのセルの内容をコピー&ペーストしても、 オートシェイプなどがペーストされません。 どうすれば、すべての内容をペーストできるでしょうか? (分かりにくい変数名で申し訳ございません) Option Explicit Dim v, w, x, y, z Set v = CreateObject("Excel.Application") Set w = v.Workbooks.Open("E:\Test\Original.xls") Set x = w.Worksheets(1) Set y = v.Workbooks.Open("E:\Test\Result.xls") Set z = y.Worksheets(1) v.Application.DisplayAlerts = False x.Range("A1:U55").Copy z.Range("A1:U55").PasteSpecial(-4104) x.Range("AB1:AF55").Copy z.Range("V1:Z55").PasteSpecial(-4104) y.SaveAs("E:\Test\ResultPaste.xls") y.Close w.Close v.Quit Set z = Nothing Set y = Nothing Set x = Nothing Set w = Nothing Set v = Nothing MsgBox("Finished") 上記のプログラムで、「Original.xls」の内容を 「Result.xls」にコピー&ぺーストしたいのですが、 セル内の文字情報はフォントや文字の大きさ(サイズ)、 セルの表示形式などがちゃんとペーストされたのですが、 「Original.xls」にあるテキストボックスや オートシェイプはペーストされませんでした。 すべての内容をペーストするには、 どうすれば良いでしょうか? よろしくお願い致します。

  • VBScriptでExcel(インデックスが…)

    昨日も質問をしたばかりで、自分でも情けないのですが… (すみません、2つ分からないことがあります。) VBScriptでExcelのファイルの中身を 別のファイルにコピーするプログラムを作りました。 見にくい変数名で申し訳ないのですが、 これを実行すると、17行目で 「インデックスが有効範囲にありません」 というエラーメッセージが出て止まってしまいます。 しかし、ここで「Set」しているファイルは 「Original.xls」というファイルなのですが、 シートは20個あります。 この20個という数は、絶対にあり得ない数で、 読み込み側のファイルのシートは最大で17個ですので、 数が足りないはずはありません。 だいたい、「インデックス…」というのは配列変数と思って 処理しているのでしょうか? 何より、プログラムの最初の方に 「On Error Resume Next」を置くと、 このプログラムの所期の目的である、 読み込んだファイルの中身を 「Original.xls」にペースとして ファイル名をかえて保存する というのは実現できています。 2つ目の問題は、 22行目から24行目で 「Original.xls」の不要なシートを削除しているのですが、 途中に「MsgBox」を置いて、 「s」や「i」の値を調べてみても問題はないのに、 シートが1つしか残りません。 例えば、読み込んだファイルのシートの数が3なら 「s + 1 = 4」ですから、この「For~Next」ループは 「4~20」までの17回実行され、 その間、常に4番目のシートを削除し続け、 結果として、必要な1~3のシートが残るはずなのですが、 常に19個削除されてしまいます。 本来は、「Original.xls」のシートの数は1つにしておいて、 必要な数だけ、その1つのシートをコピーで増やしたかったのですが、 それも分からず、仕方なしにこんなやり方をしました。 やはり、そのやり方でないと、ダメなのでしょうか? 以上、ややこしい質問で申し訳ないのですが、 お分かりの方がおられましたら、お教えください。 Option Explicit '01 Dim d, i, s, t, u, v, w, x, y, z '02 Set t = CreateObject("Scripting.FileSystemObject") '03 Set u = t.GetFolder(".") '04 Set v = CreateObject("Excel.Application") '05 Set w = v.Workbooks.Open(u & "\Result\Original.xls") '06 '07 v.Application.DisplayAlerts = False '08 v.Visible = False '09 '10 For Each d In u.Files '11 If t.GetExtensionName(d.Name) = "xls" Then '12 Set x = v.Workbooks.Open(u & "\" & d.Name) '13 s = x.Worksheets.Count '14 For i = 1 to s '15 Set y = x.Worksheets(i) '16 Set z = w.Worksheets(i) '17 z.Name = y.Name '18 y.Range("A1:U55").Copy z.Range("A1") '19 y.Range("AB1:AF55").Copy z.Range("V1") '20 Next '21 For i = s + 1 to 20 '22 .Worksheets(s + 1).Delete '23 Next '24 x.SaveAs(u & "\o_" & d.Name) '25 w.SaveAs(u & "\Result\" & d.Name) '26 x.Close '27 End If '28 Next '29 '30 v.Quit '31 Set z = Nothing '32 Set y = Nothing '33 Set x = Nothing '34 Set w = Nothing '35 Set v = Nothing '36 Srt u = Nothing '37 Set t = Nothing '38 '39 MsgBox("Finished") '40 よろしく、お願い致します。

  • テキストをUNICODEで記録するには

    現在エクセルVBAで以下のコードを使用してセルから読み込んだデータをテキストファイルに変換するプログラムを使用しています。 今回下記のコードだと文字化けしてしまう文字(韓国語)を扱うことになりました。 エクセルの保存形式を「Unicode」で保存すると問題なくテキストができることがわかりました。 そこで下記のプルグラムで保存形式を「Unicode」で保存する方法を教えてください。 ターゲットになる変数は「text」という変数です。 よろしくお願いします。 Open "x:\文字.txt" For Append As #1 If a = "" Then Print #1, Chr(9); text Else Print #1, Format(a, "@"); Chr(9); intime; "/"; outtime; Chr(9); text No = No + 1 End If Close #1 n = n + 1

  • vbscript ファイル操作

    二つのテキストファイルを行レベルで結合したファイルを 作成しようとしています。 ファイルの最後を越えた入力を行おうとしました。 とエラーが吐き出され、結合したファイルがうまく作成されません。 -vbscritptファイル- dim f, f_a, f_b, f_bu, f_mk, wrtxt set f = createobject("scripting.filesystemobject") set f_a = f.opentextfile("c:\temp\a.txt",1) set f_b = f.opentextfile("c:\temp\b.txt",1) set f_mk = f.createtextfile("c:\temp\result.txt") f_mk.close set wrtxt = f.opentextfile("c:\temp\result.txt",2) do while f_b.atendofstream <> true if not f_a.readline & f_b.readline = "" then wrtxt.writeline(f_a.readline & " " & f_b.readline) else exit do end if loop f_a.close f_b.close   -a.txt- 2008/07/01 9:30 2008/07/02 9:59 2008/07/03 9:35 2008/07/04 9:52 2008/07/08 9:45 2008/07/09 9:47 2008/07/10 9:15 2008/07/11 9:44 2008/07/14 9:44 2008/07/15 9:43 2008/07/16 13:19 2008/07/17 9:45 2008/07/18 9:31 2008/07/22 9:39 2008/07/23 9:28 2008/07/24 9:41 2008/07/25 9:58 2008/07/28 9:29 2008/07/29 9:49 2008/07/30 9:50 2008/07/31 9:21 -b.txt- 2008/07/01 18:25 2008/07/02 19:15 2008/07/03 18:45 2008/07/04 19:16 2008/07/08 18:36 2008/07/09 19:14 2008/07/10 18:46 2008/07/11 21:58 2008/07/14 22:36 2008/07/15 19:42 2008/07/16 18:00 2008/07/17 19:19 2008/07/18 18:16 2008/07/22 19:56 2008/07/23 18:42 2008/07/24 18:38 2008/07/25 21:55 2008/07/28 21:31 2008/07/29 22:23 2008/07/30 20:13 2008/07/31 20:00 期待値 2008/7/1 9:30 2008/7/1 18:25 2008/7/2 9:59 2008/7/2 19:15 2008/7/3 9:35 2008/7/3 18:45 2008/7/4 9:52 2008/7/4 19:16 2008/7/8 9:45 2008/7/8 18:36 2008/7/9 9:47 2008/7/9 19:14 2008/7/10 9:15 2008/7/10 18:46 2008/7/11 9:44 2008/7/11 21:58 2008/7/14 9:44 2008/7/14 22:36 2008/7/15 9:43 2008/7/15 19:42 2008/7/16 13:19 2008/7/16 18:00 2008/7/17 9:45 2008/7/17 19:19 2008/7/18 9:31 2008/7/18 18:16 2008/7/22 9:39 2008/7/22 19:56 2008/7/23 9:28 2008/7/23 18:42 2008/7/24 9:41 2008/7/24 18:38 2008/7/25 9:58 2008/7/25 21:55 2008/7/28 9:29 2008/7/28 21:31 2008/7/29 9:49 2008/7/29 22:23 2008/7/30 9:50 2008/7/30 20:13 2008/7/31 9:21 2008/7/31 20:00 vbscriptを使い出したのは最近のため、どこが悪いのかわかりません。 ご指導よろしくお願い致します。

  • 1行単位のデータをテキストファイルに保存するマクロ

    エクセルに入力済みの連続したデータを1行単位で以下のような内容でテキストファイルを作成し、 かつテキストファイル名を、セルに入力されている文字を使って保存するマクロを作りたいのですが、 どのようにしたら良いのでしょうか?よろしくお願いします。 *エクセルシート (ファイル名:aaa.xls シート名:sheet1 エクセルシートがあるフォルダ名:yyy) _|A |B |C | 1|x |y |z | 2|a1|a2|a3| 3|b1|b2|b3| *テキストファイル(保存するフォルダ名:zzz) ---テキストファイルの内容(ファイル名:a1.txt) x a1 y a2 z a3 --- ---テキストファイルの内容(ファイル名:b1.txt) x b1 y b2 z b3 --- エクセルはExcel2000でWindows2000を使用しております。

  • プログラミングの問題です

    このプログラムは何をするものか詳しく説明しなさい。 100 FOR x=1 TO 100 110 FOR y=x TO 100 120 LET a=x 130 LET b=y 140 DO 150 LET r=MOD(a,b) 160 IF r=0 THEN EXIT DO 170 LET a=b 180 LET b=r 190 LOOP 200 IF b=1 THEN 210 LET z=SQR(x^2+y^2) 220 IF INT(z)=z THEN PRINT x,y,z 230 END IF 240 NEXT y 250 NEXT x プログラムに関して初心者で、120~230(ほとんどですが…)の部分で何をしようとしているのかが分かりません。何か参考になるHPや考え方だけでも教えていただけないでしょうか。

  • 配列表示と間引き

    配列の間引きをを教えて下さい。 下記文を書きました Sub 配列() Dim u As Integer '左 Dim v As Integer '中 Dim w As Integer '右 Dim x As Integer '左 Dim y As Integer '中 Dim z As Integer '右 Dim row As Integer '行カウンタ Dim col As Integer '列カウンタ Dim intSheet As Integer 'シートカウンタ Dim blnNextPage As Boolean '次シートフラグ '初期値セット u = 1 v = 2 w = 3 x = 4 y = 5 z = 5 row = 0 col = 1 intSheet = 1 Do While (1) 'zカウント z = z + 1 If z > 20 Then 'zが20以上ならy+1 y = y + 1 If y > 19 Then 'yが20以上ならx+1 x = x + 1 If x > 18 Then 'xが20以上ならy+1 w = w + 1 If w > 17 Then 'wが20以上ならx+1 v = v + 1 If v > 16 Then 'wが20以上ならx+1 u = u + 1 '終了条件 If (x = 19 And y = 19 And z = 20) Then Exit Do 'v初期化 = x+1 v = u + 1 End If 'w初期化 = y+1 w = v + 1 End If 'x初期化 = x+1 x = w + 1 End If 'y初期化 = y+1 y = x + 1 End If 'z初期化 = y+1 z = y + 1 End If If z > 20 Then Exit Sub '行カウント row = row + 1 If row > 1000 Then '1000で次の列か次のページへ If blnNextPage Then '行・列カウンタ初期化 col = 1 row = 1 '次のシートへ intSheet = intSheet + 1 '次のシートが無い場合は追加 If intSheet > Worksheets.Count Then Sheets.Add After:=Worksheets(Worksheets.Count) End If 'シートをアクティブに Worksheets(intSheet).Select 'フラグ消去 blnNextPage = False Else '次の列へ col = col + 6 row = 1 'blnNextPage = True End If End If If col = 6 * 3 + 1 Then blnNextPage = True End If 'データ表示 Worksheets(intSheet).Range(Chr(64 + col) & row).Cells = u Worksheets(intSheet).Range(Chr(64 + col + 1) & row).Cells = v Worksheets(intSheet).Range(Chr(64 + col + 2) & row).Cells = w Worksheets(intSheet).Range(Chr(64 + col + 3) & row).Cells = x Worksheets(intSheet).Range(Chr(64 + col + 4) & row).Cells = y Worksheets(intSheet).Range(Chr(64 + col + 5) & row).Cells = z Loop End Sub 上記文で表示をしますが、 6列目までの間に3列の連数字の時には表示を行わず、次に移る様にしたいのですが、どうすれば良いでしょうか? 1,2,5,6,10,12はOKです 1,2,3,5,6,10又は1,3,4,5,10,11等3連の数字は表示を行わない。

  • Windows7でVBScriptによるネットワークアダプタの有効/無

    Windows7でVBScriptによるネットワークアダプタの有効/無効を取得 こんにちは。 ネットで情報収集しているのですが、どうも答えがわからずにいます。 どなたかアドバイスをお願い致します。 Windows7でVBScriptを使ってネットワークアダプタの有効/無効を取得し、 テキストファイルに保存したいです。 WindowsXPでは正常に動くのですがWindows7だとエラーが返ってきます。 エラーの原因は、 「if strFolderItem.name = "ネットワーク接続" then」 の所で「strFolderItem.name = "ネットワーク接続"」に該当する ものが一つも無い事が原因のようです。 Xpでは"ネットワーク接続"だったのが7では名称が変わったのか。 それとも、そもそもこのobjApp.Namespace(3)では取得できないのか。 答えがわかりません。 よろしくお願いいたします。 以下、コードです。 '//----------------------------------------- ' ファイル名:test.vbs ' このVBScriptと同じフォルダ内に ' 「NetAdapterCheck.log」という空のファイルを準備した上で実行する。 '変数の宣言を明示的にする Option Explicit '変数の宣言 Dim objApp Dim objCtrPanel Dim objConnection Dim objAdapter Dim strEnable Dim strDisable Dim strFolderName Dim strFolderItem Dim strVerb Dim intCnt Dim objFileSys Dim objOutFile set objApp = createobject("shell.application") set objCtrPanel = objApp.Namespace(3) strEnable = "有効にする(&A)" strDisable = "無効にする(&B)" for each strFolderItem in objCtrPanel.items if strFolderItem.name = "ネットワーク接続" then set objConnection = strFolderItem.getfolder: exit for end if next strFolderName = "" intCnt = 0 for each strFolderItem in objConnection.items set objAdapter = strFolderItem for each strVerb in objAdapter.verbs if strVerb.name = strEnable then intCnt = intCnt + 1 strFolderName = strFolderName & intCnt & "<>" & "無効<>" & strFolderItem.name & vbCrLf elseif strVerb.name = strDisable then intCnt = intCnt + 1 strFolderName = strFolderName & intCnt & "<>" & "有効<>" & strFolderItem.name & vbCrLf end if next next 'ファイルに書き込み Set objFileSys = WScript.CreateObject("Scripting.FileSystemObject") Set objOutFile = objFileSys.OpenTextFile("NetAdapterCheck.log",2) '1=読込、2=上書き、3=追記 objOutFile.WriteLine strFolderName 'テキストファイルのクローズ objOutFile.Close 'オブジェクト破棄 Set objFileSys = Nothing Set objOutFile = Nothing 'オブジェクトの開放 set objApp = nothing set objCtrPanel = nothing set objConnection = nothing set objAdapter = nothing '//-----------------------------

専門家に質問してみよう