指定したセル範囲をUTF-8やEUC-JP等のテキストファイルとして出力するExcelアドイン

ホーム
Office関連, Excel, リボン関連, 公開ソフト
指定したセル範囲をUTF-8やEUC-JP等のテキストファイルとして出力するExcelアドイン

Office関連

2014.12.19

指定したセル範囲をUTF-8やEUC-JP等のテキストファイルとして出力するExcelアドイン

以前この記事で、指定したセル範囲をUTF-8やEUC-JP等のテキストファイルとして出力するExcelマクロのことを書いたのですが、自分でも意外と利用する機会が多く、その都度プロシージャに渡す引数を書き換えたりしていました。

さすがに毎回毎回コードを書き換えるのが面倒臭くなってきたので、UI上からオプションを指定できるように、上記記事のマクロをアドイン化することにしました。

→ アドインファイルのダウンロード

※ アドインの詳しい設定方法は上記ファイル同梱の「readme.pdf」ファイルをご参照ください。

■ 使い方

「文字コード」メニューから、テキストファイルの文字コードを指定します(Shift-JIS(標準)、UTF-8、UTF-16、EUC-JP)。

「区切り文字」メニューから、各項目の区切り文字を指定します(タブ(標準)、カンマ、コロン、セミコロン、バーティカルバー、半角スペース、全角スペース)。

「改行文字」メニューから、各行の改行文字を指定します(CRLF(標準)、CR、LF)。

「セル範囲をテキスト保存」ボタンの下にあるメニューから、各項目を「"」で囲むかどうか指定します(標準では各項目を「"」で囲みます)。

「セル範囲をテキスト保存」ボタンをクリックして、選択中のセル範囲をテキストファイルとして保存します(標準ではCSVファイルとして保存します)。

上記の通り、アドイン化したおかげで大分楽にセル範囲をテキストファイルとして保存できるようになりました。

自分用に適当に作ったアドインなので、動作は不完全かもしれませんが、興味がある方は是非お試しください。

ちなみに、本アドインのコードは下記のようになっています。

■ リボンXML

