Public MyFiles() As String
Public fnum As Long
Sub InsertDrawing()
'in red variable
'Mypath=folder where is Screws2000
'ExtStr=drawing name
'1.4=drawing scale (according screen)
'Top=cell row 6 column 1
'*****************************************************
Dim drw As Picture, b As Double, c As Double
Get_File_Names _
MyPath:="C:\program\screws2000", _
Subfolders:=True, _
ExtStr:="TEMP.WMF"
If fnum = 0 Then Exit Sub
Set drw = ActiveSheet.Pictures.Insert(MyFiles(1))
b = drw.ShapeRange.Width / 1.4
c = b / 1.4
With drw
.Top = ActiveSheet.Cells(4, 1).Top
.Left = ActiveSheet.Cells(4, 1).Left
.Height = c
.Width = c
End With
End Sub
Sub Get_File_Names(MyPath As String, Subfolders As Boolean, ExtStr As String)
Dim Fso_Obj As Object, RootFolder As Object
Dim SubFolderInRoot As Object, file As Object
'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If
'Create FileSystemObject object
Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
Erase MyFiles()
fnum = 0
'Test if the folder exist and set RootFolder
If Fso_Obj.FolderExists(MyPath) = False Then
MsgBox MyPath & " doesn't exist"
Exit Sub
End If
Set RootFolder = Fso_Obj.GetFolder(MyPath)
'Fill the array(myFiles)with the list of Excel files in the folder(s)
'Loop through the files in the RootFolder
For Each file In RootFolder.Files
If LCase(file.Name) Like LCase(ExtStr) Then
fnum = fnum + 1
ReDim Preserve MyFiles(1 To fnum)
MyFiles(fnum) = MyPath & file.Name
End If
Next file
'Loop through the files in the Sub Folders if SubFolders = True
If Subfolders = True Then
For Each SubFolderInRoot In RootFolder.Subfolders
For Each file In SubFolderInRoot.Files
If LCase(file.Name) Like LCase(ExtStr) Then
fnum = fnum + 1
ReDim Preserve MyFiles(1 To fnum)
MyFiles(fnum) = SubFolderInRoot & "\" & file.Name
End If
Next file
Next SubFolderInRoot
End If
'If there are no files in the folder display a msgbox
If fnum = 0 Then
MsgBox "There are no " & ExtStr & " files in this folder"
End If
End Sub