説明に自信ありませんが。

質問

以前質問させていただいた者です、
解答していただいた方ありがとうございました。
さっそく本屋さんで見てみましたが、私が理解するには多少なりとも
プログラムに詳しい人がそばいないと難しいと思い、
改めて質問させていただきます。
自分にはプログラムはまだまだ時間がかかるので、以下のような
処理の可能なソフトを探しています。何かありますでしょうか？
画像データを取り扱うもので、以下のような処理をしたいのですが・・。
データベースフォルダＡ
001.jpg 002.jpg 003.jpg 004.jpg ・・・ 2000.jpg
(1) 数字を入力
　　352　200　212　1555　2　33　525　223　200　33　33　・・・　
(2) 実行
　　352をキーに352.jpgを検索し　1-00352-001.jpg とファイル名を変更して
　　データベースフォルダＢに。
　　200をキーに200.jpgを検索し　2-00200-001.jpg とファイル名を変更して
　　データベースフォルダＢに。
　　212をキーに212.jpgを検索し　3-00212-001.jpg とファイル名を変更して
　　データベースフォルダＢに。
　　同様に　1555から 4-01555-001.jpg 2から 5-00002-001.jpg
　　 　　　　33から　6-00033-001.jpg 525から 7-00525-001.jpg
223から 8-00223-001.jpg　そして、同じ番号がキーに
なっている場合（次の200の場合）
200.jpgを 9-00200-002.jpgと変更してデータベースフォルダＢに。
その次の33は33.jpgを　10-00033-002.jpg　　次は 11-00033-003.jpg
と言うように、データベースＡから
（1から連番）-（検索されたファイルの数字）-（そのファイルの検索された回数）.jpg
と名前を変更したものをデータベースＢとして作成したいのですが・・。
（例えば2-00200-001.jpg と　9-00200.002.jpgは同じ画像になります）。
こんなかんじですが、いかがなものでしょう？やはり一般人にこなせるレベルじゃないですか？

回答No.3

TAGOSAKU7 · ベストアンサー

環境が書いてなかったから、ＶＢ６だと思ってました...
アクセスだったのですね(^^;)

アクセスだと・・・
ファイルリストボックスはありません。
フォーカスを持っているコントロールを使用不可にできません。

恐らくそれがエラーの原因になってると思います。

ですので、for アクセス バージョンです。

'処理内容としては
'１．キーを元に"*-00001-*.jpg"というようなパターンを作成
'２．getFiles関数により同パターンのファイル数を取得
'３．新たな名前の作成をしてコピー
'
'
'必要なオブジェクト／コントロール
'フォーム1
'│
'├コマンドボタン1 [Command1]
'│
'└コマンドボタン2 [Command2]

Option Compare Database
Option Explicit

Private Const RENAME_KEY_FILE　 As String = "c:\TEST.txt"
Private Const RENAME_KRY_CUT　　As String = ","

Private Const DIR_DB_A As String = "C:\A\"
Private Const DIR_DB_B As String = "C:\B\"

Private lngCntKey　 As Long　　 'キーの数
Private valKwyAry　 As Variant　'キーを配列で記憶

'キーファイルを読み取る
Private Sub Command1_Click()
　　Dim lngFile　　 As Long
　　Dim lngFileSize As Long
　　Dim strWork　　 As String

　　'--- キーファイルから、文字列の取得 ---
　　lngFileSize = FileLen(RENAME_KEY_FILE)
　　strWork = String(lngFileSize, vbNullChar)
　　lngFile = FreeFile
　　Open RENAME_KEY_FILE For Binary As #lngFile
　　　　'バッファ取得
　　　　Get #lngFile, , strWork
　　Close #lngFile

　　'---- 取得した文字列の分解 ---
　　On Error Resume Next
　　lngCntKey = 0
　　Erase valKwyAry
　　valKwyAry = Split(strWork, RENAME_KRY_CUT)　'サンプルではカンマ区切り
　　lngCntKey = UBound(valKwyAry) + 1　　　　　 'キーの数を得る
　　On Error GoTo 0

　　'キーが存在したらリネーム処理ボタン使用可能
　　If (lngCntKey > 0) Then
　　　　Me.Command2.Enabled = True
　　　　Me.Command2.SetFocus
　　　　Me.Command1.Enabled = False
　　　　MsgBox "キー情報を取得しました"
　　Else
　　　　MsgBox "キー情報を取得できませんでした"
　　End If
End Sub

Private Sub Command2_Click()
　　Dim i　　　　　　　 As Long
　　Dim strFileName　　 As String
　　Dim strNewFileName　As String
　　Dim strPattern　　　As String
　　Dim lngCntMain　　　As Long
　　Dim lngCntSub　　　 As Long
　　Dim lngFileCnt　　　As Long