<?xml version="1.0" encoding="utf-8"?>
<customUI onLoad="rbnRangeToText_onLoad" xmlns="http://schemas.microsoft.com/office/2006/01/customui">
  <ribbon>
    <tabs>
      <tab idMso="TabHome">
        <group id="grpRangeToText" label="セル範囲をテキスト保存">
          <splitButton id="sbnRangeToText" size="large">
            <button id="btnRangeToText" imageMso="SaveSelectionToTableOfContentsGallery" label="セル範囲をテキスト保存" screentip="セル範囲をテキスト保存" supertip="選択中のセル範囲をテキストファイルとして保存します。" onAction="btnRangeToText_onAction" />
            <menu id="mnuQuotes" supertip="各項目を[&quot;]で囲むかどうかを指定します。標準では各項目を[&quot;]で囲みます。">
              <checkBox id="cbxQuotes1" label="各項目を[&quot;]で囲みます。" screentip="[&quot;]囲み" tag="Quotes" supertip="各項目を[&quot;]で囲みます。" getPressed="cbxQuotes_getPressed" onAction="cbxQuotes_onAction" />
              <checkBox id="cbxQuotes2" label="各項目を[&quot;]で囲みません。" screentip="[&quot;]囲み" tag="NoQuotes" supertip="各項目を[&quot;]で囲みません。" getPressed="cbxQuotes_getPressed" onAction="cbxQuotes_onAction" />
            </menu>
          </splitButton>
          <menu id="mnuCharacterSet" imageMso="CharacterBorder" screentip="文字コード" supertip="テキストファイルの文字コードを指定します。標準は「Shift-JIS」です。" itemSize="normal" getLabel="mnuCharacterSet_getLabel">
            <checkBox id="cbxCharacterSet1" label="Shift-JIS" screentip="文字コード" tag="Shift-JIS" supertip="Shift-JIS" getPressed="cbxCharacterSet_getPressed" onAction="cbxCharacterSet_onAction" />
            <checkBox id="cbxCharacterSet2" label="UTF-8" screentip="文字コード" tag="UTF-8" supertip="UTF-8" getPressed="cbxCharacterSet_getPressed" onAction="cbxCharacterSet_onAction" />
            <checkBox id="cbxCharacterSet3" label="UTF-16" screentip="文字コード" tag="UTF-16" supertip="UTF-16" getPressed="cbxCharacterSet_getPressed" onAction="cbxCharacterSet_onAction" />
            <checkBox id="cbxCharacterSet4" label="EUC-JP" screentip="文字コード" tag="EUC-JP" supertip="EUC-JP" getPressed="cbxCharacterSet_getPressed" onAction="cbxCharacterSet_onAction" />
          </menu>
          <menu id="mnuSeparator" imageMso="StylesStyleSeparator" screentip="区切り文字" supertip="区切り文字を指定します。標準は「タブ」です。" itemSize="normal" getLabel="mnuSeparator_getLabel">
            <checkBox id="cbxSeparator1" label="タブ" screentip="区切り文字" tag="タブ" supertip="タブ" getPressed="cbxSeparator_getPressed" onAction="cbxSeparator_onAction" />
            <checkBox id="cbxSeparator2" label="," screentip="区切り文字" tag="," supertip="カンマ" getPressed="cbxSeparator_getPressed" onAction="cbxSeparator_onAction" />
            <checkBox id="cbxSeparator3" label=":" screentip="区切り文字" tag=":" supertip="コロン" getPressed="cbxSeparator_getPressed" onAction="cbxSeparator_onAction" />
            <checkBox id="cbxSeparator4" label=";" screentip="区切り文字" tag=";" supertip="セミコロン" getPressed="cbxSeparator_getPressed" onAction="cbxSeparator_onAction" />
            <checkBox id="cbxSeparator5" label="|" screentip="区切り文字" tag="|" supertip="バーティカルバー" getPressed="cbxSeparator_getPressed" onAction="cbxSeparator_onAction" />
            <checkBox id="cbxSeparator6" label="半角スペース" screentip="区切り文字" tag=" " supertip="半角スペース" getPressed="cbxSeparator_getPressed" onAction="cbxSeparator_onAction" />
            <checkBox id="cbxSeparator7" label="全角スペース" screentip="区切り文字" tag="　" supertip="全角スペース" getPressed="cbxSeparator_getPressed" onAction="cbxSeparator_onAction" />
          </menu>
          <menu id="mnuLineSeparator" imageMso="ParagraphMarks" screentip="改行文字" supertip="改行文字を指定します。標準は「CRLF」です。" itemSize="normal" getLabel="mnuLineSeparator_getLabel">
            <checkBox id="cbxLineSeparator1" label="CRLF" screentip="改行文字" tag="-1" supertip="CRLF" getPressed="cbxLineSeparator_getPressed" onAction="cbxLineSeparator_onAction" />
            <checkBox id="cbxLineSeparator2" label="CR" screentip="改行文字" tag="13" supertip="CR" getPressed="cbxLineSeparator_getPressed" onAction="cbxLineSeparator_onAction" />
            <checkBox id="cbxLineSeparator3" label="LF" screentip="改行文字" tag="10" supertip="LF" getPressed="cbxLineSeparator_getPressed" onAction="cbxLineSeparator_onAction" />
          </menu>
        </group>
      </tab>
    </tabs>
  </ribbon>
</customUI>

■ 標準モジュール

Option Explicit

Private myRibbon As Office.IRibbonUI
Private chkedQuotesID As String
Private chkedCharsetID As String
Private chkedSeparatorID As String
Private chkedLineSeparatorID As String
Private quotes As Boolean
Private charset As String
Private separator As String
Private lineSeparator As Long

