アプリ版:「スタンプのみでお礼する」機能のリリースについて

vbsにてファイル名、セル内、シート名の置換ができましたが、図形内テキストの置換方法が分かりません。どなたか置換方法を知りませんか?


Const xlMinimized = -4140 'Excelの定数1
Const xlPart = 2 'Excelの定数2

Dim args, xls, i, file, wb, sheet, newName, newSheet '変数指定

Set args = WScript.Arguments 'ドロップされたファイル
Set xls = CreateObject("Excel.Application") 'Excelオブジェクト
xls.WindowState = xlMinimized '最小化
xls.Visible = True '可視化
For i = 0 To args.Count - 1 'ドロップされたファイルを順に
file = args(i) 'ファイルのフルパス
Set wb = xls.Workbooks.Open(file) 'ブックを開く
For Each sheet In wb.Sheets '開いたブックのシートを順に
xls.DisplayAlerts = False '警告禁止(置換元が無い場合出る警告を禁止する)
newName = Wb.Name 'ファイル名取得

'////////////////////////////////Excel内置換文字///////////////////////////////

sheet.Cells.Replace "0", "0", xlPart, ,1
sheet.Cells.Replace "1", "1", xlPart, ,1
sheet.Cells.Replace "2", "2", xlPart, ,1
sheet.Cells.Replace "3" , "3", xlPart, ,1
sheet.Cells.Replace "4" , "4", xlPart, ,1
sheet.Cells.Replace "5" , "5", xlPart, ,1
sheet.Cells.Replace "6" , "6", xlPart, ,1
sheet.Cells.Replace "7" , "7", xlPart, ,1
sheet.Cells.Replace "8" , "8", xlPart, ,1
sheet.Cells.Replace "9" , "9", xlPart, ,1

'//////////////////////////////ファイル名置換文字//////////////////////////////

newName = Replace(newName, "0", "0")
newName = Replace(newName, "1", "1")
newName = Replace(newName, "2", "2")
newName = Replace(newName, "3" , "3")
newName = Replace(newName, "4" , "4")
newName = Replace(newName, "5" , "5")
newName = Replace(newName, "6" , "6")
newName = Replace(newName, "7" , "7")
newName = Replace(newName, "8" , "8")
newName = Replace(newName, "9" , "9")

'///////////////////////////////シート名置換文字///////////////////////////////

Sheet.Name = Replace(Sheet.Name, "0", "0")
Sheet.Name = Replace(Sheet.Name, "1", "1")
Sheet.Name = Replace(Sheet.Name, "2", "2")
Sheet.Name = Replace(Sheet.Name, "3" , "3")
Sheet.Name = Replace(Sheet.Name, "4" , "4")
Sheet.Name = Replace(Sheet.Name, "5" , "5")
Sheet.Name = Replace(Sheet.Name, "6" , "6")
Sheet.Name = Replace(Sheet.Name, "7" , "7")
Sheet.Name = Replace(Sheet.Name, "8" , "8")
Sheet.Name = Replace(Sheet.Name, "9" , "9")

'/////////////////////////////////////////////////////////////////////////////

