Hey guys,
I have this outrun VBA code that loops a string that places thousands of images in an excel spreadsheet. It starts out running pretty fast but as the images add up in the spreadsheet it eventually grinds to a halt. I need some help fixing the slow pace it runs at toward the end of the process. The whole process ran fine through and through in Excel 2003. We are upgrading and need to be able to run this program in Excel 2010. Please reply with help asap. Thanks.
Here is the code we are using:
'==============================
' This Sub does the Burl Survey Stitching
'============================
Sub Burls()
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 45
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll
'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
'------------ First Group of Files - Seal Left -----------------
r = 2
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "SL-lft*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 1.5 Group of Files - Seal Rt -----------------
r = 53
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "SL-Rgt*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r - 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ 2nd Group of Files - BT -----------------
r = 5
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "BT-_*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BB -----------------
r = 50
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "BB-_*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 3rd Group of Files - BE1C, BE2C, BE3C, BE4C -----------------
r = 6
c = 6
n = 1
i = 1
For Z = 1 To 4
rootname = "BE" + Trim(Z) + "C-"
If (Z = 1 Or Z = 4) Then
Imax = 12
Else
Imax = 10
End If
For U = 1 To Imax
If (U < 10) Then
Irow = "_I00" & Trim(U)
Else
Irow = "_I0" & Trim(U)
End If
For D = 1 To 45
If (D < 10) Then
Drow = "_D00" & Trim(D)
Else
Drow = "_D0" & Trim(D)
End If
ffilename(i) = dirname + rootname + Drow + Irow + ".jpg"
PlaceImage ffilename(i), r - 1 + U, c - 1 + D
Next D
Next U
r = r + Imax
Next Z
'------------ 4th Group of Files - Seal Lwr -----------------
r = 50
c = 2
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "SL-lwr*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
If i = n * columns_s Then
r = 50
c = c + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 5th Group of Files - Seal Upr -----------------
r = 50
c = 54
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "SL_UPR*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
If i = n * columns_s Then
r = 50
c = c - 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR1_D001 -----------------
r = 8
c = 5
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "BLR1-_D001*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR1_D002 -----------------
r = 17
c = 51
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "BLR1-_D002*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR4_D001 -----------------
r = 38
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BLR4-_D001*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
''------------ Group of Files - BLR4_D002 -----------------
r = 38
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BLR4-_D002*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMRU -----------------
r = 18
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRU*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMRL -----------------
r = 28
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRL*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMLU -----------------
r = 18
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLU*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMLL -----------------
r = 28
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLL*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BMLC -----------------
r = 27
c = 4
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLC*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
''------------ Group of Files - BMRC -----------------
r = 27
c = 52
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRC*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - Part ID -----------------
r = 54
c = 26
n = 1
i = 1
ffilename(i) = Dir(dirname + "Prt_ID*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - TS -----------------
ffilename(i) = Dir(dirname + "TS4-_D001_I001.jpg")
PlaceImage dirname + ffilename(i), 54, 14
ffilename(i) = Dir(dirname + "TS4-_D002_I001.jpg")
PlaceImage dirname + ffilename(i), 54, 42
ffilename(i) = Dir(dirname + "TS4-_D001_I002.jpg")
PlaceImage dirname + ffilename(i), 1, 14
ffilename(i) = Dir(dirname + "TS4-_D002_I002.jpg")
PlaceImage dirname + ffilename(i), 1, 42
End Sub
'=======================================
' This sub does the full-grid survey
'=======================================
Sub Full_Grid()
'
' Macro recorded 8/3/99 by tuitterd
'
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 58
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll
'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
ffilename(i) = Dir(dirname + "*.jpg")
'Determine amount of files
While Len(ffilename(i)) > 0
ffilename(i) = Dir()
files = files + 1
Wend
beginrow = 2 * files + 2
ffilename(i) = Dir(dirname + "*.jpg")
'Get data
While Len(ffilename(i)) > 0
Cells(r, c).Select
ActiveSheet.Pictures.Insert(filename:=dirname + ffilename(i)).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=dirname + ffilename(i)
c = c + 1
If i = n * columns_s Then
c = 1
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
End Sub
'======================================
' This sub does the full-grid survey
'======================================
Sub WFull_Grid()
'
' Macro recorded 8/3/99 by tuitterd
'
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 113
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll
'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
ffilename(i) = Dir(dirname + "*.jpg")
'Determine amount of files
While Len(ffilename(i)) > 0
ffilename(i) = Dir()
files = files + 1
Wend
beginrow = 2 * files + 2
ffilename(i) = Dir(dirname + "*.jpg")
'Get data
While Len(ffilename(i)) > 0
Cells(r, c).Select
ActiveSheet.Pictures.Insert(filename:=dirname + ffilename(i)).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=dirname + ffilename(i)
c = c + 1
If i = n * columns_s Then
c = 1
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
End Sub
Sub ClearAll()
Cells.Select
Selection.ColumnWidth = 7.2
Selection.RowHeight = 36
End Sub
Sub PlaceImage(xfilename As String, row As Variant, col As Variant)
Cells(row, col).Select
ActiveSheet.Pictures.Insert(filename:=xfilename).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=xfilename
End Sub
Sub Mark_BdImage()
Sheets("Bad_Images").Select
numpts = Cells(1, 2).Value
strtrw = 7
endrw = 7 + numpts - 1
For i = strtrw To endrw
Sheets("Bad_Images").Select
'imgrow = Cells(i, 2).Value
'imgcol = Cells(i, 3).Value
pictnum = Cells(i, 4).Value
pictstr = "Picture " & pictnum
Sheets("Output1").Select
ActiveSheet.Shapes(pictstr).Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Next i
End Sub
Sub Clear_BdImage()
Sheets("Bad_Images").Select
numpts = Cells(1, 2).Value
strtrw = 7
endrw = 7 + numpts - 1
For i = strtrw To endrw
Sheets("Bad_Images").Select
'imgrow = Cells(i, 2).Value
'imgcol = Cells(i, 3).Value
'pictnum = imgrow * imgcol
pictnum = Cells(i, 4).Value
pictstr = "Picture " & pictnum
Sheets("Output1").Select
ActiveSheet.Shapes(pictstr).Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse
Next i
End Sub
I have this outrun VBA code that loops a string that places thousands of images in an excel spreadsheet. It starts out running pretty fast but as the images add up in the spreadsheet it eventually grinds to a halt. I need some help fixing the slow pace it runs at toward the end of the process. The whole process ran fine through and through in Excel 2003. We are upgrading and need to be able to run this program in Excel 2010. Please reply with help asap. Thanks.
Here is the code we are using:
'==============================
' This Sub does the Burl Survey Stitching
'============================
Sub Burls()
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 45
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll
'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
'------------ First Group of Files - Seal Left -----------------
r = 2
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "SL-lft*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 1.5 Group of Files - Seal Rt -----------------
r = 53
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "SL-Rgt*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r - 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ 2nd Group of Files - BT -----------------
r = 5
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "BT-_*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BB -----------------
r = 50
c = 6
n = 1
i = 1
ffilename(i) = Dir(dirname + "BB-_*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
If i = n * columns_s Then
c = 6
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 3rd Group of Files - BE1C, BE2C, BE3C, BE4C -----------------
r = 6
c = 6
n = 1
i = 1
For Z = 1 To 4
rootname = "BE" + Trim(Z) + "C-"
If (Z = 1 Or Z = 4) Then
Imax = 12
Else
Imax = 10
End If
For U = 1 To Imax
If (U < 10) Then
Irow = "_I00" & Trim(U)
Else
Irow = "_I0" & Trim(U)
End If
For D = 1 To 45
If (D < 10) Then
Drow = "_D00" & Trim(D)
Else
Drow = "_D0" & Trim(D)
End If
ffilename(i) = dirname + rootname + Drow + Irow + ".jpg"
PlaceImage ffilename(i), r - 1 + U, c - 1 + D
Next D
Next U
r = r + Imax
Next Z
'------------ 4th Group of Files - Seal Lwr -----------------
r = 50
c = 2
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "SL-lwr*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
If i = n * columns_s Then
r = 50
c = c + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ 5th Group of Files - Seal Upr -----------------
r = 50
c = 54
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "SL_UPR*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
If i = n * columns_s Then
r = 50
c = c - 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR1_D001 -----------------
r = 8
c = 5
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "BLR1-_D001*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR1_D002 -----------------
r = 17
c = 51
n = 1
i = 1
columns_s = 46
ffilename(i) = Dir(dirname + "BLR1-_D002*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r - 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BLR4_D001 -----------------
r = 38
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BLR4-_D001*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
''------------ Group of Files - BLR4_D002 -----------------
r = 38
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BLR4-_D002*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMRU -----------------
r = 18
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRU*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMRL -----------------
r = 28
c = 51
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRL*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMLU -----------------
r = 18
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLU*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - BMLL -----------------
r = 28
c = 5
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLL*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - BMLC -----------------
r = 27
c = 4
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMLC*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
''------------ Group of Files - BMRC -----------------
r = 27
c = 52
n = 1
i = 1
ffilename(i) = Dir(dirname + "BMRC*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
r = r + 1
i = i + 1
ffilename(i) = Dir()
Wend
'------------ Group of Files - Part ID -----------------
r = 54
c = 26
n = 1
i = 1
ffilename(i) = Dir(dirname + "Prt_ID*.jpg")
While Len(ffilename(i)) > 0
PlaceImage dirname + ffilename(i), r, c
c = c + 1
i = i + 1
ffilename(i) = Dir()
Wend
' '------------ Group of Files - TS -----------------
ffilename(i) = Dir(dirname + "TS4-_D001_I001.jpg")
PlaceImage dirname + ffilename(i), 54, 14
ffilename(i) = Dir(dirname + "TS4-_D002_I001.jpg")
PlaceImage dirname + ffilename(i), 54, 42
ffilename(i) = Dir(dirname + "TS4-_D001_I002.jpg")
PlaceImage dirname + ffilename(i), 1, 14
ffilename(i) = Dir(dirname + "TS4-_D002_I002.jpg")
PlaceImage dirname + ffilename(i), 1, 42
End Sub
'=======================================
' This sub does the full-grid survey
'=======================================
Sub Full_Grid()
'
' Macro recorded 8/3/99 by tuitterd
'
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 58
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll
'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
ffilename(i) = Dir(dirname + "*.jpg")
'Determine amount of files
While Len(ffilename(i)) > 0
ffilename(i) = Dir()
files = files + 1
Wend
beginrow = 2 * files + 2
ffilename(i) = Dir(dirname + "*.jpg")
'Get data
While Len(ffilename(i)) > 0
Cells(r, c).Select
ActiveSheet.Pictures.Insert(filename:=dirname + ffilename(i)).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=dirname + ffilename(i)
c = c + 1
If i = n * columns_s Then
c = 1
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
End Sub
'======================================
' This sub does the full-grid survey
'======================================
Sub WFull_Grid()
'
' Macro recorded 8/3/99 by tuitterd
'
'Declarations and clear the input and output sheet
i = 1
r = 1
c = 1
n = 1
columns_s = 113
files = 0
Const nmax = 15000
Dim ffilename(1 To nmax) As String
Windows("ImageStitch.XLS").Activate
Sheets("Output1").Select
ClearAll
'Get directory name
ChDir "m:\"
dirstr = CurDir()
FileToOpen = Application.GetOpenFilename("JPG files,*.jpg")
If FileToOpen = False Then End
t = 3
Do
t = t + 1
Loop Until InStr(Right(FileToOpen, t), "\") <> 0
dirname = Left(FileToOpen, Len(FileToOpen) - t + 1)
ffilename(i) = Dir(dirname + "*.jpg")
'Determine amount of files
While Len(ffilename(i)) > 0
ffilename(i) = Dir()
files = files + 1
Wend
beginrow = 2 * files + 2
ffilename(i) = Dir(dirname + "*.jpg")
'Get data
While Len(ffilename(i)) > 0
Cells(r, c).Select
ActiveSheet.Pictures.Insert(filename:=dirname + ffilename(i)).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=dirname + ffilename(i)
c = c + 1
If i = n * columns_s Then
c = 1
r = r + 1
n = n + 1
ActiveWindow.SmallScroll Down:=1
End If
i = i + 1
ffilename(i) = Dir()
Wend
End Sub
Sub ClearAll()
Cells.Select
Selection.ColumnWidth = 7.2
Selection.RowHeight = 36
End Sub
Sub PlaceImage(xfilename As String, row As Variant, col As Variant)
Cells(row, col).Select
ActiveSheet.Pictures.Insert(filename:=xfilename).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 36#
Selection.ShapeRange.Width = 48#
ActiveSheet.Hyperlinks.Add Anchor:=Selection.ShapeRange.Item(1), Address:=xfilename
End Sub
Sub Mark_BdImage()
Sheets("Bad_Images").Select
numpts = Cells(1, 2).Value
strtrw = 7
endrw = 7 + numpts - 1
For i = strtrw To endrw
Sheets("Bad_Images").Select
'imgrow = Cells(i, 2).Value
'imgcol = Cells(i, 3).Value
pictnum = Cells(i, 4).Value
pictstr = "Picture " & pictnum
Sheets("Output1").Select
ActiveSheet.Shapes(pictstr).Select
Selection.ShapeRange.Fill.Visible = msoFalse
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.SchemeColor = 10
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Next i
End Sub
Sub Clear_BdImage()
Sheets("Bad_Images").Select
numpts = Cells(1, 2).Value
strtrw = 7
endrw = 7 + numpts - 1
For i = strtrw To endrw
Sheets("Bad_Images").Select
'imgrow = Cells(i, 2).Value
'imgcol = Cells(i, 3).Value
'pictnum = imgrow * imgcol
pictnum = Cells(i, 4).Value
pictstr = "Picture " & pictnum
Sheets("Output1").Select
ActiveSheet.Shapes(pictstr).Select
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoFalse
Next i
End Sub