I'm trying to add multiple pictures in a word document using vb.net but on the second picture, trhows the following error: System.Runtime.InteropServices.COMException: 'Error HRESULT E_FAIL has been returned from a call to a COM component.', I think I might dispose some variable but I don't know which.
this is my code:
Sub LoadPics()
Dim wdWrapFront As Integer = 3
Dim wdRelativeVerticalPositionPage As Integer = 1
Dim objWordApp As Word.Application
objWordApp = New Word.Application
Dim objDoc As Word.Document
Dim objSelection
objDoc = objWordApp.Documents.Open("Document.doc")
Dim objShapes As Word.InlineShapes
objShapes = objDoc.InlineShapes
Dim oShape As Word.Shape
objWordApp.Visible = False
objSelection = objWordApp.Selection
Dim FL As string = ""
For c As Integer = 0 to 10
FL = "file.png"
If IO.File.Exists(FL) Then
oShape = objShapes.AddPicture(FL).ConvertToShape()'<<<---here is the problem
With oShape
.WrapFormat.Type = wdWrapFront
.LockAspectRatio = False
.Height = objWordApp.CentimetersToPoints(5.08)
.Width = objWordApp.CentimetersToPoints(10.16)
.RelativeVerticalPosition = wdRelativeVerticalPositionPage
.Top = objWordApp.CentimetersToPoints(TopValue)
.Left = objWordApp.CentimetersToPoints(LeftValue)
End With
Else
MsgBox("File doesn't exist" & vbCrLf & FL)
End If
Next
objWordApp.Visible = True
End Sub
I was able to solve the problem by simply changing this line
objWordApp.Visible = True
I don't know which was the problem with that line but it works now
Related
I have an existing piece of code (see below) for importing a batch of photos and creating a slide show. At present, the code is creating these slides on a blank background with a title only. How can I modify it so it will choose a specific slide layout from the Master slides? I know it has something to do with this line in the code:
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
I looked here and tried some ideas but I just keep getting bugs: Applying layout to a slide from specific Master
Here's the full program:
Sub ImportStuffFromTextFile()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
Set oSld = ActivePresentation.Slides.Add(ActivePresentation.Slides.Count + 1, ppLayoutTitleOnly)
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
When you say you keep getting bugs, what do you mean?
Are you getting error messages? If so, what are the error numbers/descriptions? Where does the code break?
If not, and you're getting 'bugs', what should the final output look like and how does this differ from that?
I would say that one big unknown here is the text file input. According to your code, it seems as though it needs to have a series of filenames and corresponding picture descriptions on each line of the text file, separated by a tab. Critically, it must be a tab and not 2 spaces or 4 spaces or 10 spaces or a hyphen ... it must be a tab. Is that the structure of the text file you're using as input?
PowerPoint treats built-in layouts differently than custom ones. You can't call a custom layout by name. Instead, you have to loop through each custom layout to find the one that has the right name, then use it:
Sub AddSlideFromCustomLayout()
Dim oLayout As CustomLayout
Dim oSlide As Slide
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSlide = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
End Sub
Here's your listing with the code replacing the Set oSld line:
Sub ImportStuffFromTextFile()
Dim oLayout As CustomLayout
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
Dim fs As Object
Dim f As Object
Dim PicDesc() As String
Dim strFile As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Add "Text Files", "*.txt"
.AllowMultiSelect = False
.InitialFileName = ActivePresentation.Path
If .Show = -1 Then
strFile = .SelectedItems.Item(1)
End If
If strFile = "" Then Exit Sub
End With
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strFile, 1, 0)
Do While Not f.AtEndOfStream
PicDesc = Split(f.readline, Chr(9))
For Each oLayout In ActivePresentation.SlideMaster.CustomLayouts
If oLayout.Name = "Custom Layout Name" Then
Set oSld = ActivePresentation.Slides.AddSlide(ActivePresentation.Slides.Count + 1, oLayout)
End If
Next oLayout
Set oPic = oSld.Shapes.AddPicture(FileName:=PicDesc(0), LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0)
If oSld.Shapes.HasTitle Then
oSld.Shapes.Title.TextFrame.TextRange.Text = PicDesc(1)
With oPic
.Height = 469.875
.Width = 626.325
.Left = ActivePresentation.PageSetup.SlideWidth / 2 - .Width / 2
.Top = oSld.Shapes.Title.Top + oSld.Shapes.Title.Height + 7
End With
End If
Set oPic = Nothing
Set oSld = Nothing
Loop
Set f = Nothing
Set fs = Nothing
End Sub
When opening Outlook 2016, how can I to open two windows on startup, one with a mail, one with specific calendars selected?
Calendars are shared. I found a code that opens two windows, but how can I set up the window with a specific calendar selected.
I researched on internet, couldn't find anything.
Private Sub Application_Startup()
Dim xCalendar As Folder
Dim xInbox As Folder
Dim xExplorer As Outlook.Explorer
Dim xWidth, xHeight As Integer
On Error Resume Next
xWidth = Int(GetSystemMetrics32(0) / 4) + 60
xHeight = GetSystemMetrics32(1)
Set xInbox = Outlook.Application.ActiveExplorer.CurrentFolder
xInbox.Display
Set Application.ActiveExplorer.CurrentFolder = xInbox
Set xExplorer = Application.ActiveExplorer
With xExplorer
.WindowState = olNormalWindow
.Top = 0
.Left = 0
.Height = xHeight
.Width = xWidth
End With
Set xCalendar = Outlook.Session.GetDefaultFolder(olFolderCalendar)
xCalendar.Display
Set xExplorer = Application.ActiveExplorer
With xExplorer
.WindowState = olNormalWindow
.Top = 0
.Left = xWidth
.Height = xHeight
.Width = xWidth
End With
Set xExplorer = Application.ActiveExplorer
With xExplorer
.WindowState = olNormalWindow
.Top = 0
.Left = xWidth * 2
.Height = xHeight
.Width = xWidth
End With
Set xExplorer = Application.ActiveExplorer
With xExplorer
.WindowState = olNormalWindow
.Top = 0
.Left = xWidth * 3
.Height = xHeight
.Width = xWidth
End With
End Sub
I expect this: Click to open Outlook, two windows open, one regular mail, and one with a specific calendar selected.
This is what you're looking for. To use a custom group name, just set accordingly this line:
Set objGroup = .Item("group name")
Here the full code:
Dim WithEvents objPane As NavigationPane
'This goes on ThisOutlookSession
Private Sub Application_Startup()
Set objPane = Application.ActiveExplorer.NavigationPane
End Sub
Private Sub objPane_ModuleSwitch(ByVal CurrentModule As NavigationModule)
Dim objPane As NavigationPane
Dim objModule As CalendarModule
Dim objGroup As NavigationGroup
Dim objNavFolder As NavigationFolder
Dim objCalendar As Folder
Dim objFolder As Folder
Dim i As Integer
If CurrentModule.NavigationModuleType = olModuleCalendar Then
Set Application.ActiveExplorer.CurrentFolder = Session.GetDefaultFolder(olFolderCalendar)
DoEvents
Set objCalendar = Session.GetDefaultFolder(olFolderCalendar)
Set objPane = Application.ActiveExplorer.NavigationPane
Set objModule = objPane.Modules.GetNavigationModule(olModuleCalendar)
With objModule.NavigationGroups
Set objGroup = .GetDefaultNavigationGroup(olMyFoldersGroup)
' To use a different group
Set objGroup = .Item("group name")
End With
For i = 1 To objGroup.NavigationFolders.Count
Set objNavFolder = objGroup.NavigationFolders.Item(i)
Select Case i
' Enter the calendar index numbers you want to open
Case 1, 3, 4
objNavFolder.IsSelected = True
' Set to True to open side by side
objNavFolder.IsSideBySide = False
Case Else
objNavFolder.IsSelected = False
End Select
Next
' set the view here
End If
Set objPane = Nothing
Set objModule = Nothing
Set objGroup = Nothing
Set objNavFolder = Nothing
Set objCalendar = Nothing
Set objFolder = Nothing
End Sub
I want to Export large data stock from Access to Excel. I'm doing that with a form.
My code with "DoCmd.TransferSpreadsheet acExport..." works normally, but the program breaks off because of the large data stock.
Perhaps with queries I can solve this Problem, or what do you think?
I am thankful for each tip! =)
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'=======================
you can you use below code: this will copy the datesheet view in your form and copy paste it in to one excel file .For this you just drag one sub form control from tool box in to your form and set the property of this sub form's source data as your query name and replace the sub form name in the code
Private Sub Command48_Click()
On Error GoTo Command13_Click_Err
Me.subformName.SetFocus
'DoCmd.GoToControl "Policy Ref"
DoCmd.RunCommand acCmdSelectAllRecords
DoCmd.RunCommand acCmdCopy
Dim xlapp As Excel.Application
Set xlapp = CreateObject("Excel.Application")
With xlapp
.Workbooks.Add
.ActiveSheet.PasteSpecial Format:="Text", Link:=False, DisplayAsIcon:= _
False
.Cells.Select
.Cells.EntireColumn.AutoFit
.Visible = True
.Range("a1").Select
End With
Command13_Click_Exit:
Exit Sub
Command13_Click_Err:
MsgBox Error$
Resume Command13_Click_Exit
End sub
'''PPT
Sub pptExoprort()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationAutomatic
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim slideNum As Integer
Dim chartName As String
Dim tableName As String
Dim PPTCount As Integer
Dim PPSlideCount As Long
Dim oPPTShape As PowerPoint.Shape
Dim ShpNm As String
Dim ShtNm As String
Dim NewSlide As String
Dim myChart As PowerPoint.Chart
Dim wb As Workbook
Dim rngOp As Range
Dim ro As Range
Dim p As Integer
Dim v, v1, v2, v3, Vtot, VcaGr
Dim ws As Worksheet
Dim ch
Dim w As Worksheet
Dim x, pArr
Dim rN As String
Dim rt As String
Dim ax
Dim yTbN As String
'Call InitializeGlobal
''start year offset
prodSel = shtSet.Range("rSelProd")
x = shtSet.Range("rngMap").Value
pArr = fretPrVal(x, prodSel)
TY = 11 'number of years in chart
ThisWorkbook.Activate
Set w = ActiveSheet
Set PPApp = GetObject("", "Powerpoint.Application") '******************
PPTCount = PPApp.Presentations.Count
If PPTCount = 0 Then
MsgBox ("Please open a PPT to export the Charts!")
Exit Sub
End If
Set PPPres = PPApp.ActivePresentation '******************
For j = 0 To UBound(pArr)
If j = 0 Then
rN = "janport"
slideNum = 3
yTbN = "runport"
Else
rN = "janprod" & j
slideNum = 3 + j
yTbN = "runprod" & j
End If
chartName = "chtSalesPort"
Set PPSlide = PPPres.Slides(slideNum) '**************
PPApp.ActiveWindow.View.GotoSlide PPSlide.SlideIndex
Set myChart = PPSlide.Shapes(chartName).Chart '******************
myChart.ChartData.Activate '********************
Set wb = myChart.ChartData.Workbook '***********
Set ws = wb.Worksheets(1) '**************
Set rngOp = w.Range(rN).Offset(0, 1).Resize(12, 6)
Set ro = rngOp
' v1 = ro.Offset(1, 22).Resize(Lc, 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$B$" & Ty + 1)
'ws.ListObjects("Table1").Resize Range("$A$1:$" & Chr(Lc + 1 + 64) & "$" & Ty + 1)
ws.Range("B2:g13").ClearContents '***********
rngOp.Copy '**********
ws.Range("B2:g13").PasteSpecial xlPasteValues '******************
End Sub
Sub Picture62_Click()
Dim charNamel As String
Dim leftm As Integer
Dim toptm As Integer
charNamel = "Chart 1"
leftm = 35
toptm = 180
Call chartposition(leftm, toptm, charNamel)
End Sub
Sub chartposition(leftm, toptm, charNamel)
ActiveSheet.ChartObjects(charNamel).Activate
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
Dim activslidenumber As Integer
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
' If newPowerPoint.Presentations.Count = 0 Then
' newPowerPoint.Presentations.Add
' End If
'Show the PowerPoint
newPowerPoint.Visible = True
On Error GoTo endd:
activslidenumber = Str(GetActiveSlide(newPowerPoint.ActiveWindow).SlideIndex)
Set activeSlide = newPowerPoint.ActivePresentation.Slides(activslidenumber)
ActiveChart.ChartArea.Copy
On Error GoTo endddd:
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteDefault).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'activeSlide.Shapes.PasteSpecial(DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse).Select
endddd:
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = leftm
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = toptm
GoTo enddddd:
endd:
MsgBox ("Please keep your PPT file opened")
enddddd:
End Sub
I am placing picture in my worksheet using a URL. The code works great except "on error resume next" places the previous cell's (good) value in the cell where the error occurred instead of the cell it should (one row up). It then continues placing values where they belong until there is another error.
I have tried placing the "on error resume next" in different areas of the code, but haven't been able to fix the issue. Is it a matter of where the error handling is placed, or do I need to have a better error handler?
Thank you,
Andy
Sub InsertPic()
On Error Resume Next
Dim pic As String
Dim myPicture As Picture
Dim rng As Range
Dim cl As Range
Set rng = Range("F2:F1131")
For Each cl In rng
pic = cl.Offset(0, -1)
Set myPicture = ActiveSheet.Pictures.Insert(pic)
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
Next
End Sub
If you need to check if the URL exists then maybe a helper function will suffice?
Sub InsertPic()
Dim pic As String
Dim myPicture As Picture
Dim rng As Range 'E3:E1132
Dim cl As Range 'iterator
Set rng = Range("F2:F1131")
For Each cl In rng
pic = cl.Offset(0, -1)
if URLExists(pic) then
Set myPicture = ActiveSheet.Pictures.Insert(pic)
With myPicture
.ShapeRange.LockAspectRatio = msoFalse
.Width = cl.Width
.Height = cl.Height
.Top = Rows(cl.Row).Top
.Left = Columns(cl.Column).Left
End With
end if
Next
End Sub
'ref: http://www.mrexcel.com/forum/excel-questions/567315-check-if-url-exists-so-then-return-true.html
Function URLExists(url As String) As Boolean
Dim Request As Object
Dim ff As Integer
Dim rc As Variant
On Error GoTo EndNow
Set Request = CreateObject("WinHttp.WinHttpRequest.5.1")
With Request
.Open "GET", url, False
.Send
rc = .StatusText
End With
Set Request = Nothing
If rc = "OK" Then URLExists = True
Exit Function
EndNow:
End Function
This is the code I wrote to copy over a picture from Excel to PowerPoint. I have other code that preps the PowerPoint slide, which should have no factor on this. For some reason this code is not working. It is giving me the error that no slide is currently in view. Thanks in advance for the help.
Sub CopyPicToPPt()
Dim pptApp As PowerPoint.Application
Dim pptPresent As Presentation
Dim sldPPT As Slide
Dim shpPic As Shape
Dim oLayout As CustomLayout
Dim x As PowerPoint.Shape
ActiveWorkbook.Sheets("Sheet1").Select
Set shpPic = Sheet4.Shapes("Picture 3") '<< --- Pic Name
shpPic.CopyPicture
Set pptApp = GetObject(class:="PowerPoint.Application")
pptApp.Visible = True
pptApp.Activate
Set pptPresent = pptApp.ActivePresentation
Set sldPPT = pptApp.ActiveWindow.View.Slide
sldPPT.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
pptApp.ActiveWindow.Selection.ShapeRange.Left = 24
pptApp.ActiveWindow.Selection.ShapeRange.Top = 6
pptApp.ActiveWindow.Selection.ShapeRange.Height = 55
pptApp.ActiveWindow.Selection.ShapeRange.width = 672
End Sub
After a little fiddling and some help from a friend I think I have it! - Cheers
Sub CopyPicToPPt()
Dim pptApp As PowerPoint.Application
Dim pptPresent As Presentation
Dim sldPPT As Slide
Dim shpPic As Shape
Dim oLayout As CustomLayout
Dim x As PowerPoint.Shape
ActiveWorkbook.Sheets("Sheet1").Visible = True
ActiveWorkbook.Sheets("Sheet1").Select
Set shpPic = Sheet4.Shapes("Picture 3") '<< --- Pic Name
shpPic.CopyPicture
Set pptApp = GetObject(class:="PowerPoint.Application")
pptApp.Visible = True
pptApp.Activate
pptApp.ActivePresentation.Slides(1).Select
Set pptPresent = pptApp.ActivePresentation
Set sldPPT = pptApp.ActivePresentation.Slides(1)
sldPPT.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
pptApp.ActiveWindow.Selection.ShapeRange.LockAspectRatio = False
pptApp.ActiveWindow.Selection.ShapeRange.Left = 24
pptApp.ActiveWindow.Selection.ShapeRange.Top = 6
pptApp.ActiveWindow.Selection.ShapeRange.Height = 55
pptApp.ActiveWindow.Selection.ShapeRange.width = 672
ActiveWorkbook.Sheets("Sheet1").Visible = False
End Sub