Public Sub rbnRangeToText_onLoad(ribbon As IRibbonUI)
  '初期化
  Set myRibbon = ribbon
  chkedQuotesID = "cbxQuotes1" '["]囲みON
  quotes = True
  chkedCharsetID = "cbxCharacterSet1" 'Shift-JIS
  charset = "Shift-JIS"
  chkedSeparatorID = "cbxSeparator1" 'タブ
  separator = vbTab
  chkedLineSeparatorID = "cbxLineSeparator1" 'CRLF
  lineSeparator = -1
End Sub

Public Sub btnRangeToText_onAction(control As IRibbonControl)
  Dim filePath As Variant
  Dim bookName As String
  
  If LCase(TypeName(Application.Selection)) <> "range" Then
    MsgBox "セル範囲を選択してください。", vbExclamation + vbSystemModal
    Exit Sub
  End If
  
  bookName = Application.ActiveWorkbook.Name
  If InStr(bookName, ".") Then bookName = Left(bookName, InStrRev(bookName, ".", -1, vbTextCompare) - 1)
  filePath = Application.GetSaveAsFilename( _
               InitialFileName:=bookName, _
               FileFilter:="CSV ファイル (*.csv),*.csv," & _
                           "TSV ファイル (タブ区切り) (*.tsv),*.tsv," & _
                           "テキスト ファイル (*.txt),*.txt," & _
                           "すべてのファイル (*.*),*.*", _
               FilterIndex:=1, _
               Title:="テキストファイルの保存先指定")
  If filePath <> False Then
    'MsgBox filePath & vbCrLf & charset & vbCrLf & separator & vbCrLf & lineSeparator & vbCrLf & quotes '確認用
    RangeToText target_range:=Application.Selection, _
                file_path:=filePath, _
                character_set:=charset, _
                separator:=separator, _
                line_separator:=lineSeparator, _
                flg_quotes:=quotes
    MsgBox "処理が終了しました。", vbInformation + vbSystemModal
  End If
End Sub

Public Sub mnuCharacterSet_getLabel(control As IRibbonControl, ByRef returnedVal)
  returnedVal = "文字コード：" & charset
End Sub

Public Sub mnuSeparator_getLabel(control As IRibbonControl, ByRef returnedVal)
  Select Case separator
    Case vbTab: returnedVal = "区切り文字：タブ"
    Case " ": returnedVal = "区切り文字：半角スペース"
    Case "　": returnedVal = "区切り文字：全角スペース"
    Case Else: returnedVal = "区切り文字：" & separator
  End Select
End Sub

Public Sub mnuLineSeparator_getLabel(control As IRibbonControl, ByRef returnedVal)
  Select Case lineSeparator
    Case -1: returnedVal = "改行文字：CRLF"
    Case 13: returnedVal = "改行文字：CR"
    Case 10: returnedVal = "改行文字：LF"
    Case Else: returnedVal = "改行文字：" & lineSeparator
  End Select
End Sub

Public Sub cbxQuotes_getPressed(control As IRibbonControl, ByRef returnedVal)
  Select Case control.id
    Case chkedQuotesID: returnedVal = True
    Case Else: returnedVal = False
  End Select
End Sub

Public Sub cbxCharacterSet_getPressed(control As IRibbonControl, ByRef returnedVal)
  Select Case control.id
    Case chkedCharsetID: returnedVal = True
    Case Else: returnedVal = False
  End Select
End Sub

Public Sub cbxSeparator_getPressed(control As IRibbonControl, ByRef returnedVal)
  Select Case control.id
    Case chkedSeparatorID: returnedVal = True
    Case Else: returnedVal = False
  End Select
End Sub

Public Sub cbxLineSeparator_getPressed(control As IRibbonControl, ByRef returnedVal)
  Select Case control.id
    Case chkedLineSeparatorID: returnedVal = True
    Case Else: returnedVal = False
  End Select
End Sub

Public Sub cbxQuotes_onAction(control As IRibbonControl, pressed As Boolean)
  Dim i As Long
  
  chkedQuotesID = control.id
  Select Case control.Tag
    Case "Quotes": quotes = True
    Case "NoQuotes": quotes = False
    Case Else: quotes = True
  End Select
  'MsgBox chkedQuotesID & vbCrLf & "「" & quotes & "」" & vbCrLf & pressed '確認用
  
  'リボン更新
  For i = 1 To 2
    myRibbon.InvalidateControl "cbxQuotes" & CStr(i)
  Next
