ここから本文です

エクセルマクロにて、「画像の名前をファイル名」にするコードで、日本語のファイ...

ogn********さん

2010/4/2312:51:18

エクセルマクロにて、「画像の名前をファイル名」にするコードで、日本語のファイル名だとエラーになる

お世話になっております。
先日、下記のマクロをアドバイス頂きました。
大変申し訳ありませんが、画像の名前をファイル名にする部分についてアドバイス頂けませんでしょうか。

ファイル名が英&数であれば問題ないのですが、日本語が含まれている場合はエラーになってしまいます。
色々とチャレンジはしてみたのですが、どうしてもうまくいきませんでした・・・・
どのように修正&対処をしたら良いのでしょうか?

-----------------------------------------------------------------

Sub makeThumbnail()
Dim imgFolder As String
Dim sh As Shape
Dim f As String
Dim r As Long
Cells.Clear
Cells.ColumnWidth = 10 'セルの幅設定
Cells.RowHeight = 40 'セルの高さ設定
For Each sh In ActiveSheet.Shapes '全てのシェープについて
If sh.Type = msoPicture Then sh.Delete '画像なら削除
Next
With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ選択ダイアログ
If .Show <> True Then Exit Sub 'キャンセルなら終了
Range("A1").Value = .SelectedItems(1) '画像フォルダ
End With
imgFolder = Range("A1").Value '画像フォルダ
r = 2 '表示行の初期値
f = Dir(imgFolder & "\*.jpg") '最初のjpgファイル取得
Do While f <> "" 'ファイルがある間
Range("A" & r).Value = f 'A列にファイル名
Range("C" & r).Value = f 'C列にファイル名(新たなファイル名(連番)を作らない時用)
With ActiveSheet.Pictures.Insert(imgFolder & "\" & f) '画像を読み込んで
.Left = Range("B" & r).Left '画像の左位置をセルの左位置に
.Top = Range("B" & r).Top '同じく上位置
.Width = Range("B" & r).Width '同じく幅
.Height = Range("B" & r).Height '同じく高さ
.Name = f '画像の名前をファイル名に-----------------------------------ここでエラーになる
End With
r = r + 1 '表示行+1
f = Dir '次のファイル
Loop

End Sub

補足大変申し訳ありません。
日本語という問題ではなく、ファイル名の長さに問題があるようです。
○日本語でもファイル名が短いとOK!
×英数でもファイル名が長いとNG!

長いファイル名、又は、ファイル名の頭5文字程度で対応する方法をアドバイス頂ければ助かります。
すみませんが、よろしくお願いいたします。

閲覧数:
804
回答数:
2

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

hot********さん

2010/4/2406:17:08

以前の質問でその解答を書いた者ですが、シェープの名前をファイル名にすると処理が楽だと思って使ったのですが、nameプロパティが長さに制限があると言う事に気が付かなかったので、他の部分も含めてプログラムを書き直しました。
シェープの名前には情報を持たないようにしましたが、シェープとの対応をセルの値で行うための列を用意しました。
余計な情報を表示しないようにする時は(*1)を有効にして余計な情報を表示しないようにしてください。(この時最初の1回目はボタンの位置が変わるかもしれません)
シート部のVBAは変わりません。
標準モジュール部にコピーしてください。

'読み込みとサムネイル作成
Sub makeThumbnail()
Dim imgFolder As String
Dim sh As Shape
Dim f As String
Dim r As Long
With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ選択ダイアログ
If .Show <> True Then Exit Sub 'キャンセルなら終了
Cells.Clear
Columns("A").ColumnWidth = 10 'A列の幅設定
Cells.RowHeight = 40 'セルの高さ設定
'Columns("B:C").Hidden = True '余計な情報を表示しない場合(*1)
For Each sh In ActiveSheet.Shapes '全てのシェープについて
If sh.Type = msoPicture Then sh.Delete '画像なら削除
Next
Range("A1").Value = .SelectedItems(1) '画像フォルダ
End With
imgFolder = Range("A1").Value '画像フォルダ
r = 2 '表示行の初期値
f = Dir(imgFolder & "\*.jpg") '最初のjpgファイル取得
Do While f <> "" 'ファイルがある間
Range("D" & r).Value = f 'A列にファイル名
Range("E" & r).Value = f 'C列にファイル名(新たなファイル名(連番)を作らない時用)(*2)
Range("E" & r).Value = Format(r - 1, "000.jpg") '連番ファイル名作成(*2)
With ActiveSheet.Pictures.Insert(imgFolder & "\" & f) '画像を読み込んで
.Left = Range("A" & r).Left '画像の左位置をセルの左位置に
.Top = Range("A" & r).Top '同じく上位置
.Width = Range("A" & r).Width '同じく幅
.Height = Range("A" & r).Height '同じく高さ
Range("C" & r).Value = .Name 'C列にPictureオブジェクトの名前
End With
r = r + 1 '表示行+1
f = Dir '次のファイル
Loop
doReform '再整列
End Sub

'再整列と連番作成
Sub doReform()
Dim lastRow As Long
Dim r As Long
lastRow = Range("C" & Rows.Count).End(xlUp).Row 'C列最終行取得
For r = 2 To lastRow '2行目からA列最後まで
Range("B" & r).Value = ActiveSheet.Shapes(Range("C" & r).Value).Top 'B列に各画像の上位置
Next
Columns("B:D").Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlYes '画像上位置で並べ替え
For r = 2 To lastRow '2行目からA列最後まで
With ActiveSheet.Shapes(Range("C" & r).Value)
.Left = Range("A" & r).Left '画像の左位置をセルの左位置に
.Top = Range("A" & r).Top '同じく上位置
.Width = Range("A" & r).Width '同じく幅
.Height = Range("A" & r).Height '同じく高さ
End With
Next
End Sub

'リネーム実行
Sub doRename()
Dim imgFolder As String
Dim lastRow As Long
Dim r As Long
If MsgBox("保存しますか?", vbYesNo) <> vbYes Then Exit Sub
imgFolder = Range("A1").Value '画像フォルダ
lastRow = Range("D" & Rows.Count).End(xlUp).Row 'D列最終行取得
'途中で同名になる事が無いように、ダブらないように後ろに.$$$を付ける(あり得ない拡張子)
For r = 2 To lastRow '2行目からD列最後まで
Name imgFolder & "\" & Range("D" & r).Value As imgFolder & "\" & Range("D" & r).Value & ".$$$" 'ファイル名の最後に.$$$を付ける
Next
'リネーム
For r = 2 To lastRow '2行目からD列最後まで
Name imgFolder & "\" & Range("D" & r).Value & ".$$$" As imgFolder & "\" & Range("E" & r).Value '.$$$が付いたファイル名を連番ファイル名に
Next
End Sub

以前の質問でその解答を書いた者ですが、シェープの名前をファイル名にすると処理が楽だと思って使ったのですが、name...

質問した人からのコメント

2010/4/24 07:17:34

降参 hotosysさん何度もありがとうございます。
また、いつもお世話になっております。

ばっちりうまくいきました。
前々から憧れていた機能なので何度見ても感動しますね・・・・

本当にありがとうございました。
また宜しくお願いいたします。

ベストアンサー以外の回答

1〜1件/1件中

hei********さん

編集あり2010/4/2315:58:34

自信はないですが

Dim f As String→Dim f As Variantに変更してみてはどうでしょうか?

それでだめなら下記も追加してお試しください。

Dim imgFolder As String→Dim imgFolder As Variant

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる