zarpenstein
09-01-2016, 11:57 AM
Hello,
I'm really inexperienced with VBA, as part of my system administration job I haven't compiled much code independently. At my job, an engineer had developed a script to run on Office 2003 32-bit, and we're just now migrating everyone to Office 2016 64-bit. Part of the problem I've seen is that numerous changes between the versions of Office have modified or even removed certain arguments, and one used heavily was Application.Filesearch but that's no longer a valid call in a function. Pasted below is the code I am trying to upgrade, thank you for any help:
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub Print_PDFs()
Dim folder As String
Dim PDFfilename As String
Dim n As Integer
Dim tempn As Integer
Dim lastRow As Integer
Dim I2 As Long
Dim I3 As Long
Dim rev As String
Dim partName As String
Dim fileList As String
Dim missList As String
Dim skipList As String
Dim list() As Variant
n = 0
fileList = "Printed:"
missList = "Missing:"
skipList = "Skipped:"
folder = "Y:\" 'CHANGE AS REQUIRED
Process_BOM
list = ListDirectory(folder)
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For I2 = 2 To lastRow
If InStr(Cells(I2, "F"), "PURCHASED") = 0 And InStr(Cells(I2, "F"), "INV") = 0 And InStr(Cells(I2, "F"), "COMP") = 0 And InStr(Cells(I2, "F"), "HARDWARE") = 0 Then
rev = Cells(I2, "B")
partName = Cells(I2, "A")
tempn = n
For I3 = 1 To UBound(list)
If InStr(UCase(CStr(list(I3))), UCase(partName)) Then
If InStr(UCase(CStr(list(I3))), "_" & UCase(rev)) Then
PDFfilename = CStr(list(I3))
Print_Input PDFfilename
n = n + 1
fileList = fileList & vbNewLine & PDFfilename & " - " & Cells(I2, "F")
I3 = UBound(list)
End If
End If
Next I3
If tempn = n Then
If InStr(Cells(I2, "F"), "REFERENCE DRAWING") <> 0 Then
PDFfilename = UCase(partName) & "_" & UCase(rev) & ".pdf"
Print_Input folder & "RD" & Chr(39) & "s Reference Drawings\" & PDFfilename
fileList = fileList & vbNewLine & PDFfilename & " - " & Cells(I2, "F")
Else
missList = missList & vbNewLine & partName & "_" & rev & ".pdf" & " - " & Cells(I2, "F")
End If
End If
Else
skipList = skipList & vbNewLine & Cells(I2, "A").Value & " - " & Cells(I2, "F")
End If
Next I2
Open "Print Sheet.txt" For Output As #1
Write #1, fileList
Write #1, missList
Write #1, skipList
Close #1
Print_Input Application.DefaultFilePath & "\Print Sheet.txt"
MsgBox n & " files have been printed"
End Sub
Private Sub Print_Input(sPDFfile As String)
Shell "C:\Program Files\Java\jre7\bin\java.exe Print_PDFS " & Chr(34) & sPDFfile & Chr(34), vbNormalFocus
Sleep (500)
End Sub
Private Function ListDirectory(folder As String) As Variant
Dim fs As FileSearch, list() As Variant, I As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False ' set to true if you want sub-folders included
.FileType = msoFileTypeAllFiles 'can modify to just Excel files eg with msoFileTypeExcelWorkbooks
.LookIn = folder 'modify this to where you want to serach
If .Execute > 0 Then
ReDim list(1 To .FoundFiles.Count)
For I = 1 To .FoundFiles.Count
list(I) = .FoundFiles(I)
Next
Else
MsgBox "No files found"
End If
End With
ListDirectory = list
End Function
Private Sub Process_BOM()
Dim I As Long
Dim lastRow As Integer
Dim partName() As String
Columns("D").TextToColumns
Columns("D").NumberFormat = "0"
Columns("E").TextToColumns
Columns("E").NumberFormat = "0.00"
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For I = 2 To lastRow
If InStr(Cells(I, "A"), ".") <> 0 Then
partName() = Split(Cells(I, "A"), ".")
Sheets("Sheet1").Cells(I, "A").Value = partName(0)
End If
If IsNumeric(Cells(I, "A")) = True Then
If Cells(I, "A") < 10000 Then
Cells(I, "A").NumberFormat = "00000"
End If
End If
If InStr(Cells(I, "B"), ".") <> 0 Then
partName() = Split(Cells(I, "B"), ".")
Cells(I, "B").Value = partName(0)
End If
Next I
Range("A1:F" & lastRow).Sort _
Key1:=Range("A1"), Header:=xlYes
Range("A2").Select
Do Until ActiveCell = ""
For I = 2 To lastRow
If ActiveCell.Row <> Cells(I, "A").Row Then
If ActiveCell.Value = Cells(I, "A").Value Then
ActiveCell.Offset(0, 3).Value = ActiveCell.Offset(0, 3).Value + Cells(I, "D").Value
Rows(I).Delete
I = I - 1
End If
End If
Next I
ActiveCell.Offset(1, 0).Select
Loop
Range("A2").Select
End Sub
I'm really inexperienced with VBA, as part of my system administration job I haven't compiled much code independently. At my job, an engineer had developed a script to run on Office 2003 32-bit, and we're just now migrating everyone to Office 2016 64-bit. Part of the problem I've seen is that numerous changes between the versions of Office have modified or even removed certain arguments, and one used heavily was Application.Filesearch but that's no longer a valid call in a function. Pasted below is the code I am trying to upgrade, thank you for any help:
Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Sub Print_PDFs()
Dim folder As String
Dim PDFfilename As String
Dim n As Integer
Dim tempn As Integer
Dim lastRow As Integer
Dim I2 As Long
Dim I3 As Long
Dim rev As String
Dim partName As String
Dim fileList As String
Dim missList As String
Dim skipList As String
Dim list() As Variant
n = 0
fileList = "Printed:"
missList = "Missing:"
skipList = "Skipped:"
folder = "Y:\" 'CHANGE AS REQUIRED
Process_BOM
list = ListDirectory(folder)
lastRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
For I2 = 2 To lastRow
If InStr(Cells(I2, "F"), "PURCHASED") = 0 And InStr(Cells(I2, "F"), "INV") = 0 And InStr(Cells(I2, "F"), "COMP") = 0 And InStr(Cells(I2, "F"), "HARDWARE") = 0 Then
rev = Cells(I2, "B")
partName = Cells(I2, "A")
tempn = n
For I3 = 1 To UBound(list)
If InStr(UCase(CStr(list(I3))), UCase(partName)) Then
If InStr(UCase(CStr(list(I3))), "_" & UCase(rev)) Then
PDFfilename = CStr(list(I3))
Print_Input PDFfilename
n = n + 1
fileList = fileList & vbNewLine & PDFfilename & " - " & Cells(I2, "F")
I3 = UBound(list)
End If
End If
Next I3
If tempn = n Then
If InStr(Cells(I2, "F"), "REFERENCE DRAWING") <> 0 Then
PDFfilename = UCase(partName) & "_" & UCase(rev) & ".pdf"
Print_Input folder & "RD" & Chr(39) & "s Reference Drawings\" & PDFfilename
fileList = fileList & vbNewLine & PDFfilename & " - " & Cells(I2, "F")
Else
missList = missList & vbNewLine & partName & "_" & rev & ".pdf" & " - " & Cells(I2, "F")
End If
End If
Else
skipList = skipList & vbNewLine & Cells(I2, "A").Value & " - " & Cells(I2, "F")
End If
Next I2
Open "Print Sheet.txt" For Output As #1
Write #1, fileList
Write #1, missList
Write #1, skipList
Close #1
Print_Input Application.DefaultFilePath & "\Print Sheet.txt"
MsgBox n & " files have been printed"
End Sub
Private Sub Print_Input(sPDFfile As String)
Shell "C:\Program Files\Java\jre7\bin\java.exe Print_PDFS " & Chr(34) & sPDFfile & Chr(34), vbNormalFocus
Sleep (500)
End Sub
Private Function ListDirectory(folder As String) As Variant
Dim fs As FileSearch, list() As Variant, I As Long
Set fs = Application.FileSearch
With fs
.SearchSubFolders = False ' set to true if you want sub-folders included
.FileType = msoFileTypeAllFiles 'can modify to just Excel files eg with msoFileTypeExcelWorkbooks
.LookIn = folder 'modify this to where you want to serach
If .Execute > 0 Then
ReDim list(1 To .FoundFiles.Count)
For I = 1 To .FoundFiles.Count
list(I) = .FoundFiles(I)
Next
Else
MsgBox "No files found"
End If
End With
ListDirectory = list
End Function
Private Sub Process_BOM()
Dim I As Long
Dim lastRow As Integer
Dim partName() As String
Columns("D").TextToColumns
Columns("D").NumberFormat = "0"
Columns("E").TextToColumns
Columns("E").NumberFormat = "0.00"
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
For I = 2 To lastRow
If InStr(Cells(I, "A"), ".") <> 0 Then
partName() = Split(Cells(I, "A"), ".")
Sheets("Sheet1").Cells(I, "A").Value = partName(0)
End If
If IsNumeric(Cells(I, "A")) = True Then
If Cells(I, "A") < 10000 Then
Cells(I, "A").NumberFormat = "00000"
End If
End If
If InStr(Cells(I, "B"), ".") <> 0 Then
partName() = Split(Cells(I, "B"), ".")
Cells(I, "B").Value = partName(0)
End If
Next I
Range("A1:F" & lastRow).Sort _
Key1:=Range("A1"), Header:=xlYes
Range("A2").Select
Do Until ActiveCell = ""
For I = 2 To lastRow
If ActiveCell.Row <> Cells(I, "A").Row Then
If ActiveCell.Value = Cells(I, "A").Value Then
ActiveCell.Offset(0, 3).Value = ActiveCell.Offset(0, 3).Value + Cells(I, "D").Value
Rows(I).Delete
I = I - 1
End If
End If
Next I
ActiveCell.Offset(1, 0).Select
Loop
Range("A2").Select
End Sub