MS-WORDの文書ファイルを読込んでテキスト表示するには？

解決

---

はじめまして、こんにちは。
Delphi 7 Professional で、Word 2000形式のファイルの
テキストを取り出すプログラムを作りたいです。

過去ログ
  Mr.XRAY [HomePage] 2005/03/13(日) 14:10:25
  http://homepage3.nifty.com/m-and-i/tips/readworddoc.htm
を参考に、コードを頂いて加工したのですが、実行しても何も起きませんでした。

あと、この方法以外では、
次の方法でワードを開く所まではいきましたが、
文字の取得(Ctrl+A ,Ctrl+Cでも構いません)を行うコードがわかりませんでした。
    // uses に  ComObj  必要。
    OpenFileName:='C:\文書.doc';
    Word:=CreateOLEObject('Word.Application');
    Word.Visible:=True;
    Word.Documents.Open(OpenFileName);

また、Mr.XRAYさんのコンポをさわってみましたが、
テキスト取りだし方法はわかりませんでした。


色々な方法があるかと思いますが、どんな方法でも構いません。
コーディングの大きな流れ的ヒントでも構いません。
○○を使うのが一番楽だよ、的ヒントでも構いません。

アドバイス、よろしくお願いいたします。

————————————————————————————————————
procedure TForm1.Button1Click(Sender: TObject);
var
  FileName : String;
  F: File;
  WdSrc: array[0..256] of WideChar;
  WdHed: array[0..512] of WideChar;
  Header: array[0..$300] of Byte;
  RtfHeader: array[0..6] of char;
  Txt, Line: string;
  i, rp: integer;
  TxtLen: LongInt;