　　With Me
　　　　'メインカウンタの初期化
　　　　lngCntMain = 0

　　　　For i = 0 To lngCntKey - 1
　　　　　　'ファイル名を作成
　　　　　　strFileName = DIR_DB_A & valKwyAry(i) & ".jpg"

　　　　　　'ファイルの有無を調べる
　　　　　　If Dir(strFileName) <> "" Then
　　　　　　　　'--- 存在したら ---

　　　　　　　　'メインカウンタを１増やす
　　　　　　　　lngCntMain = lngCntMain + 1

　　　　　　　　'新たなファイル名の途中部分をパターンを作成
　　　　　　　　strPattern = "*-" & Format(valKwyAry(i), "00000") & "-*.jpg"
　　　　　　　　'作成したパターンのファイルが、コピー先に何個あるかを得る
　　　　　　　　lngFileCnt = getFiles(DIR_DB_B, strPattern)

　　　　　　　　'サブカウンタをセット（同じパターンのファイル数＋１）
　　　　　　　　lngCntSub = lngFileCnt + 1

　　　　　　　　'コピー先名を定義
　　　　　　　　strNewFileName = DIR_DB_B & _
　　　　　　　　　　　　　　lngCntMain & "-" & _
　　　　　　　　　　　　　　Format(valKwyAry(i), "00000") & "-" & _
　　　　　　　　　　　　　　Format(lngCntSub, "000") & ".jpg"
　　　　　　　　'コピー
　　　　　　　　Call FileCopy(strFileName, strNewFileName)

　　　　　　End If
　　　　Next i

　　End With

　　MsgBox "変更終了しました"
End Sub

Private Sub Form_Load()
　　With Me
　　　　.Command1.Caption = "ファイル取得"
　　　　.Command2.Caption = "コピー実行"
　　　　.Command2.Enabled = False
　　End With
End Sub

'【機　能】 ：フォルダ内に存在するファイルの数を取得する
'【返り値】 ：フォルダに含むファイルの数

'''パラメータ１（inPath）　　　 ：ファイルパス
'''パラメータ２（inFileFilter)　：ファイルのフィルタ
Private Function getFiles(inPath As String, inFileFilter As String) As Long
　　Dim strFileName As String

　　'最初ののJEPGファイルを見つける
　　strFileName = Dir(inPath & inFileFilter)

　　'取得できなくなるまで繰り返す
　　Do While strFileName <> ""
　　　　'拡張子を持っているようなフォルダ名をはじく処理
　　　　If (GetAttr(inPath & strFileName) And vbDirectory) <> vbDirectory Then
　　　　　　getFiles = getFiles + 1
　　　　End If

　　　　'次のファイルを取得する
　　　　strFileName = Dir
　　Loop
End Function

お礼

またまた返事が遅れてしまいました。
ようやく、プログラム自体稼動するようになりました。
本当にありがとうございました。

回答No.2

TAGOSAKU7

すいません訂正です

Option Explicit
↑これ二つ存在してます。一つでいいです。

Private lngCntKey　 As Long　　 'キーを配列で記憶
Private valKwyAry　 As Variant　'キーの数
コメントが反対です
Private lngCntKey　 As Long　　 'キーの数
Private valKwyAry　 As Variant　'キーを配列で記憶
が正しいです。

あとロード時のコマンドボタン２のキャプションがリネームになってますが、機能はリネームではありません。コピーです。

過去のファイルから引っぱってきて作成したサンプルなので、修正し忘れてました。。。

回答No.1

TAGOSAKU7

サンプルです。

処理内容としては
１．キーを元に"*-00001-*.jpg"というようなパターンを作成
２．ファイルリすとボックスにパターンをセット
３．ファイルのカウントをファイルリストボックスから読み取る
４．新たな名前の作成をしてコピー

必要なオブジェクト／コントロール
フォーム１[Form1]
│
├コマンドボタン１[Command1]
│
├コマンドボタン２[Command2]
│
└ファイルリストボックス[File1]

あとサンプルでは
Private Const RENAME_KEY_FILE　 As String = "c:\TEST.txt"
Private Const RENAME_KRY_CUT　　As String = ","
として、キーをファイルから読み取ってます。
カンマ区切りのキーが入ったテキストファイルが必要です。

元のJPGフォルダ[DIR_DB_A]
出力先のJPGフォルダ[DIR_DB_A]
で宣言してあるので、任意に変更してください。

Option Explicit
Option Explicit
Option Compare Text 'ここに記されているプログラムは、文字列の比較を大文字小文字の区別をしない事を宣言

