I have the following old VB6 working code to add a custom button (in a new toolbar) in Outlook
Dim oApp As Object
Dim objIns As Object
Dim objCBar As Object
Dim lpobjButton As Object
Set oApp = CreateObject("Outlook.Application")
Set objIns = oApp.ActiveExplorer
Set objCBar = objIns.CommandBars.Add(barra)
Set lpobjButton = objCBar.Controls.Add()
With lpobjButton
.Caption = "myLabel"
.HyperlinkType = 1
.ToolTipText = "myLink"
End With
I'm trying to add an image to the button, but when I execute the following
Dim oApp As Object
Dim objIns As Object
Dim objCBar As Object
Dim lpobjButton As Object
Dim picPicture As IPictureDisp
Set oApp = CreateObject("Outlook.Application")
Set objIns = oApp.ActiveExplorer
Set objCBar = objIns.CommandBars.Add(barra)
Set picPicture = stdole.StdFunctions.LoadPicture(App.Path & "\myimage.bmp")
Set lpobjButton = objCBar.Controls.Add()
With lpobjButton
.Caption = "myLabel"
.Picture = picPicture '<--- runtime error 8000ffff here
.HyperlinkType = 1
.ToolTipText = "myLink"
End With
I get a runtime error
(8000ffff) when assigning picPicture to .Picture.
myimage.bmp is a 16x16 image (256 color)
I also tried with 32x32 pixels (256 color) but no luck.
I'm using OL 2007
any idea?
thanks
Change your code to use the PasteFace method which copies the picture from the clipboard. Of course that means you have to put your picture on the clipboard first.
With lpobjButton
.Caption = "myLabel"
Clipboard.Clear
Clipboard.SetData picPicture, vbCFBitmap
.PasteFace
''.Picture = picPicture '<--- runtime error 8000ffff here
.HyperlinkType = 1
.ToolTipText = "myLink"
End With
Related
We have switched over to office 365 / outlook.
we have a legacy application in VB6 the was working fine with the previous version of outlook. but now we are having issues with an automated email with in VB6, that sends daily reports. Can someone tell me what is the equivalent of the following code is and what reference i need to point to?`
Dim mstrEmailTo As String 'email to addresses
Dim mstrEmailCC As String 'email cc addresses
mstrEmailTo = Text1.Text
mstrEmailCC = "TestEmail"
Dim oApp As Outlook.Application
Dim oCB As Office.CommandBar
Dim oCBTools As Office.CommandBarPopup
Dim oCBSelect As Office.CommandBarButton
Dim oInsp As Outlook.Inspector
Dim oCont As Outlook.MailItem
Set oApp = New Outlook.Application
Dim oInspLeft As Integer
Dim oContTo As String
Dim oContCC As String
Set oCont = oApp.CreateItem(olMailItem)
If mstrEmailTo <> "" Then
'objRecipients.AddMultiple mstrEmailTo, CdoTo
oCont.To = mstrEmailTo
End If
If mstrEmailCC <> "" Then
'objRecipients.AddMultiple mstrEmailCC, CdoCc
oCont.CC = mstrEmailCC
End If
'Set objNewMsg.Recipients = mobjSession.AddressBook(objRecipients, "Select recipients for the Daily report ...", , True, 2)
Set oInsp = oCont.GetInspector
oInsp.Display vbModeless
oInsp.WindowState = olNormalWindow
oInspLeft = oInsp.Left
oInsp.Left = -10000 'Set the Inspector off screen.
'Set to 250 to return it to viewable location
Set oCB = oInsp.CommandBars("Menu Bar")
Set oCBTools = oCB.Controls("&Tools")
Set oCBSelect = oCBTools.Controls("Address &Book...")
oCBSelect.Execute
oContTo = oCont.To
oContCC = oCont.CC
oCont.Close olDiscard
oInsp.Left = oInspLeft
Set oCont = Nothing
Set oCBSelect = Nothing
Set oCBTools = Nothing
Set oCB = Nothing
Set oApp = Nothing`
You don't need to simulate a button click to show an address book. You need to use SelectNamesDialog object for that - see https://learn.microsoft.com/en-us/office/vba/api/outlook.selectnamesdialog
How do you search for the last empty cell in an excel sheet from a vsto outlook addin?
I have the following code (not compiling)
Imports Excel = Microsoft.Office.Interop.Excel
Dim ExcelApp As New Excel.Application
Dim ExcelWorkbook As Excel.Workbook
Dim ExcelWorkSheet As Excel.Worksheet= ExcelWorkbook.Worksheets(1)
Dim ExcelRange As Excel.Range = ExcelWorkSheet.Range("A1","A600")
Dim currentFind As Excel.Range = Nothing
Dim firstFind As Excel.Range = Nothing
currentFind = ExcelRange.Find("*", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
While Not currentFind Is Nothing
' Keep track of the first range you find.
If firstFind Is Nothing Then
firstFind = currentFind
' If you didn't move to a new range, you are done.
ElseIf currentFind.Address = firstFind.Address Then
Exit While
End If
currentFind = ExcelRange.FindNext(currentFind)
End While
ExcelWorkbook.ActiveSheet.range(currentFind).Select()
I have updated it according to Scott Holtzman's comments but now I get an error message: HRESULT: 0x800A03EC
The code does not have the correct hierarchy according to the Object Model.
You cannot define a Range object without first defining a Worksheet object, which needs a Workbook object before it can be defined.
Try this:
Set ExcelApp = New Excel.Application
Dim ExcelWorkbook as Excel.Workbook
Set ExcelWorkbook = ExcelApp.Workbooks.Open("myPath") 'actually opens a workbook to work with
Dim ExcelWorksheet as Excel.Worksheet
Set ExcelWorksheet = ExcelWorkbook.Worksheets("mySheet")
Dim currentFind As Excel.Range = Nothing
Dim firstFind As Excel.Range = Nothing
Dim Fruits As Excel.Range = ExcelWorksheet.Range("A1", "A200")
Set currentFind = Fruits.Find("apples", , Excel.XlFindLookIn.xlValues, Excel.XlLookAt.xlPart, Excel.XlSearchOrder.xlByRows, Excel.XlSearchDirection.xlNext, False)
...
Set currentFind = Fruits.FindNext(currentFind)
SOLVED: I have the following code (now compiling!)
Imports Excel = Microsoft.Office.Interop.Excel
Dim ExcelApp As New Excel.Application
Dim ExcelWorkbook As Excel.Workbook
Dim ExcelWorkSheet As Excel.Worksheet= ExcelWorkbook.Worksheets(1)
Dim LastRow As Integer
LastRow = ExcelWorkSheet.Columns(1).Find("*", , , , Excel.XlSearchOrder.xlByColumns, Excel.XlSearchDirection.xlPrevious).Row
ExcelWorkSheet.Range("A" & LastRow).Select()
My error was in the actual property library choice. Beware to choose:
XlSearchOrder.xlByColumns, Excel.XlSearchDirection.xlPrevious
I have a function that can get the page's number of the pdf file.
Public Function GetNumPages(ByVal PdfFile As String) As Long
Dim objTempDoc As Object
Dim fso As FileSystemObject
Set fso = New FileSystemObject
If fso.FileExists(PdfFile ) Then
Set objTemp = CreateObject("AcroExch.PDDoc")
objTemp.Open pstrPdfFilename
GetNumPages = objTemp.GetNumPages
objTemp.Close
Set objTemp = Nothing
End If
Set fso = Nothing
End Function
I want to get the last line's context in last page of pdf file.
I have found this API, but I don't know how to use it.
Will it return the context that I want?
PDOCContext PDDocGetOCContext(PDDoc pdDoc)
I tried this way to use API, but it was fail.
Set objTempDoc = CreateObject("AcroExch.PDDoc")
objTempDoc.Open PdfFile
myPDFPage = objTempDoc.GetOCContext
Can call this Function to get the text of last page.
Public Function GetPDFText(ByVal pstrPdfFilename As String) As String
Dim PDDoc As Object
Dim CAcroRect As New Acrobat.AcroRect
Dim PDPage As Acrobat.AcroPDPage
Dim PDTxtSelect As Acrobat.AcroPDTextSelect
Dim CArcoPoint As Acrobat.AcroPoint
Dim iNumWords As Integer
Dim iMax As Long
Dim arPdfLines() As String
Dim i As Integer
Dim fso As FileSystemObject
Set fso = New FileSystemObject
If fso.FileExists(pstrPdfFilename) Then
Set PDDoc = CreateObject("AcroExch.PDDoc")
PDDoc.Open pstrPdfFilename
Set PDPage = PDDoc.AcquirePage(PDDoc.GetNumPages() - 1)
Set CArcoPoint = PDPage.GetSize()
CAcroRect.Top = CArcoPoint.y
CAcroRect.Left = 0
CAcroRect.Right = CArcoPoint.x
CAcroRect.bottom = 0
Set PDTxtSelect = PDDoc.CreateTextSelect(PDDoc.GetNumPages() - 1, CAcroRect)
If PDTxtSelect Is Nothing Then
iNumWords = 0
iMax = 0
GetPDFLastLineText = ""
Else
iNumWords = PDTxtSelect.GetNumText
iMax = iNumWords - 1
Dim ii As Long
For ii = 0 To iMax
GetPDFLastLineText = GetPDFLastLineText & PDTxtSelect.GetText(ii)
Next
End If
PDDoc.Close
End If
Set fso = Nothing
Set PDDoc = Nothing
Set CAcroRect = Nothing
Set PDPage = Nothing
Set PDTxtSelect = Nothing
Set CArcoPoint = Nothing
End Function
I am trying to display an image from a SpreadSheet(OpenOffice) into my PictureBox control and here is my code.
Dim objServiceManager As Object
Dim objDesktop As Object
Dim objDocument As Object
Dim objText As Object
Dim objCursor As Object
Dim oDoc As Object
Dim ARG()
Dim oGraph As Object
Dim oView As Object
Dim oDrawPage As Object
Dim oSheet As Object
Dim oimage As Object
Dim osize As Object
Dim Cell As Object
Dim GraphURL As String
Set objServiceManager = CreateObject("com.sun.star.ServiceManager")
Set objDesktop = objServiceManager.createInstance("com.sun.star.frame.Desktop")
Set osize = objServiceManager.Bridge_GetStruct("com.sun.star.awt.Size")
Set opos = objServiceManager.Bridge_GetStruct("com.sun.star.awt.Point")
Set oDoc = objDesktop.loadComponentFromURL("file:///C:\Users\paul\Desktop\ACE Express - Fairview_Sample PC of Gondola.ods", "_blank", 0, ARG())
Set oSheet = oDoc.getSheets().getByIndex(0)
Set oimage = oDoc.createInstance("com.sun.star.drawing.GraphicObjectShape")
Set oView = oDoc.CurrentController
Set oDrawPage = oView.getActiveSheet.DrawPage
Set oControl = oDoc
Set oDrawPage = oDoc.getDrawPages().getByIndex(0)
Set oimage = oDrawPage.getByIndex(0)
Image1.Picture = LoadPicture(oimage.GraphicURL)
But sad to say I have this error
It is supposed to be that the image that will replace the image in my picturebox(Mountain.jpg) is this.
But it doesn't happen
Please take note of the following:
The spreadsheet used is OpenOffice Calc
Displaying the image inside Picturebox (VB6)
Update 2
The error comes from the code.
Image1.Picture = LoadPicture(oimage.GraphicURL)
I have an Access database which has a filename field, along with width and height fields for an image. Instead of populating the width and height manually, I'm trying to read the height and width from the filename alone (full file path) and then insert into a record.
The reading of dimensions is fairly trivial in most languages, but can't find much for Access VBA. All I can find is for Excel which assumes the image is already in the spreadsheet as an object.
Just try googling "Use vba to read image file dimensions"
eg
https://social.msdn.microsoft.com/Forums/office/en-US/5f375529-a002-4312-a54b-b70d6d3eb6ae/how-to-retrieve-image-dimensions-using-vba-?forum=accessdev
for example
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Documents and Settings\Administrator\Desktop")
Set objFile = objFolder.ParseName("file_name.bmp")
MsgBox objFile.ExtendedProperty("Dimensions")
You can extract what you need from the string displayed in the message box
You can do this:
Dim objShell As Object
Dim objFolder As Object
Dim objFile As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace("C:\Documents and Settings\Administrator\Desktop")
Set objFile = objFolder.ParseName("file_name.bmp")
MsgBox objFile.ExtendedProperty("Dimensions")
That messagebox should give you something along the lines of "300 X 500" (or whatever the Length X Width is). If you need the individual dimensions, you'll need to use something like
FileLen = CInt(Trim(Mid(objFile.ExtendedProperty, 2, InStr(objFile.ExtendedProperty, "X") - 1)))
and
FileWid = CInt(Trim(Mid(objFile.ExtendedProperty, InStr(objFile.ExtendedProperty, "X") + 2, Len(objFile.ExtendedProperty))))
You can also accomplish this with a class, which lets you use code like this:
targetImage.PixelWidth
targetImage.PixelHeight
Create a new Class Module and name it ImageDimensions.
Paste the following code into that class module:
Class Module Code
Option Explicit
Private pPixelWidth As Long
Private pPixelHeight As Long
Private pImageFullPath As String
Public Property Get ImageFullPath() As String
ImageFullPath = pImageFullPath
End Property
Public Property Let ImageFullPath(fullPath As String)
pImageFullPath = fullPath
Dim dimensionsText As String
dimensionsText = GetImageDimensions(fullPath)
pPixelWidth = Left$(dimensionsText, InStr(dimensionsText, ",") - 1)
pPixelHeight = Mid$(dimensionsText, InStr(dimensionsText, ",") + 1)
End Property
Public Property Get PixelWidth() As Long
PixelWidth = pPixelWidth
End Property
Private Property Let PixelWidth(value As Long)
pPixelWidth = value
End Property
Public Property Get PixelHeight() As Long
PixelHeight = pPixelHeight
End Property
Private Property Let PixelHeight(value As Long)
pPixelHeight = value
End Property
Private Function GetImageDimensions(ByVal fullPath As String)
Dim fileName As String
Dim fileFolder As String
fileName = FilenameFromPath(fullPath)
fileFolder = FolderFromFilePath(fullPath)
Dim objShell As Object
Set objShell = CreateObject("Shell.Application")
Dim targetFolder As Object
Set targetFolder = objShell.Namespace(fileFolder & vbNullString)
Const IMAGE_DIMENSIONS As Long = 31
Dim dimensionsPrep As String
dimensionsPrep = targetFolder.GetDetailsOf( _
targetFolder.Items.Item(fileName & vbNullString), _
IMAGE_DIMENSIONS)
dimensionsPrep = Replace(dimensionsPrep, " x ", ",")
dimensionsPrep = Mid$(dimensionsPrep, 2, Len(dimensionsPrep) - 2)
GetImageDimensions = dimensionsPrep
End Function
Private Function FolderFromFilePath(ByVal filePath As String) As String
Dim filesystem As Object
Set filesystem = CreateObject("Scripting.FileSystemObject")
FolderFromFilePath = filesystem.GetParentFolderName(filePath) & "\"
End Function
Private Function FilenameFromPath(ByVal filePathAndName As String) As String
Dim pathLength As Long
Dim iString As String
pathLength = Len(filePathAndName)
iString = vbNullString
Dim iCount As Long
For iCount = pathLength To 1 Step -1
If Mid$(filePathAndName, iCount, 1) = Application.PathSeparator Then
FilenameFromPath = iString
Exit Function
End If
iString = Mid$(filePathAndName, iCount, 1) & iString
Next iCount
FilenameFromPath = filePathAndName
End Function
Example Usage
Put this code in a regular code module (not a class module):
Sub ExampleImageDimensions()
Dim targetImage As ImageDimensions
Set targetImage = New ImageDimensions
targetImage = "C:\Users\ChrisB\Downloads\Screenshot.jpg"
Debug.Print targetImage.PixelHeight
Debug.Print targetImage.PixelWidth
End Sub