PDA

View Full Version : Help to execute a word macro within a excel macro



Kumarcoolz
06-15-2013, 05:02 AM
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.:think:



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
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



the VBA Code used on the Word document is below
convert the pictures in the folder into pdf
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


:help 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:help

i have attached the excel file10150

patel
06-15-2013, 05:25 AM
Show please desired result

Kumarcoolz
06-15-2013, 08:11 AM
Show please desired result

HI patel
the excel macro copies a folder containing a 4-5 picture (JPEG) from a database and copy it to the desired location (say Desktop). then the word macro is used to select the entire pictures in the folder and save it as a single PDF file with predefined page setting as saves it on the same location .

Now my desired intention was to convert pictures in folder into PFD directly from excel (with out having to manually open word) and save in the desired location in click of button.

i hope i have made my desired result clear

i was told we cannot use word macro in excel and vice versa. just wanted to know if there is any other way to do it.