Next
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(Wb.path & "\変換済") Then .CreateFolder Wb.path & "\変換済"
End With
Wb.SaveAs (Wb.path & "\変換済\" & newName) '名前をつけて保存
xls.DisplayAlerts = True '警告許可
wb.Close False 'ブックを閉じる
Next
xls.Quit 'Excel終了
WScript.Echo " 駆逐完了 "

質問者からの補足コメント

  • HAPPY

    Excelの文字を纏めて置換するvbsです。主に全角英数字を消し去るために作りたいのです。

      補足日時:2017/02/28 14:17
  • うーん・・・

    VBAを使用する場合、D&Dでまとめて変換する方法を教えていただけると助かります。
    文字数制限の為質問欄では省略しましたが、任意の置換リストを使用したいと思っています。

    No.1の回答に寄せられた補足コメントです。 補足日時:2017/02/28 16:06
  • 「変換.vbs」というVBSファイルに「置換するファイル.xlsx」(複数ファイルでも可)をD&Dすると「置換済」フォルダが自動作成されてその中に任意の文字が置換された「置換するファイル.xlsx」がコピーされる感じです。

    No.2の回答に寄せられた補足コメントです。 補足日時:2017/03/04 01:36
  • 例えば「×」(掛ける記号)→「x」(小文字のX)に置換、「あいことば」→「開けゴマ」に置換というように、必要な置換文字が増えたら追加していける様な形にしたいです。
    カタカナはそのままにしておきたいと考えています。

    No.3の回答に寄せられた補足コメントです。 補足日時:2017/03/04 01:44
  • 大きめのファイルを入れると結構時間はかかりますが、図形内テキストも置換できました。シートのar1、ar2リストでの置換ができていなかったのが惜しいです。ここが解決できると完璧です。

    No.4の回答に寄せられた補足コメントです。 補足日時:2017/03/09 09:12
  • どう思う?

    「(」→「(」、「,」→「,」、「.」→「.」のシート名変換がうまく行きませんでした。
    これは小さいファイルでもだめでした。

    No.5の回答に寄せられた補足コメントです。 補足日時:2017/03/12 00:03
  • 適当なExcelファイル(シート数4、ページ数計4)の変換に数時間かかりましたが、だいたいこの位かかるのでしょうか? 途中でExcelを閉じると
    行:72
    文字:1
    エラー:起動されたオブジェクトはクライアントから切断されました。
    コード:80010108
    ソース:(null)
    という表示が出ます。

    No.6の回答に寄せられた補足コメントです。 補足日時:2017/03/12 23:41
  • 多くの補足失礼します。
    試した所、ファイル名に:が含まれているとエラーが出てしまいました。
    ar1=Array("-"," ","=","(",")","*","?","@","/","×",".",",","#","♯","№","¥",">","<")
    ar2 =Array("-"," ","=","(",")","*","?","@","/","x",".",",","#","#","No.","\",">","<")
    のようにシート名もar1、ar2で設定できるようにしたいです。(これが現在変換したい記号一覧です)
    半角()等でエラーが出る場合は無変換になるようにできますでしょうか。

    No.7の回答に寄せられた補足コメントです。 補足日時:2017/03/13 21:00

A 回答 (8件)

遅くなりました。



ファイル名の「 \ / : * ? " < > | 」について、
>ファイル名に:が含まれているとエラーが出てしまいました。

この文字に対応する半角は、ファイル名には使えませんが、それだけでは済まないようです。おそらく、入れ出しで二重チェックが働くので、難しいことではないかと思います。現状としては、せいぜい、ファイル名をチェックて、そのファイルを弾くことぐらいしか考えていません。

>半角()等でエラーが出る場合は無変換になるようにできますでしょうか。
エラーの出る場所に、

On Error Resume Next

On Error Goto 0
と挟むぐらいしかりませんが、そこまでしてまで、と思ってしまいます。

そうでなければ、ファイル名だけを別に処理するプログラムを考えなくてはなりません。

>シート名もar1、ar2で設定できるようにしたいです

これを大幅にコードを換えるだけの余裕もないし、せめて、Excelがあるのなら、Excelの中で処理すれば、逃げられる部分もあったはずだと思います。

補足の中で、ar1 の記号の中で、すでに処理されているはずのものは、

- = ( ) * ? @ / . , # > <

13個
処理されていないものは、
(全角空白)× ♯ № ¥
この5つ

正規表現
RegEx.Pattern = "([\uFF01-\uFF66]+)" '全角記号対応
この式でサポートされている文字は、

! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9
: ; < = > ? @ A B C D E F G H I J K L M N O P Q R
S T U V W X Y Z [ \ ] ^ _ ` a b c d e f g h i j k
l m n o p q r s t u v w x y z { | } ~ ⦅ ⦆ 。 「 」 、 ・
-------------------

For i = 0 To args.Count - 1 'ドロップされたファイルを順に
file = args(i) 'ファイルのフルパス
On Error Resume Next '<---ここから
Set wb =xlApp.Workbooks.Open(file) 'ブックを開く
If Err.Number <> 0 Then Msgbox "ファイルの処理ができません。"
WScript.Quit
End If
On Error Goto 0 '<-- ここまで
-------------------------------
'Convert DBCS to ansi for BookName
On Error Goto 0  '★
If DoubleByteChk(newName) Then
On Error Resume next  '★★
newName = RegConvert(newName)
On Error Goto 0  '★★★
End If
'元はここにあった、On Error Goto 0 ★を上に繰り上げて
.SaveAs (wbPath & newName) '名前をつけて保存
「vbsで図形内テキストの置換方法」の回答画像8
    • good
    • 0

こんにちは。


一度、念のために、全部のコードを出しておきます。お手数掛けてすみません。

>「(」→「(」、「,」→「,」、「.」→「.」

変更点

範囲を拡大しました。
\uFF01~\uFF66 までは、半角に変換
「(」ff08 .. ok, 「,」ff05 .. ok, 「.」ff0e ...ok
負担軽減のため、ar1, ar2 をpublic 変数にしました。
Keywords(ar1,ar2)は、シート全体に一度に行うことにしました。

----------------
'//Convert DBSC of Excel Book to ansi
Const xlMinimized = -4140 'Excelの定数1
Const xlPart = 2 'Excelの定数2
Const xlCellTypeConstants = 2
Dim args, xlApp, i, file, wb, sh, newName, newSheet '変数指定
Dim UsedRange, wbPath
Dim RegEx
Public ar1
Public ar2
ar1=Array("x","あいことば","yJapan","adabra","山","猫","空")
ar2 =Array("×","開けゴマ","xJapan","magic_word","海","犬","大地" )
If UBound(ar1)<> UBound(ar2) Then MsgBox "Err" :WScript.Quit
Set RegEx = New RegExp
With RegEx
.Global = True: .IgnoreCase = False: .MultiLine = True
End With
Set args = WScript.Arguments 'ドロップされたファイル
Set xlApp = CreateObject("Excel.Application") 'Excelオブジェクト
xlApp.WindowState = xlMinimized '最小化
xlApp.Visible = True '可視化
With xlApp
For i = 0 To args.Count - 1 'ドロップされたファイルを順に
file = args(i) 'ファイルのフルパス
Set wb =xlApp.Workbooks.Open(file) 'ブックを開く
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(wb.Path & "\変換済") Then .CreateFolder wb.Path & "\変換済"
wbPath=wb.Path & "\変換済\"
End With

With wb 'ブックを開く
newName = .Name 'ファイル名取得 (ループの中ではだめです)

xlApp.DisplayAlerts = False
For Each sh In .Worksheets '開いたブックのシートを順に
xlApp.DisplayAlerts = False '警告禁止(置換元が無い場合出る警告を禁止する)
Set UsedRange = sh.UsedRange
'Convert DBCS to ansi in cells of each Sheet
sbListConvert UsedRange
On Error Resume Next
For Each c In UsedRange
If DoubleByteChk(c.value) Then
buf =c.value
' buf =sbListConvert(buf) '' another way execute
buf = RegConvert(buf)
c.value =buf
End If
For Each shp In sh.Shapes 'In Shapes
buf = shp.TextEffect.Text
shp.TextEffect.Text = RegConvert(buf)
buf = shp.TextEffect.Text
shp.TextEffect.Text= sbListConvert(buf)
Next
Next
sbListConvert UsedRange
''Convert DBCS to ansi for Sheet Name
If DoubleByteChk(sh.name) then
sh.name = RegConvert(sh.name)
End If
Next
'Convert DBCS to ansi for BookName
If DoubleByteChk(newName) Then
newName = RegConvert(newName)
End If
On Error Goto 0
.SaveAs (wbPath & newName) '名前をつけて保存
xlApp.DisplayAlerts = True '警告許可
.Close False 'ブックを閉じる
End With
Next
xlApp.Quit 'Excel終了
Set wb = Nothing
Set xlApp = Nothing
End With
WScript.Echo " 駆逐完了 "
WScript.Quit

Function DoubleByteChk(arg)
Dim flg, t
Do Until t >= Len(arg) Or flg
flg = (Asc(Mid(arg, t + 1, 1)) And &HFF00) <> 0
t = t + 1
Loop
DoubleByteChk= flg
End Function

Function RegConvert(arg)
Dim Ms, m, buf
Dim RegEx
Set RegEx = New RegExp
With RegEx
.Global = True: .IgnoreCase = False: .MultiLine = True
End With
RegEx.Pattern = "([\uFF01-\uFF66]+)"
With RegEx
buf = arg
Set Ms = .Execute(buf)
If Ms.Count = 0 Then RegConvert = arg
For Each m In Ms
buf = Replace(buf, m.SubMatches(0), xlApp.WorksheetFunction.Asc(m.SubMatches(0)))
Next
End With
RegConvert = buf
buf =""
End Function
Function sbListConvert(arg)
If CLng(VarType(arg))= 8204 Then
For i=0 To UBound(ar1)
arg.Replace ar1(i),ar2(i),2,1,True,True
Next
Exit Function
ElseIf CLng(VarType(arg))=8 Then 'string
buf= arg
For i=0 To UBound(ar1)
buf =Replace(buf,ar1(i),ar2(i),1,-1,1) 'textcompare
Next
sbListConvert =buf
buf=""
Exit Function
End If
End Function
この回答への補足あり
    • good
    • 0

こんにちは。



>「(」→「(」、「,」→「,」、「.」→「.」のシート名変換がうまく行きません

基本的には、比較の際に、BinaryMode なら置換を可能にしているはずです。
何か、そこらあたりで、かなり難しい問題があったような気がしているのですが、一度、細かくみないとはっきりしません。一両日中に返事を差し上げます。しばしお待ちを。
この回答への補足あり
    • good
    • 0

何度も試してみましたが、シート上で置換ができなかったという現象を発見できずにいます。

ただし、こちらは、あまり大きなファイルではないということです。

ar1=Array("x","あいことば","yJapan","adabra","山","猫","空")
ar2 =Array("×","開けゴマ","xJapan","magic_word","海","犬","大地" )

両方ともコマ数があっていることが条件ですが、文字コードが原因だと、今度は、他の部分も置換されないはずです。

ただ、使用メモリの問題がありますので、大きなファイルで、途中で抜けている可能性はあると思います。

こういうことですと、Excelで行ったほうが、良いのかもしれません。
画像は、Winmergeで差を取りました。左が元ファイル、右が置換後のファイルです。
「vbsで図形内テキストの置換方法」の回答画像5
この回答への補足あり
    • good
    • 0

最初に、とても大事なことですが、万が一、Unicode が交じるようなことがありましたら、メモ帳などで、Unicode に設定しておいてからに貼り付けてください。



また、どのアプリにしても同じですが、複数の単語の置換は、順序があります。
>例えば「×」(掛ける記号)→「x」(小文字のX)に置換、
>「あいことば」→「開けゴマ」に置換というように、

たぶん、おわかりになっているとは思いますが、
>「×」(掛ける記号)→「x」(小文字のX)に置換、
特殊なものから、一般的なものに換えます。
この場合は、×記号 ->x 文字で、正解です。

ar1=Array("×","あいことば","yJapan","adabra")
ar2 =Array("x","開けゴマ","xJapan","magic_word" )
単語の数は、1,2 と必ず同じでないといけません。

また、基本的には長い単語から変えています。そうでない場合は、正規表現置換という方法を使います。

''----------------------------
'//Convert DBSC of Excel Book to ansi
Const xlMinimized = -4140 'Excelの定数1
Const xlPart = 2 'Excelの定数2
Const xlCellTypeConstants = 2
Dim args, xlApp, i, file, wb, sh, newName, newSheet '変数指定
Dim UsedRange, wbPath
Dim RegEx
Set RegEx = New RegExp
With RegEx
.Global = True: .IgnoreCase = False: .MultiLine = True
End With
RegEx.Pattern ="([0-9A-Za-z]+)"

Set args = WScript.Arguments 'ドロップされたファイル
Set xlApp = CreateObject("Excel.Application") 'Excelオブジェクト
xlApp.WindowState = xlMinimized '最小化
xlApp.Visible = True '可視化
With xlApp
For i = 0 To args.Count - 1 'ドロップされたファイルを順に
file = args(i) 'ファイルのフルパス
Set wb =xlApp.Workbooks.Open(file) 'ブックを開く
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(wb.Path & "\変換済") Then .CreateFolder wb.Path & "\変換済"
wbPath=wb.Path & "\変換済\"
End With

With wb 'ブックを開く
newName = .Name 'ファイル名取得 (ループの中ではだめです)

xlApp.DisplayAlerts = False
For Each sh In .Worksheets '開いたブックのシートを順に
xlApp.DisplayAlerts = False '警告禁止(置換元が無い場合出る警告を禁止する)
Set UsedRange = sh.UsedRange
'Convert DBCS to ansi in cells of each Sheet
On Error Resume Next
For Each c In UsedRange
If DoubleByteChk(c.value) Then
buf =c.value
buf = RegConvert(buf)
buf =sbListConvert(buf)
c.value =buf
End If
For Each shp In sh.Shapes 'In Shapes
buf = shp.TextEffect.Text
shp.TextEffect.Text = RegConvert(buf)
buf = shp.TextEffect.Text
shp.TextEffect.Text= sbListConvert(buf)
Next
Next
sbListConvert UsedRange
''Convert DBCS to ansi for Sheet Name
If DoubleByteChk(sh.name) then
sh.name = RegConvert(sh.name)
End If
Next
'Convert DBCS to ansi for BookName
If DoubleByteChk(newName) Then
newName = RegConvert(newName)
End If
On Error Goto 0
.SaveAs (wbPath & newName) '名前をつけて保存
xlApp.DisplayAlerts = True '警告許可
.Close False 'ブックを閉じる
End With
Next
xlApp.Quit 'Excel終了
Set wb = Nothing
Set xlApp = Nothing
End With
WScript.Echo " 駆逐完了 "
WScript.Quit

Function DoubleByteChk(arg)
Dim flg, t
Do Until t >= Len(arg) Or flg
flg = (Asc(Mid(arg, t + 1, 1)) And &HFF00) <> 0
t = t + 1
Loop
DoubleByteChk= flg
End Function
Function RegConvert(arg)
Dim Ms, m, buf
Dim RegEx
Set RegEx = New RegExp
With RegEx
.Global = True: .IgnoreCase = False: .MultiLine = True
End With
RegEx.Pattern = "([0-9A-Za-z]+)"
With RegEx
buf = arg
Set Ms = .Execute(buf)
If Ms.Count = 0 Then RegConvert = arg
For Each m In Ms
buf = Replace(buf, m.SubMatches(0), xlApp.WorksheetFunction.Asc(m.SubMatches(0)))
Next
End With
RegConvert = buf
buf =""
End Function
Function sbListConvert(arg)
ar1=Array("x","あいことば","yJapan","adabra")
ar2 =Array("×","開けゴマ","xJapan","magic_word" )
a =VarType(arg)
If CLng(VarType(arg))= 8204 Then
For i=0 To UBound(ar1)
obj.Replace arg,ar1(i),ar2(i),2,1,True,True
Next
Exit Function
ElseIf CLng(VarType(arg))=8 Then 'string
buf= arg
For i=0 To UBound(ar1)
buf =Replace(buf,ar1(i),ar2(i))
Next
sbListConvert =buf
buf=""
Exit Function
End If
End Function
この回答への補足あり
    • good
    • 0

こんばんは。



>文字数制限の為質問欄では省略しましたが、任意の置換リストを使用したいと
どのようなものになるのか、教えてくだされば、また考えますが、VBSで、こんなに大きなものを作ったのは初めてです。

>主に全角英数字を消し去るために作りたいのです。
c.value = xlApp.WorksheetFunction.Asc(c.value)
で良いと思ったら、正規表現を使うしかありません。

そのままですと、カタカナが半角になってしまうからです。
Basp21 を使えば、便利なのですが……。

それと、xls は、紛らわしいので、xlApp にしました。
それから、VBSでは、strConv は、使えませんので、Excel のワークシート関数を使います。

vbsで図形内テキストの置換方法、もしかしたら、違っているかもしれません。図形のテキストボックスと、図形の四角の中で変換するか試しました。

今回、やってみれば、VBAもVBSも大差はありませんが、これは重すぎますね。

'//Convert DBSC of Excel Book to ansi
Const xlMinimized = -4140 'Excelの定数1
Const xlPart = 2 'Excelの定数2
Const xlCellTypeConstants = 2
Dim args, xlApp, i, file, wb, sh, newName, newSheet '変数指定
Dim UsedRange, wbPath
Dim RegEx
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Global = True: .IgnoreCase = False: .MultiLine = True
End With
RegEx.Pattern ="([0-9A-Za-z]+)" '全角です

Set args = WScript.Arguments 'ドロップされたファイル
Set xlApp = CreateObject("Excel.Application") 'Excelオブジェクト
xlApp.WindowState = xlMinimized '最小化
xlApp.Visible = True '可視化
With xlApp
For i = 0 To args.Count - 1 'ドロップされたファイルを順に
file = args(i) 'ファイルのフルパス
Set wb =xlApp.Workbooks.Open(file) 'ブックを開く
With CreateObject("Scripting.FileSystemObject")
If Not .FolderExists(wb.Path & "\変換済") Then .CreateFolder wb.Path & "\変換済"
wbPath=wb.Path & "\変換済\"
End With

With wb 'ブックを開く
newName = .Name 'ファイル名取得 (ループの中ではだめです)

xlApp.DisplayAlerts = False
For Each sh In .Worksheets '開いたブックのシートを順に
xlApp.DisplayAlerts = False '警告禁止(置換元が無い場合出る警告を禁止する)
Set UsedRange = sh.UsedRange
'Convert DBCS to ansi in cells of each Sheet
On Error Resume Next
For Each c In UsedRange
If DoubleByteChk(c.value) Then
c.value = RegConvert(c.value)
End If
For Each shp In ActiveSheet.Shapes '図の中
buf = shp.TextEffect.Text
shp.TextEffect.Text = RegConvert(buf)
Next

Next
''Convert DBCS to ansi for Sheet Name
If DoubleByteChk(sh.name) then
sh.name = RegConvert(sh.name)
End If
Next
'Convert DBCS to ansi for BookName
If DoubleByteChk(newName) Then
newName = RegConvert(newName)
End If
On Error Goto 0
.SaveAs (wbPath & newName) '名前をつけて保存
xlApp.DisplayAlerts = True '警告許可
.Close False 'ブックを閉じる
End With
Next
xlApp.Quit 'Excel終了
Set wb = Nothing
Set xlApp = Nothing
End With
WScript.Echo " 駆逐完了 "
WScript.Quit

Function DoubleByteChk(arg)
Dim flg, t
Do Until t >= Len(arg) Or flg
flg = (Asc(Mid(arg, t + 1, 1)) And &HFF00) <> 0
t = t + 1
Loop
DoubleByteChk= flg
End Function

Function RegConvert(arg)
Dim Ms, m, buf
Dim RegEx
Set RegEx = CreateObject("VBScript.RegExp")
With RegEx
.Global = True: .IgnoreCase = False: .MultiLine = True
End With
RegEx.Pattern = "([0-9A-Za-z]+)"
With RegEx
Set Ms = .Execute(arg)
If Ms.Count = 0 Then RegConvert = False
buf = arg
For Each m In Ms
buf = Replace(buf, m.SubMatches(0), xlApp.WorksheetFunction.Asc(m.SubMatches(0)))
Next
End With
RegConvert = buf
End Function
この回答への補足あり
    • good
    • 0

「D&Dでまとめて変換する方法」とは、選択範囲のものをあるマクロの実行で一括変換するということでしょうか?


「任意の置換リストを使用したい」とはどこかのシートに置換リストを置いておいてそれに基づいて置換したいということでしょうか?
この回答への補足あり
    • good
    • 0

直接の回答ではありません


VBS ? VBAとは別物ですよね?
VBA ならば 
たとえば、シート名置換文字ならそんな面倒なことは必要ありません。
「Sheet.Name = StrConv(Sheet.Name, vbNarrow)」の1行で済みます。
この回答への補足あり
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!