End Sub

Public Sub cbxCharacterSet_onAction(control As IRibbonControl, pressed As Boolean)
  Dim i As Long
  
  chkedCharsetID = control.id
  charset = control.Tag
  'MsgBox chkedCharsetID & vbCrLf & charset & vbCrLf & pressed '確認用
  
  'リボン更新
  For i = 1 To 4
    myRibbon.InvalidateControl "cbxCharacterSet" & CStr(i)
  Next
  myRibbon.InvalidateControl "mnuCharacterSet"
End Sub

Public Sub cbxSeparator_onAction(control As IRibbonControl, pressed As Boolean)
  Dim i As Long
  
  chkedSeparatorID = control.id
  Select Case control.Tag
    Case "タブ": separator = vbTab
    Case Else: separator = control.Tag
  End Select
  'MsgBox chkedSeparatorID & vbCrLf & "「" & separator & "」" & vbCrLf & pressed '確認用
  
  'リボン更新
  For i = 1 To 7
    myRibbon.InvalidateControl "cbxSeparator" & CStr(i)
  Next
  myRibbon.InvalidateControl "mnuSeparator"
End Sub

Public Sub cbxLineSeparator_onAction(control As IRibbonControl, pressed As Boolean)
  Dim i As Long
  
  chkedLineSeparatorID = control.id
  lineSeparator = CLng(control.Tag)
  'MsgBox chkedLineSeparatorID & vbCrLf & "「" & lineSeparator & "」" & vbCrLf & pressed '確認用
  
  'リボン更新
  For i = 1 To 3
    myRibbon.InvalidateControl "cbxLineSeparator" & CStr(i)
  Next
  myRibbon.InvalidateControl "mnuLineSeparator"
End Sub

Private Sub RangeToText(ByVal target_range As Excel.Range, _
                        ByVal file_path As String, _
                        ByVal character_set As String, _
                        Optional ByVal separator As String = vbTab, _
                        Optional ByVal line_separator As Long = -1, _
                        Optional ByVal flg_quotes As Boolean = True)
  '指定したセル範囲をテキストファイルとして出力
  '----------------------------------------
  'target_range:出力対象セル範囲
  'file_path:出力先のフォルダパス
  'character_set:文字セット(HKEY_CLASSES_ROOT\MIME\Database\Charset 参照)
  'separator:区切り文字
  'line_separator:行区切り文字(adCR:13, adCRLF:-1, adLF:10)
  'flg_quotes:["]で囲むかどうかを指定
  Dim str As String
  Dim i As Long, j As Long
  Const adTypeText = 2
  Const adWriteChar = 0
  Const adWriteLine = 1
  Const adSaveCreateOverWrite = 2
  
  On Error Resume Next
  With CreateObject("ADODB.Stream")
    .Type = adTypeText
    .charset = character_set
    .lineSeparator = line_separator
    .Open
    For i = 1 To target_range.Rows.Count
      For j = 1 To target_range.Columns.Count
        If j = 1 Then
          If flg_quotes = True Then
            str = ChrW(&H22) & target_range(i, j) & ChrW(&H22)
          Else
            str = target_range(i, j)
          End If
        Else
          If flg_quotes = True Then
            str = str & separator & ChrW(&H22) & target_range(i, j).Value & ChrW(&H22)
          Else
            str = str & separator & target_range(i, j).Value
          End If
        End If
      Next
      If i = target_range.Rows.Count Then
        .WriteText str, adWriteChar
      Else
        .WriteText str, adWriteLine
      End If
    Next
    .SaveToFile file_path, adSaveCreateOverWrite
    .Close
  End With
  If Err.Number <> 0 Then
    MsgBox "Err:" & Err.Description, vbCritical + vbSystemModal
    Exit Sub
  End If
  On Error GoTo 0
End Sub