begin
  FileName:='C:\文書.doc';
  AssignFile(F, filename);
  Reset(F, 1);
  BlockRead(F, RtfHeader, 6);

  RichEdit1.Lines.BeginUpdate;
  RichEdit1.Lines.Clear;
  //---------------------
  RichEdit1.PlainText := True;

  Seek(F, $200);
  BlockRead(F, RtfHeader, 6);
  Seek(F, $200);
  BlockRead(F, Header, $300);
  Seek(F, $200);
  try
    BlockRead(F, WdHed, SizeOf(WdHed));
  except
    ;
  end;

  //---------------------
    // WORD8以降なので、これ
    TxtLen := Header[$4C] + (Header[$4D] shl 8) + (Header[$4E] shl 16)
           + (Header[$4F] shl 24);
    try
      TxtLen := TxtLen * 2;
    except
      ;
    end;
    Seek(F, $600);
    Txt := '';
    for i := 0 to TxtLen div 512 do
    begin
      try
        BlockRead(F, WdSrc, SizeOf(WdSrc));
      except
        Break;
      end;
      // VER8以降の文書はテキストがUNICODEで格納されているので、これを
      // SHIFT-JISに戻す
      Txt := Txt + WideCharToString(WdSrc);
      rp := Pos(#$0D, Txt);
      while rp > 0 do
      begin
        Line := Copy(Txt, 1, rp - 1);
        try
          RichEdit1.Lines.Add(Line);
        except
          MessageDlg('全てを読込めませんでした.', mtWarning, [mbOK], 0);
          RichEdit1.Lines.EndUpdate;
          CloseFile(F);
          Exit;
        end;
        Delete(Txt, 1, rp);
        rp := Pos(#$0D, Txt);
      end;
    end;
    try
      BlockRead(F, WdSrc, TxtLen mod 512);
      // VER8以降の文書はテキストがUNICODEで格納されているので、これを
      // SHIFT-JISに戻す
      Txt := WideCharToString(WdSrc);
      rp := Pos(#$0D, Txt);
      while rp > 0 do
      begin
        Line := Copy(Txt, 1, rp - 1);
        try
          RichEdit1.Lines.Add(Line);
        except
          MessageDlg('全てを読込めませんでした.', mtWarning, [mbOK], 0);
          RichEdit1.Lines.EndUpdate;
          CloseFile(F);
          Exit;
        end;
        Delete(Txt, 1, rp);
        rp := Pos(#$0D, Txt);
      end;
    except
      ;
    end;
  end;
————————————————————————————————————
コード見ていただいてありがとうございました。
正直なところ、元コードから必要と思われる部分だけどコピーしたものです。
行っている内容については、ほとんどの部分が理解できていません。
なのに質問してしまって、すみません。

編集    削除

---

メモリは、文書によってはかなり消費しますが
テキストをとれればなんでもいいのでしたら下記でできます。

スクリプトエディターでもみれますけど
Wordを起動してマクロを記録してコマンドを調べるといいですよ。
下のを実行するとクリップボードに転送します。
あとは、クリップボードからデータひろってくればいいと思います。
閉じるときに残すか聞いてくるので、
クリップボードはクリアしていたほうがいいようです


procedure TForm1.Button1Click(Sender: TObject);
  var
    vWord : Variant;
    Text : string;
begin
  vWord := CreateOLEObject('Word.Application');
  vWord.Visible := True;
  vWord.Documents.Open(Edit1.Text);
  vWord.Selection.WholeStory;
  vWord.Selection.Copy;
  Text := Clipboard.AsText;
  Clipboard.Clear;
  vWord.Quit;
  Memo1.Text := Text;
end;

編集    削除

---

確かに開けないですね…
リンクを参考にしてググッとシンプルにしてみました。
Word2003で動作確認しました。
適切に例外処理を入れてくださいね。

function TForm1.LoadDoc8File(FileName: string):string;
var
  F: File;
  W8ByteA : WideChar;
  WText : Widestring;
  Text  : string;
begin
  AssignFile(F, filename);
  Reset(F, 1);
  Seek(F, $A00);
  repeat
    BlockRead(F, W8ByteA, 2);
    if W8ByteA= WideChar($0D) then
      WText:= WText + #13#10
      else
      WText:= WText + WideChar(W8ByteA);

  until (W8ByteA= '') ;
  Text := WideCharToString(PWideChar(WText));
  CloseFile(F);
  result:=Text;
end;

編集    削除

---

http://homepage3.nifty.com/m-and-i/tips/tipspage.htm

編集    削除

---

スミマセン、半角英数だけの場合の処理してません。
日本語を含む場合のみです。
半角場合は１バイトずつ読み込んでください。
Word2000と2003に違いがあるかどうかは知りません。

編集    削除

---

おっ，ちぃこさんこんにちは．

起動中のワードに限りますが(必要なら非表示に)以下のコードはどうでしょうか．TWordApplicationを使用した例です．ワードを起動して文書を開いて
いるものと仮定しています．

//=============================================================================
//  起動中のワード文書のテキストをテキストファイルに保存
//  ただしテキストボックス等は無視される
//  usesにClipbrdが必要
//=============================================================================
procedure TForm1.Button1Click(Sender: TObject);
var
    AFileName: OleVariant;
    SL : TStringList;
begin
     AFileName :=ChangeFileExt(Application.ExeName,'.txt');
     WordDocument1.Range.Copy;
     SL:=TStringList.Create;
     try
        SL.Text:=Clipboard.AsText;
        SL.SaveToFile(AFileName);
     finally
       SL.Free;
     end;
end;

編集    削除

---

失礼しました．RichEditでしたね．
同じくクリップボード経由です．
動作確認は  Delphi5+ Word2000です．

//========================================================
//  起動中のワード文書のテキストをRichEditに表示
//  ただしテキストボックス等は無視される
//  usesにClipbrdが必要
//========================================================
procedure TForm1.Button1Click(Sender: TObject);
begin
     WordDocument1.Range.Copy;
     RichEdit1.Clear;
     RichEdit1.Text:=Clipboard.AsText;
     Clipboard.Clear;
end;
//========================================================
//  起動中のワード文書のテキストをRichEditに書式付きで表示
//  ただしテキストボックス等は無視される
//  usesにClipbrdが必要
//========================================================
procedure TForm1.Button2Click(Sender: TObject);
begin
     WordDocument1.Range.Copy;
     RichEdit1.Clear;
     RichEdit1.PasteFromClipboard;
     Clipboard.Clear;
end;

編集    削除

---

クリップボードにこだわりましたが，以下でもRichEditにテキストのみ
の表示が可能です．
現在起動中の文書であればいろいろやり方はありそうです．
docファイル内ということであればメラトニンさんの提示したコード
を操作することになるでしょう．

procedure TForm1.Button1Click(Sender: TObject);
begin
     RichEdit1.Text:=WordDocument1.Range.Text;
end;

編集    削除

---

どもどもです。
皆さん、多くのアドバイス、各種手法ありがとうございました。
そして、せっかく皆さんが早くレスくれたのに、
返事が遅くなってしまって、何だかすみませんです。

１．ComObj＋クリップボード                  →Memo  （arisannさん提供）
２．Word無しでも可能                        →Function  （メラトニンさん提供）
３．TWordApplicationコンポ＋クリップボード  →テキストFile（Mr.XRAYさん提供）
４．TWordApplicationコンポ＋クリップボード  →RitchEdit（Mr.XRAYさん提供）
５．TWordApplicationコンポ                  →RitchEdit（Mr.XRAYさん提供）


私としては、理解が全くできていないけどワードが入っていないＰＣでも動く２番を改良し、
全て正常にテキスト化できるようにしてみよう、とググって勉強してみましたが、
成功せずに撃沈・・・。
半角全角混在で４ページくらいあるワードファイルから吸い取った際に、
どうしても何か所か文字化けしちゃうのを治すことができませんでした。

スマートでないけど、クリップボード経由で…と思ったところに、
クリップボードに頼らないアイデア５をいただきましたので、
それができるように、勉強してみます。
じつは・・・WordApplicationを使ってファイルを開く方法がわかっていないんです(^^;;


でもでも、もうゴールが見えてきましたので、解決とさせていただきます。
皆さん、ありがとうございました(^-^)/

編集    削除

---

ぉぉぉ．．．．

ググたら、一発目にでてきました。
Mr.XRAYさんのサイト
http://homepage2.nifty.com/Mr_XRAY/Delphi/plWord/T_BasicCode.htm

Mr.XRAYさん、またまたお世話になります(^-^)
ありがとうございます。

編集    削除

---

ちぃこさん，

http://homepage3.nifty.com/m-and-i/tips/tipspage.htm#readdoc

ここのReadDocをダウンロードして，ReadDoc.pasをコンポーネントと
してインストールして，添付されている DocSampleフォルダ内の
プロジェクトを実行してみて下さい．
ワード文書内のテキストが取得できているようです．
今確認しました．

確認環境
WindowsXP + Delphi5 + Word2000文書

編集    削除

---

最初から↑のほうで示してるのに・・・

編集    削除

---

>最初から↑のほうで示してるのに・・・

ですね．ちぃこさんが気づいていなかったようですので，僭越ながら，
改めて私が具体的なURLを提示させて頂きました．

編集    削除

---

どもどもです。
Wordさん、すみません。
レス書き忘れていました(・・*)ゞポリポリ

Wordさんに教えていただいたページ
過去ログ（Mr.XRAYさん 2005/03/13(日)14:10:25）で知って、トライしたんです。
でも、私の環境ではうまく動かせなくて、
(私なりに)必要と思うところだけを抜き出したのですが、でも動かなかったのです。
それが今回の初稿のコードなのでした（  ．．）ヾポリポリ

Mr.XRAYさん、引き続き調べていただいて、ありがとうございました(^-^)/
そういうわけで、そのコンポは求める結果を得られなかったのです(^^;

編集    削除

---

そのコードはメラトニン同様私も開かないのを確認しています．
後で私が提示したのはコンポーネントの方ですが，そちらはどうでしょう．

編集    削除

---

>そのコードはメラトニン同様私も開かないのを確認しています．

失礼．メラトニンさん．
ちなみに私の場合，すでにMr.が入っていますので，「さん」は不要です．

編集    削除

---

>どうしても何か所か文字化けしちゃうのを治すことができませんでした。
XRAYさんのサンプルでもそうですが、
Text := WideCharToString(PWideChar(WText));
このところでUNICODE->Shift-JISをしているので当然Shift-JISに無い文字は文字化けします。Win2K以降の環境でよければUNICODEのまま保存すれば解決すると思いますが、他にも原因が無いとも言い切れません。
とりあえずどんなDOCファイルのどの文章が文字化けを引き起こすのか調べてみてはいかがでしょうか？
>XRAYさん
別に気にしないでください^^; HP快調ですね！Halbowさん今何してるんだろ？

編集    削除

---

ぅああああ
レスいただいていたのに気付かなかった
スミマセン┏○"ペコ

色々とやってみました。
開発環境：Delphi7 + WinXP 
・Word2002  →撃沈(何も表示されません 涙)
・Word2000  →成功っ♪
・Word6(Word2002からバージョンダウン保存)→最後の行が文字化け

Wordが入っていない環境でも動かせる良さがあるのですが、
自分のメイン環境(Word2002)では何も吸い取ってくれないので、
今回はTWordApplicationコンポでいこうと思います。

XRAYさん、メラトニンさん、色々とありがとうございました〜(^^)

編集    削除

---

ウヌヌ。Word2002が無いです…くやしい。
もし、Word2002ファイルをダウンロード可能にしてくれれば挑戦します。
欲しいのは英語only,日本語短文、日本語長文です。
要はバイナリエディタで開いてテキスト保存されている部位を探すだけですけどね。
テキストの開始位置って2000,2002,2003固定じゃないのかな？？？
ネットで調べても出てるかもしれませんね。後で調べてみます。

編集    削除

---

メラトニンさん、ありがとうございますっ！！

ここに置いておきますです〜
http://www.geocities.jp/chiiko4280/delphi.zip

うらやましいーー
早くそういう挑戦ができるようになりたいです〜
~~~ヾ(〃^∇^)ｏ ファイトォー!!

編集    削除

---

上記ファイルで動作確認しました。
調べたところWord97以降のファイル(Word8形式)であれば全て開けるはずです。
ファイル自体がWord8形式であるかどうかの確認は行っていません。
必要あらばXRAYさんのサンプルと
http://www.wotsit.org/search.asp
ここのDOCフォーマットを参考にしてください。

編集    削除

---

動作しないファイルがあった場合、暫く居つくので連絡ください。

function ExtractText(WordBlockStr: array of Byte):string;
var str:string;
    wstr:WideString;
    wchar:WideChar;
    i:integer;
    isUNICODE,isZero:boolean;
begin
  i:=0;
  isUNICODE:=False;
  isZero   :=False;
  //UNICODE判別
  repeat
    if WordBlockStr[i]>($7F) then
      isUNICODE:=True;
    if (WordBlockStr[i]=$00) and
       (WordBlockStr[i+1]<>$00) then
      isUNICODE:=True;
    if (WordBlockStr[i]=$00) and
       (WordBlockStr[i+1]=$00) then
      isZero:=True;
    inc(i);
  until (isUNICODE=True) or
        (isZero=True) or
        (i >= Length(WordBlockStr));

  if isUNICODE=True then
  //UNICODEの場合
    begin
      wstr:='';
      //何らかの制御ブロック
      if (WordBlockStr[2]=$00) and
         (WordBlockStr[3]=$00) then
         begin
           Result:='';
           exit;
         end;
      for i:=0 to ((Length(WordBlockStr)-1) div 2) do
      begin
        wchar := WideChar(WordBlockStr[i*2]+WordBlockStr[i*2+1]*256);
        if wchar=WideChar($00) then
        begin
          Result:=WideCharToString(PWideChar(wstr));
          exit;
        end;
        if wchar<>WideChar($0D) then
          wstr:=wstr + wchar
          else
          wstr:=wstr + #13#10;
      end;
      Result:=WideCharToString(PWideChar(wstr));
  end else begin
  //ASCIIの場合
    str:='';
    for i:= 0 to Length(WordBlockStr)-1 do
    begin
      if WordBlockStr[i]=$00 then
      begin
        Result:=str;
        exit;
      end;
      if WordBlockStr[i]<>$0D then
        str:=str + Char(WordBlockStr[i])
        else
        str:=str + #13#10;
    end;
    Result:=str;
  end;
end;

function TForm1.LoadDoc8File(FileName: string):string;
var
  F: File;
  str  : string;
  W8Text: array [0..511] of Byte;  //Word文字列ブロック
  fcMin:Longword;                  //Word文字列開始
  fcMac:Longword;                  //Word文字列終了
  spos :Longword;
begin
  str:='';
  AssignFile(F, filename);
  Reset(F, 1);
  //FIB
    //fcMin
    Seek(F,$0218);
    BlockRead(F,fcMin,Sizeof(fcMin));
    //fcMac
    Seek(F,$021C);
    BlockRead(F,fcMac,Sizeof(fcMac));
  spos:= $0200 + fcMin;
  seek(F,spos);
  repeat
    BlockRead(F,W8Text,Sizeof(W8Text));
    str:=str + ExtractText(W8Text);
    spos:=spos + 512;
  until spos >= $0200 + fcMac;
  result:=str;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  //確認
  Memo1.Text:= LoadDoc8File(Edit1.Text);
end;

編集    削除

---

ひぇぇ〜，完璧です．
メラトニンさん，今確認しました．VMWare上のWindowsXP + Word2003です．
(予めWord2003の文書で保存．exeで動作確認)
(そろそろもう少し速いCPUが欲しい!!)

コンパイルはWindowsXP + Delphi5です．

編集    削除

---

補足です。
先ずバグですが、
LoadDoc8Fileの最後にCloseFile(F);が有りません。
あと、ファイルの入出力はAssignFileよりTFileStreamを使った方が早いかもしれません。高速化はまた後ほど挑戦します。
昨日あの後、バージョンチェック方法を色々調べたのですが、完璧な方法がいまいち分かりません。引き続き詮索します。
あとXRAYさん以外にも日本語で解説しているサイトがありました
http://hp.vector.co.jp/authors/VA012149/labo.htm
ここではバージョンチェックを
>0204: Word文書形式のバージョン。
>$C0, $E0, $69以外ならVer8 （Word97）以降。
と書いてあるのですが、この記述については上記リンクにありませんでしたので別の方法を模索中です。

編集    削除

---

うわああああああ、すごいです＠＠
わたしの環境では、問題なく動いています！
ありがとうございます〜！

コンパイルは、WindowsXP + Delphi7 です。

ん・・・あれれ・・・
手持ちのWordファイルをいろいろと読み込んでいた所、
"ファイルの末尾以降を読み込みました"というエラーがでる場合がありました。

う〜ん・・・でも、どういう手順で作成すればそういうファイルになるのかわかりません(×_×;)

▽わかっている(わかっていない)事
・どのバージョン(Word2000/Word2002)で作成したか不明
・最終的にはWord2002作業して保存しているファイルである
・中の文書を全て消しても同じ結果
・全部消した後、Word2002で半角文字入力して保存しても同じ結果
・同様に、全角文字でもダメ。

う〜ん・・・・よくわかりませんが、
とりあえず検体(笑)をアップしますので、お時間ありましたらご確認下さい。

http://www.geocities.jp/chiiko4280/error-word.zip

編集    削除

---

おにーさん。
それはリッチテキストですよ！！！
TRichEditコントロールでLoadFromFileすればテキストを得ることができます。自力で読めないかとフォーマット仕様を読みましたが、タグ大杉です。
テキスト部分だけでもぱっと見ただけでは分かりません。

一応上に書いたソースにdoc,rtf判別ルーチンだけ付けておきました。
ちなみにrtfを解析する気力も時間もありませんです。ハィ。


function CheckVersion(stream:TStream):integer;
var
  header : array [0..7] of Byte;
  version : Byte;
  fcDop   : Longword ;
begin
  //Reset(F, 1);
  stream.Seek(0,soFromBeginning);
  stream.Read(header,Length(header));

  //BlockRead(F,header,Length(header));
  //D0-CF-11-E0-A1-B1-1A-E1
  if (header[0]=$D0) and
     (header[1]=$CF) and
     (header[2]=$11) and
     (header[3]=$E0) and
     (header[4]=$A1) and
     (header[5]=$B1) and
     (header[6]=$1A) and
     (header[7]=$E1)
  then
  begin
     //Doc形式
       stream.Seek($0202,soFromBeginning);
       stream.Read(version,Sizeof(version));
       //showmessage(inttostr(version));
       if version >= 101 then
       begin
         result:=6;
       end else
         Result:=5;
  end else
  if (header[0]=$7B) and
     (header[1]=$5C) and
     (header[2]=$72) and
     (header[3]=$74) and
     (header[4]=$66) and
     (header[5]=$31)
  then
  begin
     //rtf形式
       Result:=0;
  end else
       Result:=-1;
end;

function TForm1.LoadDoc8File(FileName: string; var FormatCode:integer):string;
var
  F: File;
  str  : string;
  W8Text: array [0..511] of Byte;  //Word文字列ブロック
  fcMin:Longword;                  //Word文字列開始
  fcMac:Longword;                  //Word文字列終了
  spos :Longword;
  FS:TFileStream;
begin
  str:='';
  FS:=TFileStream.Create(FileName, fmOpenReadWrite or fmShareDenyNone);

FormatCode :=CheckVersion(FS);
if FormatCode >=6 then
begin
  //FIB
    FS.Seek($0218,soFromBeginning);
    FS.Read(fcMin,Sizeof(fcMin));
    FS.Seek($021C,soFromBeginning);
    FS.Read(fcMac,Sizeof(fcMac));
  spos:= $0200 + fcMin;
  FS.Seek(spos,soFromBeginning);
  repeat
    FS.Read(W8Text,Sizeof(W8Text));
    str:=str + ExtractText(W8Text);
    spos:=spos + 512;
  until spos >= $0200 + fcMac;
  result:=str;
end else
if FormatCode =0 then
begin
  Result:='';
end else
  Result:='';

  FS.Free;
end;

procedure TForm1.Button1Click(Sender: TObject);
var formatCode:integer;
begin
  //確認
  Memo1.Text:= LoadDoc8File(Edit1.Text,formatCode);
  if formatCode=0 then
    showmessage('リッチテキストです');
end;

編集    削除

---

Form1上で行ってよいのであれば
下記のような関数作って

function TForm1.rtf2text(stream:TStream):string;
var RichEdit:TRichEdit;
begin
  RichEdit:=TRichEdit.Create(self);
  RichEdit.Parent:=Form1;
  stream.Seek(0,soFromBeginning);
  RichEdit.Lines.LoadFromStream(stream);
  Result:=RichEdit.Lines.Text;
  RichEdit.Free;
end;

さっき書いた
function TForm1.LoadDoc8File(FileName: string; var FormatCode:integer):string;
内の
if FormatCode =0 then
begin
  Result:=rtf2text(FS); //これに変更
  //Result:='';
end else
すれば一つの関数で読み込めます。

編集    削除

---

RichEdit.Parent:=Form1;
RichEdit.Parent:=self;
同じことです。

編集    削除

---

>それはリッチテキストですよ！！！

ええぇぇえええぇぇ...(  = =) トオイメ
貴重なお時間をさいてしまって、すみませんでした・・・( ・_;)( ;_;)

あと、リッチな場合の対応策まで、
ありがとうございます、完璧なものができました(^▽^)/

編集    削除

---

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

←解決時は質問者本人がここをチェックしてください。