そのため、IT 部門は最近、office 2003 から office 2010 に移動しました。その変更により、私の VBA マクロは機能しなくなりました。私は十分に検索しましたが、FileSearch モジュールがページの途中で認識されなくなったためです。問題が始まる場所を太字にしました。残念ながら、私は金融分野にいて、この問題を解決するのに十分な VBA の知識がありません。任意の支援をいただければ幸いです。これが私のコードです：
Function PublishCDCManagementReport()
' locate the HTML files generated by the Access report.
' Define Variables to be used by the function:
'Souce & Destination Directories for report pages:
Dim OldPath As String
Dim NewPath As String
'Array to hold Month Names for Subdirectories for path.
'Something like: OldPath "c:\CDCReports\Mgmtrpt\Source"
' NewPath "c:\CDCReports\Mgmtrpt\WebRpt"
' Report through 0802 So Month = 8
' So final NewPath = "c:\CDCReports\Mgmtrpt\WebRpt\August"
Dim Months(12) As String
Dim RptNm As String
Dim RptMth As Integer
Dim LineTxt As Variant
' HTML Code to look for to exclude/Add attitional information
Dim SrchString As String
Dim SrchString2 As String
Dim ExcludeTxt As String
Dim Exclude1 As String
Dim Exclude2 As String
Dim StartTime As Date
Dim EndTime As Date
Dim NewFileTxt As Variant
Dim IndexFileTxt As Variant
Dim AddLine As String
Dim CDCName As String
Dim FileSize As Long
Dim NextFile As Integer
Dim GetPrtNo As DAO.Recordset
Dim WebIndex As DAO.Recordset
Dim CRLF As String
Dim x As Integer
Dim z As Integer
Dim GetMth As Integer
Dim cnt As Integer
Dim SQL As String
Dim db As Database
Dim IndexFileName As String
Dim Str As String
Dim ZipData As String
Dim Msg As String
Dim frm As String
Dim MyPath As String
Dim ExportReportTo As String
On Error GoTo ErrorHandler
' RUN Access REPORT and output as web pages one page for each page of the report.....
frm = "frmPublishToWebMgmntRpt"
MyPath = Application.CurrentProject.Path
RptNm = "\"
OldPath = MyPath & "\Extract"
NewPath = MyPath & "\Renamed"
IndexFileName = "\rptlist.txt"
ExportReportTo = MyPath & "\Extract\CDCrpt.HTML"
StartTime = Now
DoCmd.Hourglass True
Forms(frm).Label3.Caption = "Running Report 'rptCDCManagementReportbyDistrictOffice' to HTML Files"
DoCmd.OutputTo acOutputReport, "rptCDCManagementReportbyDistrictOffice", acFormatHTML, ExportReportTo
DoCmd.Hourglass True
Months(1) = "January"
Months(2) = "February"
Months(3) = "March"
Months(4) = "April"
Months(5) = "May"
Months(6) = "June"
Months(7) = "July"
Months(8) = "August"
Months(9) = "September"
Months(10) = "October"
Months(11) = "November"
Months(12) = "December"
GetMth = False 'Indicator to use to only set the report month once.
ExcludeTxt = "<A HREF"
'Carrage return and linefeed characters to format page
CRLF = Chr(13) & Chr(10)
SrchString = "<TD WIDTH=4 ALIGN=LEFT > <BR></TD><TD WIDTH=608 ALIGN=CENTER ><B><I><FONT style=FONT-SIZE:12pt FACE=""Arial"" COLOR=#000000>"
SrchString2 = "<TD WIDTH=4 ALIGN=LEFT > <BR></TD><TD WIDTH=476 ALIGN=CENTER ><FONT style=FONT-SIZE:10pt FACE=""Arial"" COLOR=#000000>CDC Management Report through "
Exclude1 = "<TD WIDTH=4 ALIGN=LEFT > <BR></TD><TD WIDTH=140 ALIGN=LEFT ><FONT style=FONT-SIZE:8pt FACE=""Arial"" COLOR=#000000>Page"
Exclude2 = "<TD WIDTH=4 ALIGN=LEFT > <BR></TD><TD WIDTH=140 ALIGN=LEFT ><FONT style=FONT-SIZE:10pt FACE=""Arial"" COLOR=#000000>"
'SQL Code to get the FIRS number to use in the title. We might change this to PrtId in the future.
SQL = " SELECT cdctblInformation.PIMsNo,cdctblInformation.CDCNo,cdctblInformation.CDCName ,cdctblInformation.[Oversight Office] FROM cdctblInformation WHERE cdctblInformation.CDCNo="
Set db = CurrentDb
'Remove Index rows. This table is used to create the index in the correct sequence.
db.Execute "DELETE * FROM WEBIndex"
'RptNm = "\mangmtrpt"
' Open the table for the index file....
Set WebIndex = db.OpenRecordset("WEBIndex")
**Set fs = Application.FileSearch**
Forms(frm).Label3.Caption = Forms(frm).Label3.Caption & CRLF & "Report Created" & CRLF & "Processing File:"
With fs
.NewSearch 'Added 7/2009 to clear Microsoft File Search Cache
.LookIn = OldPath
.SearchSubFolders = True
.FileName = "*.HTML"
If .Execute() > 0 Then 'Finds files in folder stored in "OldPath
'MsgBox "There were " & .FoundFiles.Count & " file(s) found."
x = 0
NextFile = True
For I = 1 To .Execute() ' Replaced hard coded value of 288 with search count 11/2010
Open .FoundFiles(I) For Input As #1
If NextFile Then
CDCName = ""
NewFileTxt = ""
End If
cnt = 0
Do While Not EOF(1)
Input #1, LineTxt
cnt = cnt + 1
If InStr(LineTxt, SrchString) <> 0 Then
CDCName = Right(LineTxt, 6)
End If
If InStr(LineTxt, ExcludeTxt) <> 0 Or InStr(LineTxt, "</HTML>") <> 0 Then
' Do nothing we don't want this html
Else
'Append Txt
If Not NextFile Then ' This is a continuation file (i.e. Report was more than 1 page)
If cnt <= 6 Then 'We want to remove the repeated Header so ignore this data
Else
NewFileTxt = NewFileTxt & LineTxt & CRLF
End If
Else
If InStr(LineTxt, Exclude1) <> 0 Then
Else
If InStr(LineTxt, Exclude2) <> 0 Then
Input #1, LineTxt ' We want to skip this line
Else
If GetMth = False Then ' Do determine the Directory to place this in we need to report through date
If InStr(LineTxt, SrchString2) <> 0 Then
Str = Right(LineTxt, Len(LineTxt) - 147)
RptMth = CInt(Left(Str, InStr(Str, "/") - 1))
NewPath = NewPath & "\" & Months(RptMth)
GetMth = True
IndexFileName = NewPath & IndexFileName
Open IndexFileName For Output As #3
End If
NewFileTxt = NewFileTxt & LineTxt & CRLF
Else
NewFileTxt = NewFileTxt & LineTxt & CRLF
End If
End If
End If
End If
End If
Loop
Close #1
If (I = .FoundFiles.Count) Then
FileSize = FileLen(.FoundFiles(I))
Else
FileSize = FileLen(.FoundFiles(I + 1))
End If
If FileSize > 10000 Then
If CDCName <> "" Then
Set GetPrtNo = db.OpenRecordset(SQL + "'" + CDCName + "';")
If Not GetPrtNo.EOF Then
GetPrtNo.MoveFirst
' NewFile = NewPath & RptNm & CDCName & ".html"
NewFile = NewPath & RptNm & UCase(GetPrtNo("PIMsNo")) & ".htm"
WebIndex.AddNew
WebIndex("FIRSNo") = UCase(GetPrtNo("PIMsNo"))
WebIndex("OversightOffice") = GetPrtNo("Oversight Office")
WebIndex("CDCNo") = GetPrtNo("CDCNo")
WebIndex("CDCName") = GetPrtNo("CDCName")
WebIndex.Update
End If
Open NewFile For Output As #2
NewFileTxt = NewFileTxt & "<TABLE cellSpacing=0 cellPadding=0 border=0>"
NewFileTxt = NewFileTxt & "<TR height=14>"
NewFileTxt = NewFileTxt & "<TD align=middle width=626><FONT face=""Arial, Helvetica, sans-serif""><B><< <FONT size=-1>"
NewFileTxt = NewFileTxt & "<a href=""javascript:history.back()"" title=""Link to go back to the previous page"">BACK</a>>></FONT></B></FONT></TD></TR></TABLE>"
NewFileTxt = NewFileTxt & "</BODY> </HTML>" & CRLF
Print #2, NewFileTxt
Close #2
Forms(frm).Label3.Caption = "Processing File:" & x
DoCmd.RepaintObject acForm, frm
x = x + 1
NextFile = True
End If
Else
NextFile = False
x = x + 1
End If
Next I
WebIndex.Index = "PrimaryKey"
WebIndex.MoveFirst
Do While Not WebIndex.EOF
IndexFileTxt = WebIndex("FIRSNo") & " [" & WebIndex("OversightOffice") & "] " & WebIndex("CDCNo") & " " & WebIndex("CDCName") '& CRLF
Print #3, IndexFileTxt
WebIndex.MoveNext
Loop
WebIndex.Close
Close #3
ChDir NewPath
ZipData = "pkzip -a -p " & Format(RptMth, "00") & " *.*"
z = Shell(ZipData, 0)
EndTime = Now
Msg = "Report produced " & .FoundFiles.Count & "Files Of which " & x & " Where PROCESSED " & CRLF
Msg = Msg & "To " & CurDir & CRLF
Msg = Msg & "The Processing Took: " & CRLF & "Start: " & StartTime & CRLF & "End: " & EndTime & CRLF
x = Int(DateDiff("s", StartTime, EndTime) / 60)
Msg = Msg & "Minutes: " & x & ":" & DateDiff("s", StartTime, EndTime) - (x * 60) & CRLF
Msg = Msg & "Zip File: " & Format(RptMth, "00") & ".Zip Created"
Forms(frm).Label3.Caption = Msg
Forms(frm).Label9.Caption = "/opt/netscape/suitespot/docs/mgmtrpt/CDC/" & Format(RptMth, "00") & "_" & Months(RptMth)
Forms(frm).Command1.Enabled = True
Forms(frm).Command6.Visible = True
Forms(frm).Command8.Enabled = True
Else
MsgBox "There were no files found."
End If
End With
'new code
Else: End If
Next
Else
MsgBox "No Files Found at " & FILE_PATH
End If
Set FSO = Nothing
Set FSO_FOLDER = Nothing
'new code
DoCmd.Hourglass False
Exit Function
ErrorHandler:
Select Case Err
Case 2501
If MsgBox("You have cancelled the creation of the WEB Pages. Are you Sure?", vbYesNo, "Cancelled") = vbYes Then
Else
Resume
End If
Case Else
MsgBox "error: " & Err & " " & Error
End Select
End Function