| |
Jakaさん、割り込み失礼します。
こじこじさん、こんにちは。
こじこじさんって、次のスレッドの方と同一人物ですか？
【1771】レコードの値をExcelのファイル名に
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=one;no=1771;id=access
だとしたら、向こうを閉じるとかしてくださいね。
ケッコー悲しーです。
万一、同一ネームで人違いでしたら、ご容赦ください。
ACCESS用に待機していたコードをこちら用に書き換えてみました。
Microsoft ActiveX DataObjects 2.5 Library
Microsoft Scripting Runtime
を参照しています。
Sub Main()
On Error GoTo HandleErr
Dim obj As Scripting.FileSystemObject
Dim acnXL As ADODB.Connection
Dim iFile As Scripting.File
Dim newName As String
Dim strpath As String
Set obj = New Scripting.FileSystemObject
Set acnXL = New ADODB.Connection
With acnXL
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Extended Properties").Value = "Excel 8.0;HDR=NO;"
End With
strpath = "C:\work\台帳\"
For Each iFile In obj.GetFolder(strpath).Files
'検索条件にあうものだけを取得して下さい。
'現状では.全角でも半角でも000-999までを取得します。
If UCase(iFile.Name) Like "###.XLS" Then
newName = getNewName(acnXL, iFile.Path)
If newName <> "" Then
iFile.Name = newName
End If
End If
Next
If acnXL.State <> adStateClosed Then
acnXL.Close
End If
Set acnXL = Nothing
Set obj = Nothing
Exit Sub
HandleErr:
MsgBox Err.Description
Resume EndProc
EndProc:
On Error Resume Next
Set obj = Nothing
If acnXL Is Nothing = False Then
If acnXL.State <> adStateClosed Then
acnXL.Close
End If
Set acnXL = Nothing
End If
End Sub
Private Function getNewName( _
ByRef racn As ADODB.Connection, _
ByVal vstrConnString As String) As String
Dim ars As ADODB.Recordset
Dim SQLstring As String 'SQL文
Dim varNewName As Variant
On Error GoTo HandleErr
'シート接続
racn.ConnectionString = vstrConnString
racn.Open
SQLstring = "SELECT *" & vbNewLine _
& "FROM [農道台帳(調書)$N4:N4]" & vbNewLine
Set ars = New ADODB.Recordset
ars.Open SQLstring, racn, adOpenStatic
If ars.BOF = True And ars.EOF = True Then
getNewName = ""
Else
ars.MoveFirst
'ここで、取得した値（入力値）が正しいかどうかの処理を入れてください。
'今は取得値が半角or全角の処理をしていないので、
'混在状況ではエラーになります。
If IsNull(ars.Fields(0).Value) Then
getNewName = ""
Else
getNewName = VBA.Format(ars.Fields(0).Value, "000") & ".xls"
End If
End If
ars.Close
Set ars = Nothing
racn.Close
racn.ConnectionString = ""
Exit Function
HandleErr:
MsgBox Err.Description
Resume EndProc
EndProc:
On Error Resume Next
If ars Is Nothing = False Then
If ars.State <> adStateClosed Then
ars.Close
End If
Set ars = Nothing
End If
If racn.State <> adStateClosed Then
racn.Close
End If
End Function
|
|
しのしの
- 03/9/26(金) 17:32 -