Private Const RENAME_KEY_FILE　 As String = "c:\TEST.txt"
Private Const RENAME_KRY_CUT　　As String = ","

Private Const DIR_DB_A　As String = "C:\A\"
Private Const DIR_DB_B　As String = "C:\B\"

Private lngCntKey　 As Long　　 'キーを配列で記憶
Private valKwyAry　 As Variant　'キーの数

'キーファイルを読み取る
Private Sub Command1_Click()
　　Dim fileBuf()　 As Byte
　　Dim lngFile　　 As Long
　　Dim lngFileSize As Long
　　Dim strWork　　 As String

　　'--- キーファイルから、文字列の取得 ---
　　lngFileSize = FileLen(RENAME_KEY_FILE)
　　ReDim fileBuf(lngFileSize - 1) As Byte

　　lngFile = FreeFile
　　Open RENAME_KEY_FILE For Binary As #lngFile
　　　　'バッファ取得
　　　　Get #lngFile, , fileBuf
　　Close #lngFile
　　strWork = StrConv(fileBuf, vbUnicode)

　　'---- 取得した文字列の分解 ---
　　On Error Resume Next
　　lngCntKey = 0
　　Erase valKwyAry
　　valKwyAry = Split(strWork, RENAME_KRY_CUT)　'サンプルではカンマ区切り
　　lngCntKey = UBound(valKwyAry) + 1　　　　　 'キーの数を得る
　　On Error GoTo 0

　　'キーが存在したらリネーム処理ボタン使用可能
　　If (lngCntKey > 0) Then
　　　　Me.Command1.Enabled = False
　　　　Me.Command2.Enabled = True
　　　　MsgBox "キー情報を取得しました"
　　Else
　　　　MsgBox "キー情報を取得できませんでした"
　　End If
End Sub

Private Sub Command2_Click()
　　Dim i　　　　　　　 As Long
　　Dim strFileName　　 As String
　　Dim strNewFileName　As String
　　Dim strPattern　　　As String
　　Dim lngCntMain　　　As Long
　　Dim lngCntSub　　　 As Long

　　With Me
　　　　lngCntMain = 0

　　　　'ファイルリすとボックスのパスを設定
　　　　.File1.Path = DIR_DB_B

　　　　For i = 0 To lngCntKey - 1
　　　　　　'ファイル名を作成
　　　　　　strFileName = DIR_DB_A & valKwyAry(i) & ".jpg"

　　　　　　'ファイルの有無を調べる
　　　　　　If Dir(strFileName) <> "" Then
　　　　　　　　'--- 存在したら ---

　　　　　　　　'リネームのカウンタを１増やす
　　　　　　　　lngCntMain = lngCntMain + 1

　　　　　　　　'新たなファイル名の途中部分を定義
　　　　　　　　strPattern = "*-" & Format(valKwyAry(i), "00000") & "-*.jpg"
　　　　　　　　.File1.Pattern = strPattern
　　　　　　　　.File1.Refresh

　　　　　　　　'サブカウンタをセット
　　　　　　　　lngCntSub = .File1.ListCount + 1

　　　　　　　　'新たな名前を定義
　　　　　　　　strNewFileName = DIR_DB_B & _
　　　　　　　　　　　　　　lngCntMain & "-" & _
　　　　　　　　　　　　　　Format(valKwyAry(i), "00000") & "-" & _
　　　　　　　　　　　　　　Format(lngCntSub, "000") & ".jpg"
　　　　　　　　'コピー
　　　　　　　　FileCopy strFileName, strNewFileName

　　　　　　End If
　　　　Next i
　　End With

　　MsgBox "変更終了しました"
End Sub

Private Sub Form_Load()
　　With Me
　　　　.Command1.Caption = "ファイル取得"
　　　　.Command2.Caption = "リネーム実行"
　　　　.Command2.Enabled = False
　　　　.File1.Visible = False
　　End With
End Sub

補足

お礼が遅くなりました、すみません。実はこのプログラムいただいてから
アクセスの基礎から勉強していたもので・・。で、ソフトの概要はそこそこつかめたのですが、この命令文を何処に貼り付ければよいのかわからなくて・・。
新規フォームを作成し、コマンド1ボタンとコマンド２ボタンとリストボックスを作成、コマンド１ボタンの「クリック時」のイベントプロージャに貼り付けてみたのですが、うまくいかなくて・・。リストボックスは見えなくなってしまうし、エラーで　File1.Path = DIR_DB_B　の行にエラーがあるらしくそれを飛ばすと今度は Me.Command1.Enabled = False の所でもコントロールがなんたらとエラーが出てしまい、アクセスＶＢＡの本を片手に途方に暮れています。もう少し具体的に教えていただけるとうれしいのですが・・・。