Hi Guys,
i am a novice at programming, i have been using 2 separate files to perform a task.
1st file EXCEL file with macro used to copy a folder containing picture from a database and paste it into desired location.
2nd file WORD file with macro to convert the picture to pdf.
i have been trying to join these to functions into a single step which reduced the time and make it easy for execution.
Below is the VBA code used in the excel sheet
Copy the entire folder from a database location and paste it on to desired location
[VBA]Private Sub CommandButton1_Click()
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> 0 Then
TextBox1.Value = .SelectedItems(1) & "\"
Else
MsgBox "Destination Folder Not Selected"
End If
End With
End Sub
Private Sub CommandButton2_Click()
Dim CL As Range
Dim FS As Object
Dim ScrDrv As String, DesDrv As String
Dim avail As Boolean
Dim inp As Worksheet, out As Worksheet
Dim lr As Integer, i As Integer, lr_o As Integer, j As Integer, row As Integer
Dim fso, result
If TextBox1.Value = "" Then
MsgBox "Destination Folder Not Selected"
End If
If OptionButton2.Value = True Then
DesDrv = TextBox1.Value & "\":
Set inp = ThisWorkbook.Worksheets("File Searcher")
Set out = ThisWorkbook.Worksheets("Path Folder")
lr = inp.Cells(Rows.Count, "A").End(xlUp).row
lr_o = out.Cells(Rows.Count, "A").End(xlUp).row
For i = 2 To lr
avail = False
For j = 2 To lr_o
If inp.Cells(i, "A") = Left(out.Cells(j, "A"), 7) Then
ScrDrv = out.Cells(j, "B")
Set fso = CreateObject("Scripting.FileSystemObject")
result = fso.CopyFolder(ScrDrv, DesDrv, True)
avail = True
End If
If inp.Cells(i, "A") = out.Cells(j, "A") Then
ScrDrv = out.Cells(j, "B")
Set fso = CreateObject("Scripting.FileSystemObject")
result = fso.CopyFolder(ScrDrv, DesDrv, True)
avail = True
End If
Next j
If avail = False Then
inp.Cells(i, "A").Font.Bold = True:
inp.Cells(i, "A").Font.Color = vbRed
End If
Next i
End If
If OptionButton1.Value = True Then
ScrDrv = "\\q-fs03\Efs_GRS\Engineering For Services\RRD Projects\RRD_Part_Drawings_Historic_TVs\TV's\":
DesDrv = TextBox1.Value & "\":
Set FS = CreateObject("Scripting.FileSystemObject")
Application.Goto ThisWorkbook.Sheets(1).Range("A2:A100"):
For Each CL In Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).row):
avail = False
If Not Dir(ScrDrv & CL.Value & ".tiff", vbDirectory) = vbNullString Then FS.CopyFile ScrDrv & CL.Value & ".tiff", DesDrv & CL.Value & ".tiff": avail = True
If Not Dir(ScrDrv & CL.Value & ".pdf", vbDirectory) = vbNullString Then FS.CopyFile ScrDrv & CL.Value & ".pdf", DesDrv & CL.Value & ".pdf": avail = True
If avail = False Then CL.Font.Bold = True: CL.Font.Color = vbRed
Next CL
Set FS = Nothing
End If
End Sub
Private Sub CommandButton3_Click()
Range(Cells(2, 1), Cells(100, 1)).clear
Range(Cells(2, 1), Cells(100, 1)).Borders.Weight = 2
TextBox1.Value = ""
End Sub
Private Sub OptionButton1_Click()
If OptionButton1.Value = True Then
TextBox2.Text = "\\q-fs03\Efs_GRS\Engineering For Services\RRD Projects\RRD_Part_Drawings_Historic_TVs\TV's\"
Range("A1").Value = "TV NUMBER"
End If
End Sub
Private Sub OptionButton2_Click()
If OptionButton2.Value = True Then
TextBox2.Text = "\\q-fs03\Efs_GRS\Engineering For Services\RRD Projects\RRD_Part_Drawings_Historic_TVs\Drawings\"
Range("A1").Value = "PART NUMBER"
End If
End Sub[/VBA]
the VBA Code used on the Word document is below
convert the pictures in the folder into pdf
[VBA]Sub InsertImages()
Dim doc As Word.Document
Dim bkmName As String
Dim SigFile As String
Dim fd As FileDialog
Dim mg2 As Range
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set doc = ActiveDocument
Dim vrtSelectedItem As Variant
Dim theText() As String
Dim theText2 As String
Dim Char As Characters
Dim StrPath As String
Dim StrNewPath As String
Dim strDocName As String
Dim fso As Object
Dim fold As Object
Dim files As Object
' selecting the CGM files
With fd
.Filters.Add "JPEG", "*.jpg", 1
.FilterIndex = 1
If .Show = -1 Then
StrPath = .SelectedItems(1)
For Each vrtSelectedItem In .SelectedItems
Set mg2 = ActiveDocument.Range
mg2.Collapse wdCollapseEnd
doc.InlineShapes.AddPicture _
FileName:=vrtSelectedItem, _
LinkToFile:=False, SaveWithDocument:=True, Range:=mg2
SetAttr vrtSelectedItem, vbNormal
Kill vrtSelectedItem
Next vrtSelectedItem
Else
MsgBox ("No Images Selected")
ActiveDocument.Close
Application.Quit
Exit Sub
End If
End With
Set fd = Nothing
' change the page orientation to landscape
With ActiveDocument.PageSetup
.Orientation = wdOrientLandscape
.TopMargin = InchesToPoints(0)
.BottomMargin = InchesToPoints(0)
.LeftMargin = InchesToPoints(0)
.RightMargin = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(11.69)
.PageHeight = InchesToPoints(8.27)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.VerticalAlignment = wdAlignVerticalTop
.BookFoldPrintingSheets = 1
End With
With Selection.ParagraphFormat
.LeftIndent = InchesToPoints(0)
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
End With
'pasting the CGM files
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
Dim oILShp As InlineShape
For Each oILShp In ActiveDocument.InlineShapes
oILShp.Select
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Next
For Each oILShp In ActiveDocument.InlineShapes
With oILShp
.Height = InchesToPoints(8.27)
.Width = InchesToPoints(11.69)
End With
Next
' converting the file to PDF
StrNewPath = Left(StrPath, InStrRev(StrPath, "\", -1) - 1)
StrNewPath = Left(StrNewPath, InStrRev(StrNewPath, "\", -1))
strDocName = Replace(StrPath, "\", Chr(45), 1, (Len(StrPath) - Len(Replace(StrPath, "\", ""))) - 2)
strDocName = Right(strDocName, Len(StrPath) - InStr(strDocName, "\"))
strDocName = Left(strDocName, InStrRev(strDocName, "\", -1) - 1)
ActiveDocument.ExportAsFixedFormat OutputFileName:= _
StrNewPath & strDocName & ".pdf", ExportFormat:= _
wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:= _
wdExportOptimizeForPrint, Range:=wdExportAllDocument, From:=1, To:=1, _
Item:=wdExportDocumentContent, IncludeDocProps:=True, KeepIRM:=True, _
CreateBookmarks:=wdExportCreateNoBookmarks, DocStructureTags:=True, _
BitmapMissingFonts:=True, UseISO19005_1:=False
'deleting the folder
Set fso = CreateObject("Scripting.FilesystemObject")
Set fold = fso.GetFolder(StrNewPath & strDocName)
Set files = fold.files
If files.Count = 0 Then
SetAttr StrNewPath & strDocName, vbNormal
RmDir StrNewPath & strDocName
End If
Selection.WholeStory
Selection.Delete
'changing the word document to default
ActiveDocument.Content.Orientation = wdTextOrientationHorizontal
With ActiveDocument.PageSetup
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(1)
.BottomMargin = InchesToPoints(1)
.LeftMargin = InchesToPoints(0.69)
.RightMargin = InchesToPoints(0.69)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.SectionStart = wdSectionNewPage
.VerticalAlignment = wdAlignVerticalTop
End With
ActiveDocument.Close
Application.Quit
End Sub
Private Sub Document_Open()
Call InsertImages
End Sub
[/VBA]
is it possible to combine both the file to perform a single step preferably in the Excel file itself, do provide me your feedback or solution if it can be achieved in any other means
i have attached the excel fileFile Searcher.xlsm
Reply With Quote
Originally Posted by patel
